Add a metadata mechanism (C API only; scripts can use variables) that allows

code to attach arbitrary non-NULL pointers to objects and classes. Allows
extensions (like Itcl) to store data in objects/classes without major core changes.

3 files changed, 318 insertions, 6 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index 76e0f85..9593f29 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tcl.h,v 1.210.2.5 2006/10/01 21:27:24 dkf Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.210.2.6 2006/10/19 21:06:25 dkf Exp $
  */
 
 #ifndef _TCL
@@ -2350,8 +2350,8 @@ typedef unsigned long mp_digit;
 
 /*
  * Public datatypes for callbacks and structures used in the TIP#257 (OO)
- * implementation. These are all used to implement custom types of method
- * calls.
+ * implementation. These are used to implement custom types of method calls
+ * and to allow the attachment of arbitrary data to objects and classes.
  */
 
 typedef int (*Tcl_MethodCallProc)_ANSI_ARGS_((ClientData clientData,
@@ -2360,10 +2360,21 @@ typedef int (*Tcl_MethodCallProc)_ANSI_ARGS_((ClientData clientData,
 typedef void (*Tcl_MethodDeleteProc)_ANSI_ARGS_((ClientData clientData));
 typedef int (*Tcl_MethodCloneProc)_ANSI_ARGS_((ClientData oldClientData,
 	ClientData *newClientData));
+typedef void (*Tcl_ObjectMetadataDeleteProc)_ANSI_ARGS_((
+	ClientData clientData));
+typedef ClientData (*Tcl_ObjectMetadataCloneProc)_ANSI_ARGS_((
+	ClientData clientData));
+
+/*
+ * The type of a method implementation. This describes how to call the method
+ * implementation, how to delete it (when the object or class is deleted) and
+ * how to create a clone of it (when the object or class is copied).
+ */
 
 typedef struct {
     int version;		/* Structure version field. Always to be equal
-				 * to TCL_OO_METHOD_VERSION_CURRENT.*/
+				 * to TCL_OO_METHOD_VERSION_CURRENT in
+				 * declarations. */
     const char *name;		/* Name of this type of method, mostly for
 				 * debugging purposes. */
     Tcl_MethodCallProc callProc;/* How to invoke this method. */
@@ -2385,6 +2396,33 @@ typedef struct {
 
 #define TCL_OO_METHOD_VERSION_CURRENT 1
 
+/*
+ * The type of some object (or class) metadata. This describes how to delete
+ * the metadata (when the object or class is deleted) and how to create a
+ * clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+    int version;		/* Structure version field. Always to be equal
+				 * to TCL_OO_METADATA_VERSION_CURRENT in
+				 * declarations. */
+    const char *name;
+    Tcl_ObjectMetadataDeleteProc deleteProc;
+				/* How to delete the metadata. This must not
+				 * be NULL. */
+    Tcl_ObjectMetadataCloneProc cloneProc;
+				/* How to clone the metadata. If NULL, the
+				 * metadata will not be copied. */
+} Tcl_ObjectMetadataType;
+
+/*
+ * The correct value for the version field of the Tcl_ObjectMetadataType
+ * structure. This allows new versions of the structure to be introduced
+ * without breaking binary compatability.
+ */
+
+#define TCL_OO_METHOD_VERSION_CURRENT 1
+
 #ifndef TCL_NO_DEPRECATED
     /*
      * Deprecated Tcl functions:
diff --git a/generic/tclOO.c b/generic/tclOO.c
index cbc26fc..18fb337 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOO.c,v 1.1.2.61 2006/10/15 23:14:29 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.1.2.62 2006/10/19 21:06:25 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -345,6 +345,7 @@ AllocObject(
     oPtr->mixins.list = NULL;
     oPtr->classPtr = NULL;
     oPtr->flags = 0;
+    oPtr->metadataPtr = NULL;
 
     /*
      * Initialize the traces.
@@ -536,6 +537,19 @@ ReleaseClassContents(
 	ckfree((char *) clsPtr->filters.list);
 	clsPtr->filters.num = 0;
     }
+
+    if (clsPtr->metadataPtr != NULL) {
+	FOREACH_HASH_DECLS;
+	Tcl_ObjectMetadataType *metadataTypePtr;
+	ClientData value;
+
+	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+	    metadataTypePtr->deleteProc(value);
+	}
+	Tcl_DeleteHashTable(clsPtr->metadataPtr);
+	ckfree((char *) clsPtr->metadataPtr);
+	clsPtr->metadataPtr = NULL;
+    }
 }
 
 /*
@@ -613,6 +627,19 @@ ObjectNamespaceDeleted(
     }
     Tcl_DeleteHashTable(&oPtr->privateContextCache);
 
+    if (oPtr->metadataPtr != NULL) {
+	FOREACH_HASH_DECLS;
+	Tcl_ObjectMetadataType *metadataTypePtr;
+	ClientData value;
+
+	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+	    metadataTypePtr->deleteProc(value);
+	}
+	Tcl_DeleteHashTable(oPtr->metadataPtr);
+	ckfree((char *) oPtr->metadataPtr);
+	oPtr->metadataPtr = NULL;
+    }
+
     clsPtr = oPtr->classPtr;
     if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
 	Class *superPtr, *mixinPtr;
@@ -943,6 +970,7 @@ AllocClass(
     Tcl_InitObjHashTable(&clsPtr->classMethods);
     clsPtr->constructorPtr = NULL;
     clsPtr->destructorPtr = NULL;
+    clsPtr->metadataPtr = NULL;
     return clsPtr;
 }
 
@@ -1128,6 +1156,26 @@ Tcl_CopyObjectInstance(
 	    OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
 
     /*
+     * Copy the object's metadata.
+     */
+
+    if (oPtr->metadataPtr != NULL) {
+	Tcl_ObjectMetadataType *metadataTypePtr;
+	ClientData value, duplicate;
+
+	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+	    if (metadataTypePtr->cloneProc == NULL) {
+		continue;
+	    }
+	    duplicate = metadataTypePtr->cloneProc(value);
+	    if (duplicate != NULL) {
+		Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
+			duplicate);
+	    }
+	}
+    }
+
+    /*
      * Copy the class, if present. Note that if there is a class present in
      * the source object, there must also be one in the copy.
      */
@@ -1206,6 +1254,26 @@ Tcl_CopyObjectInstance(
 	    cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr,
 		    clsPtr->destructorPtr, NULL);
 	}
+
+	/*
+	 * Duplicate the class's metadata.
+	 */
+
+	if (clsPtr->metadataPtr != NULL) {
+	    Tcl_ObjectMetadataType *metadataTypePtr;
+	    ClientData value, duplicate;
+
+	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+		if (metadataTypePtr->cloneProc == NULL) {
+		    continue;
+		}
+		duplicate = metadataTypePtr->cloneProc(value);
+		if (duplicate != NULL) {
+		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
+			    duplicate);
+		}
+	    }
+	}
     }
 
     return (Tcl_Object) o2Ptr;
@@ -1856,6 +1924,192 @@ CloneForwardMethod(
 /*
  * ----------------------------------------------------------------------
  *
+ * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
+ * Tcl_ObjectSetMetadata --
+ *
+ *	Metadata management API. The metadata system allows code in extensions
+ *	to attach arbitrary non-NULL pointers to objects and classes without
+ *	the different things that might be interested being able to interfere
+ *	with each other. Apart from non-NULL-ness, these routines attach no
+ *	interpretation to the meaning of the metadata pointers.
+ *
+ *	The Tcl_*GetMetadata routines get the metadata pointer attached that
+ *	has been related with a particular type, or NULL if no metadata
+ *	associated with the given type has been attached.
+ *
+ *	The Tcl_*SetMetadata routines set or delete the metadata pointer that
+ *	is related to a particular type. The value associated with the type is
+ *	deleted (if present; no-op otherwise) if the value is NULL, and
+ *	attached (replacing the previous value, which is deleted if present)
+ *	otherwise. This means it is impossible to attach a NULL value for any
+ *	metadata type.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_ClassGetMetadata(
+    Tcl_Class clazz,
+    const Tcl_ObjectMetadataType *typePtr)
+{
+    Class *clsPtr = (Class *) clazz;
+    Tcl_HashEntry *hPtr;
+
+    /*
+     * If there's no metadata store attached, the type in question has
+     * definitely not been attached either!
+     */
+
+    if (clsPtr->metadataPtr == NULL) {
+	return NULL;
+    }
+
+    /*
+     * There is a metadata store, so look in it for the given type.
+     */
+
+    hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+
+    /*
+     * Return the metadata value if we found it, otherwise NULL.
+     */
+
+    if (hPtr == NULL) {
+	return NULL;
+    } else {
+	return Tcl_GetHashValue(hPtr);
+    }
+}
+
+void
+Tcl_ClassSetMetadata(
+    Tcl_Class clazz,
+    const Tcl_ObjectMetadataType *typePtr,
+    ClientData metadata)
+{
+    Class *clsPtr = (Class *) clazz;
+    Tcl_HashEntry *hPtr;
+    int isNew;
+
+    /*
+     * Attach the metadata store if not done already.
+     */
+
+    if (clsPtr->metadataPtr == NULL) {
+	if (metadata == NULL) {
+	    return;
+	}
+	clsPtr->metadataPtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable));
+	Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+    }
+
+    /*
+     * If the metadata is NULL, we're deleting the metadata for the type.
+     */
+
+    if (metadata == NULL) {
+	hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+	if (hPtr != NULL) {
+	    Tcl_DeleteHashEntry(hPtr);
+	}
+	return;
+    }
+
+    /*
+     * Otherwise we're attaching the metadata. Note that if there was already
+     * some metadata attached of this type, we delete that first.
+     */
+
+    hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
+    if (!isNew) {
+	typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+    }
+    Tcl_SetHashValue(hPtr, metadata);
+}
+
+ClientData
+Tcl_ObjectGetMetadata(
+    Tcl_Object object,
+    const Tcl_ObjectMetadataType *typePtr)
+{
+    Object *oPtr = (Object *) object;
+    Tcl_HashEntry *hPtr;
+
+    /*
+     * If there's no metadata store attached, the type in question has
+     * definitely not been attached either!
+     */
+
+    if (oPtr->metadataPtr == NULL) {
+	return NULL;
+    }
+
+    /*
+     * There is a metadata store, so look in it for the given type.
+     */
+
+    hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+
+    /*
+     * Return the metadata value if we found it, otherwise NULL.
+     */
+
+    if (hPtr == NULL) {
+	return NULL;
+    } else {
+	return Tcl_GetHashValue(hPtr);
+    }
+}
+
+void
+Tcl_ObjectSetMetadata(
+    Tcl_Object object,
+    const Tcl_ObjectMetadataType *typePtr,
+    ClientData metadata)
+{
+    Object *oPtr = (Object *) object;
+    Tcl_HashEntry *hPtr;
+    int isNew;
+
+    /*
+     * Attach the metadata store if not done already.
+     */
+
+    if (oPtr->metadataPtr == NULL) {
+	if (metadata == NULL) {
+	    return;
+	}
+	oPtr->metadataPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+    }
+
+    /*
+     * If the metadata is NULL, we're deleting the metadata for the type.
+     */
+
+    if (metadata == NULL) {
+	hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+	if (hPtr != NULL) {
+	    Tcl_DeleteHashEntry(hPtr);
+	}
+	return;
+    }
+
+    /*
+     * Otherwise we're attaching the metadata. Note that if there was already
+     * some metadata attached of this type, we delete that first.
+     */
+
+    hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
+    if (!isNew) {
+	typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+    }
+    Tcl_SetHashValue(hPtr, metadata);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * PublicObjectCmd, PrivateObjectCmd, ObjectCmd --
  *
  *	Main entry point for object invokations. The Public* and Private*
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 2303f09..522346a 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOO.h,v 1.1.2.36 2006/10/15 23:14:29 dkf Exp $
+ * RCS: @(#) $Id: tclOO.h,v 1.1.2.37 2006/10/19 21:06:25 dkf Exp $
  */
 
 // vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCL.DECLS vvvvvvvvvvvvvvvvvvvvvv
@@ -46,6 +46,16 @@ Tcl_Method		Tcl_ObjectContextMethod(Tcl_ObjectContext context);
 Tcl_Object		Tcl_ObjectContextObject(Tcl_ObjectContext context);
 int			Tcl_ObjectContextSkippedArgs(
 			    Tcl_ObjectContext context);
+ClientData		Tcl_ClassGetMetadata(Tcl_Class clazz,
+			    const Tcl_ObjectMetadataType *typePtr);
+void			Tcl_ClassSetMetadata(Tcl_Class clazz,
+			    const Tcl_ObjectMetadataType *typePtr,
+			    ClientData clientData);
+ClientData		Tcl_ObjectGetMetadata(Tcl_Object object,
+			    const Tcl_ObjectMetadataType *typePtr);
+void			Tcl_ObjectSetMetadata(Tcl_Object object,
+			    const Tcl_ObjectMetadataType *typePtr,
+			    ClientData clientData);
 // ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCL.DECLS ^^^^^^^^^^^^^^^^^^^^^^
 
 /*
@@ -140,6 +150,11 @@ typedef struct Object {
     int epoch;			/* Per-object epoch, incremented when the way
 				 * an object should resolve call chains is
 				 * changed. */
+    Tcl_HashTable *metadataPtr;	/* Mapping from pointers to metadata type to
+				 * the ClientData values that are the values
+				 * of each piece of attached metadata. This
+				 * field starts out as NULL and is only
+				 * allocated if metadata is attached. */
     Tcl_HashTable publicContextCache;	/* Place to keep unused contexts. */
     Tcl_HashTable privateContextCache;	/* Place to keep unused contexts. */
 } Object;
@@ -200,6 +215,11 @@ typedef struct Class {
 				 * any). */
     Method *destructorPtr;	/* Method record of the class destructor (if
 				 * any). */
+    Tcl_HashTable *metadataPtr;	/* Mapping from pointers to metadata type to
+				 * the ClientData values that are the values
+				 * of each piece of attached metadata. This
+				 * field starts out as NULL and is only
+				 * allocated if metadata is attached. */
 } Class;
 
 /*