Blessed Tcl_Obj Values

A blessing mechanism that allows complex structs with raw pointers to be easily encoded into Tcl (I usually use lists) without the overhead of converting them all into opaque pointers. At its most useful when you want to examine part of the state too...
inline char *
Memcpy(char *dst, char *src, size_t length)
{
  if (dst == NULL) {
    dst = (char *) ckalloc(length);
  }
  memcpy(dst, src, length);
  return dst;
}

inline void     stateInitialiseHash(Tcl_HashTable *);
inline Tcl_Obj *stateBless(Tcl_Obj *, Tcl_HashTable *);
inline Tcl_Obj *stateGet(Tcl_Interp *, Tcl_Obj *);
inline void     stateInvalidate(Tcl_HashTable *);

/* Blessed (semi-auto cleaned) simulator state references */
 
static int  stateSet(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void statePrint(Tcl_Obj *objPtr);
static void stateDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void stateFree(Tcl_Obj *objPtr);
static struct Tcl_ObjType stateType = {
   "Cleaned Reference",
   stateFree, stateDup, statePrint, stateSet
};
 
static int
stateSet(
      Tcl_Interp *interp,
      Tcl_Obj *objPtr)
{
   if (interp) {
     Tcl_AppendResult(interp, "cannot (re)build object of type \"",
                      stateType.name, "\"", NULL);
   }
   return TCL_ERROR;
}
 
static void
statePrint(
      Tcl_Obj *objPtr)
{
   Tcl_Obj *contents = objPtr->internalRep.twoPtrValue.ptr1;
   char *bytes = Tcl_GetStringFromObj(contents, &objPtr->length);
 
   objPtr->bytes = Memcpy(NULL, bytes, objPtr->length+1);
}
 
static void
stateDup(
     Tcl_Obj *srcPtr,
     Tcl_Obj *dupPtr)
{
   Tcl_Obj *contents = srcPtr->internalRep.twoPtrValue.ptr1;
   Tcl_HashTable *hash = srcPtr->internalRep.twoPtrValue.ptr2;
   Tcl_HashEntry *hent;
   int isNew;
 
   dupPtr->internalRep.twoPtrValue.ptr1 = contents;
   dupPtr->internalRep.twoPtrValue.ptr2 = hash;
   dupPtr->typePtr = &stateType;
   Tcl_IncrRefCount(contents);
   hent = Tcl_CreateHashEntry(hash, (char *)dupPtr, &isNew);
   if (hent) {
     Tcl_SetHashValue(hent, dupPtr);
   }
}
 
static void
stateFree(
      Tcl_Obj *objPtr)
{
   Tcl_Obj *contents =   objPtr->internalRep.twoPtrValue.ptr1;
   Tcl_HashTable *hash = objPtr->internalRep.twoPtrValue.ptr2;
   Tcl_HashEntry *hent;
 
   Tcl_DecrRefCount(contents);
   hent = Tcl_FindHashEntry(hash, (char *)objPtr);
   if (hent) {
     Tcl_DeleteHashEntry(hent);
   }
}
 
/* Invalidate all state-reference objects referred to in the given
 * hash table, nuking the hash at the same time. */
inline void
stateInvalidate(
      Tcl_HashTable *hash)
{
   Tcl_HashSearch hsearch;
   Tcl_HashEntry *hent;
 
   hent = Tcl_FirstHashEntry(hash, &hsearch);
   for (; hent ; hent=Tcl_NextHashEntry(&hsearch)) {
     Tcl_Obj *objPtr = Tcl_GetHashValue(hent);
     Tcl_Obj *contents = objPtr->internalRep.twoPtrValue.ptr1;
 
     if (!objPtr->bytes) {
       /* Make sure that there is still something there for users to see */
       statePrint(objPtr);
     }
 
     /* Delete the contents - this is the crucial bit */
     Tcl_DecrRefCount(contents);
 
     /* Mark the object as untyped */
     objPtr->typePtr = NULL;
   }
   Tcl_DeleteHashTable(hash);
}
 
/* Given a state object (AKA a complex list thingy) make it into a
 * blessed state-reference which ensures that it will be invalidated
 * at the correct time. */
inline Tcl_Obj *
stateBless(
      Tcl_Obj *stateObject,
      Tcl_HashTable *hash)
{
   Tcl_Obj *newObj = Tcl_NewObj();
   Tcl_HashEntry *hent;
   int isNew;
 
   /* Get rid of anything present by default in new objects */
   if (newObj->bytes) {
     Tcl_InvalidateStringRep(newObj);
   }
 
   /* Make the internal representation */
   newObj->typePtr = &stateType;
   newObj->internalRep.twoPtrValue.ptr1 = stateObject;
   Tcl_IncrRefCount(stateObject);
   newObj->internalRep.twoPtrValue.ptr2 = hash;
 
   /* Store a reference to the object in the hash */
   hent = Tcl_CreateHashEntry(hash, (char *)newObj, &isNew);
   if (hent) {
     Tcl_SetHashValue(hent, newObj);
   }
 
   return newObj;
}
 
/* Set up the state-reference hash table */
inline void
stateInitialiseHash(
      Tcl_HashTable *hash)
{
   Tcl_InitHashTable(hash, TCL_ONE_WORD_KEYS);
}
 
/* Get a state reference, but only if it is blessed.  Error otherwise */
inline Tcl_Obj *
stateGet(
      Tcl_Interp *interp,
      Tcl_Obj *objPtr)
{
   if (objPtr->typePtr != &stateType &&
       Tcl_ConvertToType(interp, objPtr, &stateType) != TCL_OK) {
     return NULL;
   }
   return objPtr->internalRep.twoPtrValue.ptr1;
}
Still to come; the explanation for all this!
DKF
tcl_obj
Category Discussion