summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2023-05-19 12:56:28 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2023-05-19 12:56:28 (GMT)
commitee48919fcc10becb002636e8e3a7439badf9d117 (patch)
tree74519932e966177361f7da580e2a4145171e0f3c /generic
parent00dd4a5b561cb743509bd7cb25129988a00fac4f (diff)
parentd6a3425ec6628898597b1e19cc23cd6899746fcf (diff)
downloadtcl-ee48919fcc10becb002636e8e3a7439badf9d117.zip
tcl-ee48919fcc10becb002636e8e3a7439badf9d117.tar.gz
tcl-ee48919fcc10becb002636e8e3a7439badf9d117.tar.bz2
Merge 8.7
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c53
-rw-r--r--generic/tclOOCall.c267
-rw-r--r--generic/tclOODefineCmds.c464
-rw-r--r--generic/tclOOInfo.c185
-rw-r--r--generic/tclOOInt.h42
-rw-r--r--generic/tclOOScript.h263
6 files changed, 1232 insertions, 42 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index b05fe1f..8bf29fe 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -3,7 +3,7 @@
*
* This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
*
- * Copyright © 2005-2012 Donal K. Fellows
+ * Copyright © 2005-2019 Donal K. Fellows
* Copyright © 2017 Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
@@ -327,6 +327,7 @@ InitFoundation(
DeletedObjdefNamespace);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
+ Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
fPtr->epoch = 1;
fPtr->tsdPtr = tsdPtr;
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
@@ -964,7 +965,7 @@ TclOOReleaseClassContents(
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
- Tcl_Obj *variableObj;
+ Tcl_Obj *variableObj, *propertyObj;
PrivateVariableMapping *privateVariable;
/*
@@ -1018,6 +1019,29 @@ TclOOReleaseClassContents(
}
/*
+ * Squelch the property lists.
+ */
+
+ if (clsPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
+ }
+ if (clsPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
+ }
+ if (clsPtr->properties.readable.num) {
+ FOREACH(propertyObj, clsPtr->properties.readable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(clsPtr->properties.readable.list);
+ }
+ if (clsPtr->properties.writable.num) {
+ FOREACH(propertyObj, clsPtr->properties.writable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(clsPtr->properties.writable.list);
+ }
+
+ /*
* Squelch our filter list.
*/
@@ -1118,7 +1142,7 @@ ObjectNamespaceDeleted(
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
- Tcl_Obj *filterObj, *variableObj;
+ Tcl_Obj *filterObj, *variableObj, *propertyObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
Tcl_Size i;
@@ -1272,6 +1296,29 @@ ObjectNamespaceDeleted(
}
/*
+ * Squelch the property lists.
+ */
+
+ if (oPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allReadableCache);
+ }
+ if (oPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allWritableCache);
+ }
+ if (oPtr->properties.readable.num) {
+ FOREACH(propertyObj, oPtr->properties.readable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(oPtr->properties.readable.list);
+ }
+ if (oPtr->properties.writable.num) {
+ FOREACH(propertyObj, oPtr->properties.writable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(oPtr->properties.writable.list);
+ }
+
+ /*
* Because an object can be a class that is an instance of itself, the
* class object's class structure should only be cleaned after most of
* the cleanup on the object is done.
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 5c9c986..39fd020 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -2,9 +2,10 @@
* tclOOCall.c --
*
* This file contains the method call chain management code for the
- * object-system core.
+ * object-system core. It also contains everything else that does
+ * inheritance hierarchy traversal.
*
- * Copyright © 2005-2012 Donal K. Fellows
+ * Copyright © 2005-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -58,6 +59,7 @@ typedef struct {
#define BUILDING_MIXINS 0x400000
#define TRAVERSED_MIXIN 0x800000
#define OBJECT_MIXIN 0x1000000
+#define DEFINE_FOR_CLASS 0x2000000
#define MIXIN_CONSISTENT(flags) \
(((flags) & OBJECT_MIXIN) || \
!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
@@ -1907,7 +1909,7 @@ TclOOGetDefineContextNamespace(
DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
DefineEntry *entryPtr;
Tcl_Namespace *nsPtr = NULL;
- int i;
+ int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);
define.list = staticSpace;
define.num = 0;
@@ -1918,8 +1920,8 @@ TclOOGetDefineContextNamespace(
* class mixins right.
*/
- AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
- AddSimpleDefineNamespaces(oPtr, &define, forClass);
+ AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
+ AddSimpleDefineNamespaces(oPtr, &define, flags);
/*
* Go through the list until we find a namespace whose name we can
@@ -2003,7 +2005,7 @@ AddSimpleClassDefineNamespaces(
flags | TRAVERSED_MIXIN);
}
- if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
+ if (flags & DEFINE_FOR_CLASS) {
AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
definePtr, flags);
} else {
@@ -2113,6 +2115,259 @@ AddDefinitionNamespaceToChain(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * FindClassProps --
+ *
+ * Discover the properties known to a class and its superclasses.
+ * The property names become the keys in the accumulator hash table
+ * (which is used as a set).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FindClassProps(
+ Class *clsPtr, /* The object to inspect. Must exist. */
+ int writable, /* Whether we're after the readable or writable
+ * property set. */
+ Tcl_HashTable *accumulator) /* Where to gather the names. */
+{
+ int i, dummy;
+ Tcl_Obj *propName;
+ Class *mixin, *sup;
+
+ tailRecurse:
+ if (writable) {
+ FOREACH(propName, clsPtr->properties.writable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ } else {
+ FOREACH(propName, clsPtr->properties.readable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ }
+ if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
+ /*
+ * We do *not* traverse upwards from the root!
+ */
+ return;
+ }
+ FOREACH(mixin, clsPtr->mixins) {
+ FindClassProps(mixin, writable, accumulator);
+ }
+ if (clsPtr->superclasses.num == 1) {
+ clsPtr = clsPtr->superclasses.list[0];
+ goto tailRecurse;
+ }
+ FOREACH(sup, clsPtr->superclasses) {
+ FindClassProps(sup, writable, accumulator);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FindObjectProps --
+ *
+ * Discover the properties known to an object and all its classes.
+ * The property names become the keys in the accumulator hash table
+ * (which is used as a set).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FindObjectProps(
+ Object *oPtr, /* The object to inspect. Must exist. */
+ int writable, /* Whether we're after the readable or writable
+ * property set. */
+ Tcl_HashTable *accumulator) /* Where to gather the names. */
+{
+ int i, dummy;
+ Tcl_Obj *propName;
+ Class *mixin;
+
+ if (writable) {
+ FOREACH(propName, oPtr->properties.writable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ } else {
+ FOREACH(propName, oPtr->properties.readable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ }
+ FOREACH(mixin, oPtr->mixins) {
+ FindClassProps(mixin, writable, accumulator);
+ }
+ FindClassProps(oPtr->selfCls, writable, accumulator);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetAllClassProperties --
+ *
+ * Get the list of all properties known to a class, including to its
+ * superclasses. Manages a cache so this operation is usually cheap.
+ * The order of properties in the resulting list is undefined.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOOGetAllClassProperties(
+ Class *clsPtr, /* The class to inspect. Must exist. */
+ int writable, /* Whether to get writable properties. If
+ * false, readable properties will be returned
+ * instead. */
+ int *allocated) /* Address of variable to set to true if a
+ * Tcl_Obj was allocated and may be safely
+ * modified by the caller. */
+{
+ Tcl_HashTable hashTable;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *propName, *result;
+ void *dummy;
+
+ /*
+ * Look in the cache.
+ */
+
+ if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
+ if (writable) {
+ if (clsPtr->properties.allWritableCache) {
+ *allocated = 0;
+ return clsPtr->properties.allWritableCache;
+ }
+ } else {
+ if (clsPtr->properties.allReadableCache) {
+ *allocated = 0;
+ return clsPtr->properties.allReadableCache;
+ }
+ }
+ }
+
+ /*
+ * Gather the information. Unsorted! (Caller will sort.)
+ */
+
+ *allocated = 1;
+ Tcl_InitObjHashTable(&hashTable);
+ FindClassProps(clsPtr, writable, &hashTable);
+ result = Tcl_NewObj();
+ FOREACH_HASH(propName, dummy, &hashTable) {
+ Tcl_ListObjAppendElement(NULL, result, propName);
+ }
+ Tcl_DeleteHashTable(&hashTable);
+
+ /*
+ * Cache the information. Also purges the cache.
+ */
+
+ if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
+ if (clsPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
+ clsPtr->properties.allWritableCache = NULL;
+ }
+ if (clsPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
+ clsPtr->properties.allReadableCache = NULL;
+ }
+ }
+ clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
+ if (writable) {
+ clsPtr->properties.allWritableCache = result;
+ } else {
+ clsPtr->properties.allReadableCache = result;
+ }
+ Tcl_IncrRefCount(result);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetAllObjectProperties --
+ *
+ * Get the list of all properties known to a object, including to its
+ * classes. Manages a cache so this operation is usually cheap.
+ * The order of properties in the resulting list is undefined.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOOGetAllObjectProperties(
+ Object *oPtr, /* The object to inspect. Must exist. */
+ int writable, /* Whether to get writable properties. If
+ * false, readable properties will be returned
+ * instead. */
+ int *allocated) /* Address of variable to set to true if a
+ * Tcl_Obj was allocated and may be safely
+ * modified by the caller. */
+{
+ Tcl_HashTable hashTable;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *propName, *result;
+ void *dummy;
+
+ /*
+ * Look in the cache.
+ */
+
+ if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
+ if (writable) {
+ if (oPtr->properties.allWritableCache) {
+ *allocated = 0;
+ return oPtr->properties.allWritableCache;
+ }
+ } else {
+ if (oPtr->properties.allReadableCache) {
+ *allocated = 0;
+ return oPtr->properties.allReadableCache;
+ }
+ }
+ }
+
+ /*
+ * Gather the information. Unsorted! (Caller will sort.)
+ */
+
+ *allocated = 1;
+ Tcl_InitObjHashTable(&hashTable);
+ FindObjectProps(oPtr, writable, &hashTable);
+ result = Tcl_NewObj();
+ FOREACH_HASH(propName, dummy, &hashTable) {
+ Tcl_ListObjAppendElement(NULL, result, propName);
+ }
+ Tcl_DeleteHashTable(&hashTable);
+
+ /*
+ * Cache the information.
+ */
+
+ if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
+ if (oPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allWritableCache);
+ oPtr->properties.allWritableCache = NULL;
+ }
+ if (oPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allReadableCache);
+ oPtr->properties.allReadableCache = NULL;
+ }
+ }
+ oPtr->properties.epoch = oPtr->fPtr->epoch;
+ if (writable) {
+ oPtr->properties.allWritableCache = result;
+ } else {
+ oPtr->properties.allReadableCache = result;
+ }
+ Tcl_IncrRefCount(result);
+ return result;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 84204f9..8879e26 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo::define command,
* part of the object-system core (NB: not Tcl_Obj, but ::oo).
*
- * Copyright © 2006-2013 Donal K. Fellows
+ * Copyright © 2006-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -60,6 +60,7 @@ struct DeclaredSlot {
*/
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
+static inline void BumpInstanceEpoch(Object *oPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
@@ -102,6 +103,8 @@ static int ClassVarsGet(void *clientData,
static int ClassVarsSet(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
+static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
+static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
static int ObjFilterGet(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -120,6 +123,8 @@ static int ObjVarsGet(void *clientData,
static int ObjVarsSet(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
+static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
+static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
static int ResolveClass(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -136,6 +141,14 @@ static const struct DeclaredSlot slots[] = {
SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
+ SLOT("configuresupport::readableproperties",
+ ClassRPropsGet, ClassRPropsSet, NULL),
+ SLOT("configuresupport::writableproperties",
+ ClassWPropsGet, ClassWPropsSet, NULL),
+ SLOT("configuresupport::objreadableproperties",
+ ObjRPropsGet, ObjRPropsSet, NULL),
+ SLOT("configuresupport::objwritableproperties",
+ ObjWPropsGet, ObjWPropsSet, NULL),
{NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
@@ -201,13 +214,26 @@ BumpGlobalEpoch(
if (classPtr->thisPtr->mixins.num > 0) {
classPtr->thisPtr->epoch++;
+
+ /*
+ * Invalidate the property caches directly.
+ */
+
+ if (classPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(classPtr->properties.allReadableCache);
+ classPtr->properties.allReadableCache = NULL;
+ }
+ if (classPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(classPtr->properties.allWritableCache);
+ classPtr->properties.allWritableCache = NULL;
+ }
}
return;
}
/*
* Either there's no class (?!) or we're reconfiguring something that is
- * in use. Force regeneration of call chains.
+ * in use. Force regeneration of call chains and properties.
*/
TclOOGetFoundation(interp)->epoch++;
@@ -216,6 +242,33 @@ BumpGlobalEpoch(
/*
* ----------------------------------------------------------------------
*
+ * BumpInstanceEpoch --
+ *
+ * Advances the epoch and clears the property cache of an object. The
+ * equivalent for classes is BumpGlobalEpoch(), as classes have a more
+ * complex set of relationships to other entities.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+BumpInstanceEpoch(
+ Object *oPtr)
+{
+ oPtr->epoch++;
+ if (oPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allReadableCache);
+ oPtr->properties.allReadableCache = NULL;
+ }
+ if (oPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allWritableCache);
+ oPtr->properties.allWritableCache = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* RecomputeClassCacheFlag --
*
* Determine whether the object is prototypical of its class, and hence
@@ -292,7 +345,7 @@ TclOOObjectSetFilters(
oPtr->filters.num = numFilters;
oPtr->flags &= ~USE_CLASS_CACHE;
}
- oPtr->epoch++; /* Only this object can be affected. */
+ BumpInstanceEpoch(oPtr); /* Only this object can be affected. */
}
/*
@@ -415,7 +468,7 @@ TclOOObjectSetMixins(
}
}
}
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
}
/*
@@ -482,6 +535,7 @@ TclOOClassSetMixins(
*
* ----------------------------------------------------------------------
*/
+
static inline void
InstallStandardVariableMapping(
VariableNameList *vnlPtr,
@@ -1507,7 +1561,7 @@ TclOODefineClassObjCmd(
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
}
}
return TCL_OK;
@@ -1717,7 +1771,7 @@ TclOODefineDeleteMethodObjCmd(
}
if (isInstanceDeleteMethod) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, oPtr->classPtr);
}
@@ -1877,7 +1931,7 @@ TclOODefineExportObjCmd(
if (changed) {
if (isInstanceExport) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, clsPtr);
}
@@ -2095,7 +2149,7 @@ TclOODefineRenameMethodObjCmd(
}
if (isInstanceRenameMethod) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, oPtr->classPtr);
}
@@ -2189,7 +2243,7 @@ TclOODefineUnexportObjCmd(
if (changed) {
if (isInstanceUnexport) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, clsPtr);
}
@@ -3082,6 +3136,398 @@ ResolveClass(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
+ *
+ * Implementations of the "readableproperties" slot accessors for classes
+ * and instances.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InstallReadableProps(
+ PropertyStorage *props,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *propObj;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ if (props->allReadableCache) {
+ Tcl_DecrRefCount(props->allReadableCache);
+ props->allReadableCache = NULL;
+ }
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+ FOREACH(propObj, props->readable) {
+ Tcl_DecrRefCount(propObj);
+ }
+ if (i != objc) {
+ if (objc == 0) {
+ ckfree(props->readable.list);
+ } else if (i) {
+ props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list,
+ sizeof(Tcl_Obj *) * objc);
+ } else {
+ props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc);
+ }
+ }
+ props->readable.num = 0;
+ if (objc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<objc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
+ if (created) {
+ props->readable.list[n++] = objv[i];
+ } else {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ }
+ props->readable.num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != objc) {
+ props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list,
+ sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static int
+ClassRPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassRPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ return TCL_OK;
+}
+
+static int
+ObjRPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(propNameObj, oPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjRPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallReadableProps(&oPtr->properties, varc, varv);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
+ *
+ * Implementations of the "writableproperties" slot accessors for classes
+ * and instances.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InstallWritableProps(
+ PropertyStorage *props,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *propObj;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ if (props->allWritableCache) {
+ Tcl_DecrRefCount(props->allWritableCache);
+ props->allWritableCache = NULL;
+ }
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+ FOREACH(propObj, props->writable) {
+ Tcl_DecrRefCount(propObj);
+ }
+ if (i != objc) {
+ if (objc == 0) {
+ ckfree(props->writable.list);
+ } else if (i) {
+ props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list,
+ sizeof(Tcl_Obj *) * objc);
+ } else {
+ props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc);
+ }
+ }
+ props->writable.num = 0;
+ if (objc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<objc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
+ if (created) {
+ props->writable.list[n++] = objv[i];
+ } else {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ }
+ props->writable.num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != objc) {
+ props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list,
+ sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static int
+ClassWPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassWPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "propertyList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ return TCL_OK;
+}
+
+static int
+ObjWPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(propNameObj, oPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjWPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "propertyList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallWritableProps(&oPtr->properties, varc, varv);
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 1f27b41..bbaaf02 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo-related [info]
* subcommands.
*
- * Copyright © 2006-2011 Donal K. Fellows
+ * Copyright © 2006-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,6 +17,7 @@
#include "tclOOInt.h"
static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void SortPropList(Tcl_Obj *list);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
@@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
+static Tcl_ObjCmdProc InfoObjectPropCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
@@ -41,6 +43,7 @@ static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
+static Tcl_ObjCmdProc InfoClassPropCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
@@ -61,6 +64,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
+ {"properties", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
@@ -82,6 +86,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"properties", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
@@ -1717,6 +1722,184 @@ InfoClassCallCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassPropCmd, InfoObjectPropCmd --
+ *
+ * Implements [info class properties $clsName ?$option...?] and
+ * [info object properties $objName ?$option...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+enum PropOpt {
+ PROP_ALL, PROP_READABLE, PROP_WRITABLE
+};
+static const char *const propOptNames[] = {
+ "-all", "-readable", "-writable",
+ NULL
+};
+
+static int
+InfoClassPropCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr;
+ int i, idx, all = 0, writable = 0, allocated = 0;
+ Tcl_Obj *result, *propObj;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case PROP_ALL:
+ all = 1;
+ break;
+ case PROP_READABLE:
+ writable = 0;
+ break;
+ case PROP_WRITABLE:
+ writable = 1;
+ break;
+ }
+ }
+
+ /*
+ * Get the properties.
+ */
+
+ if (all) {
+ result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
+ if (allocated) {
+ SortPropList(result);
+ }
+ } else {
+ result = Tcl_NewObj();
+ if (writable) {
+ FOREACH(propObj, clsPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ } else {
+ FOREACH(propObj, clsPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ }
+ SortPropList(result);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+static int
+InfoObjectPropCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ int i, idx, all = 0, writable = 0, allocated = 0;
+ Tcl_Obj *result, *propObj;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case PROP_ALL:
+ all = 1;
+ break;
+ case PROP_READABLE:
+ writable = 0;
+ break;
+ case PROP_WRITABLE:
+ writable = 1;
+ break;
+ }
+ }
+
+ /*
+ * Get the properties.
+ */
+
+ if (all) {
+ result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
+ if (allocated) {
+ SortPropList(result);
+ }
+ } else {
+ result = Tcl_NewObj();
+ if (writable) {
+ FOREACH(propObj, oPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ } else {
+ FOREACH(propObj, oPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ }
+ SortPropList(result);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SortPropList --
+ * Sort a list of names of properties. Simple support function. Assumes
+ * that the list Tcl_Obj is unshared and doesn't have a string
+ * representation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PropNameCompare(
+ const void *a,
+ const void *b)
+{
+ Tcl_Obj *first = *(Tcl_Obj **) a;
+ Tcl_Obj *second = *(Tcl_Obj **) b;
+
+ return strcmp(Tcl_GetString(first), Tcl_GetString(second));
+}
+
+static void
+SortPropList(
+ Tcl_Obj *list)
+{
+ int ec;
+ Tcl_Obj **ev;
+
+ Tcl_ListObjGetElements(NULL, list, &ec, &ev);
+ qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 0e666e9..031b910 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -161,6 +161,26 @@ typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
/*
+ * This type is used in various places.
+ */
+
+typedef struct {
+ LIST_STATIC(Tcl_Obj *) readable;
+ /* The readable properties slot. */
+ LIST_STATIC(Tcl_Obj *) writable;
+ /* The writable properties slot. */
+ Tcl_Obj *allReadableCache; /* The cache of all readable properties
+ * exposed by this object or class (in its
+ * stereotypical instancs). Contains a sorted
+ * unique list if not NULL. */
+ Tcl_Obj *allWritableCache; /* The cache of all writable properties
+ * exposed by this object or class (in its
+ * stereotypical instances). Contains a sorted
+ * unique list if not NULL. */
+ int epoch; /* The epoch that the caches are valid for. */
+} PropertyStorage;
+
+/*
* Now, the definition of what an object actually is.
*/
@@ -182,8 +202,8 @@ typedef struct Object {
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* This is non-NULL for all classes, and NULL
- * for everything else. It points to the class
- * structure. */
+ * for everything else. It points to the class
+ * structure. */
Tcl_Size refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism exists to
@@ -211,12 +231,15 @@ typedef struct Object {
* used inside methods. */
Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
* command. */
+ PropertyStorage properties; /* Information relating to the lists of
+ * properties that this object *claims* to
+ * support. */
} Object;
-#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
- * been destroyed */
-#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor script for the
- object has began */
+#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
+ * been destroyed */
+#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor
+ * script for the object has began */
#define OO_UNUSED_4 4 /* No longer used. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
@@ -319,6 +342,9 @@ typedef struct Class {
* namespace is defined but doesn't exist; we
* also check at setting time but don't check
* between times. */
+ PropertyStorage properties; /* Information relating to the lists of
+ * properties that this class *claims* to
+ * support. */
} Class;
/*
@@ -521,6 +547,10 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
+MODULE_SCOPE Tcl_Obj * TclOOGetAllClassProperties(Class *clsPtr,
+ int writable, int *allocated);
+MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr,
+ int writable, int *allocated);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Object *contextObjPtr, Class *contextClsPtr,
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index f2e99b0..407e919 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -29,7 +29,7 @@ static const char *tclOOSetupScript =
"::namespace eval ::oo {\n"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
-"\t\t::namespace path {}\n"
+"\t\tnamespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"
@@ -98,9 +98,9 @@ static const char *tclOOSetupScript =
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
-"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
+"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
"\t\t}\n"
-"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
+"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
@@ -141,34 +141,44 @@ static const char *tclOOSetupScript =
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
-"\t\tmethod Get {} {\n"
+"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
-"\t\tmethod Set list {\n"
+"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
-"\t\tmethod Resolve list {\n"
+"\t\tmethod Resolve -unexport list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
-"\t\tmethod -set args {\n"
+"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
-"\t\tmethod -append args {\n"
+"\t\tmethod -append -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
-"\t\tmethod -clear {} {tailcall my Set {}}\n"
-"\t\tmethod -prepend args {\n"
+"\t\tmethod -appendifnew -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\tset args [lmap a $args {\n"
+"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
+"\t\t\t\tif {$a in $current} continue\n"
+"\t\t\t\tset a\n"
+"\t\t\t}]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
+"\t\tmethod -prepend -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
-"\t\tmethod -remove args {\n"
+"\t\tmethod -remove -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
@@ -177,7 +187,7 @@ static const char *tclOOSetupScript =
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
-"\t\tmethod unknown {args} {\n"
+"\t\tmethod unknown -unexport {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
@@ -186,13 +196,12 @@ static const char *tclOOSetupScript =
"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"
-"\t\texport -set -append -clear -prepend -remove\n"
-"\t\tunexport unknown destroy\n"
+"\t\tunexport destroy\n"
"\t}\n"
"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
-"\tdefine object method <cloned> {originObject} {\n"
+"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
@@ -219,7 +228,7 @@ static const char *tclOOSetupScript =
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
-"\tdefine class method <cloned> {originObject} {\n"
+"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tnext $originObject\n"
"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"
@@ -235,7 +244,7 @@ static const char *tclOOSetupScript =
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
-"\t\t\t\t\tmethod <cloned> {originObject} {\n"
+"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t\t}\n"
@@ -248,6 +257,226 @@ static const char *tclOOSetupScript =
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
+"\t::namespace eval configuresupport {\n"
+"\t\tnamespace path ::tcl\n"
+"\t\tproc PropertyImpl {readslot writeslot args} {\n"
+"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
+"\t\t\t\tset prop [lindex $args $i]\n"
+"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {$prop ne [list $prop]} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
+"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
+"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
+"\t\t\t\tset kind readwrite\n"
+"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
+"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
+"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
+"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
+"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
+"\t\t\t\t\t\t-get {\n"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
+"\t\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t\tset getter $arg\n"
+"\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t-set {\n"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
+"\t\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t\tset setter $arg\n"
+"\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t-kind {\n"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
+"\t\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
+"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
+"\t\t\t\t\t\t\t\treadable readwrite writable\n"
+"\t\t\t\t\t\t\t} $arg]\n"
+"\t\t\t\t\t\t}\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t\tset reader <ReadProp$realprop>\n"
+"\t\t\t\tset writer <WriteProp$realprop>\n"
+"\t\t\t\tswitch $kind {\n"
+"\t\t\t\t\treadable {\n"
+"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\twritable {\n"
+"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\treadwrite {\n"
+"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t\tnamespace eval configurableclass {\n"
+"\t\t\t::proc property args {\n"
+"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
+"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
+"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
+"\t\t\t}\n"
+"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t\t::namespace path ::oo::define\n"
+"\t\t\t::namespace export property\n"
+"\t\t}\n"
+"\t\tnamespace eval configurableobject {\n"
+"\t\t\t::proc property args {\n"
+"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
+"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
+"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
+"\t\t\t}\n"
+"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t\t::namespace path ::oo::objdefine\n"
+"\t\t\t::namespace export property\n"
+"\t\t}\n"
+"\t\tproc ReadAll {object my} {\n"
+"\t\t\tset result {}\n"
+"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
+"\t\t\t\t} on error {msg opt} {\n"
+"\t\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on return {msg opt} {\n"
+"\t\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on break {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
+"\t\t\t\t} on continue {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $result\n"
+"\t\t}\n"
+"\t\tproc ReadOne {object my propertyName} {\n"
+"\t\t\tset props [info object properties $object -all -readable]\n"
+"\t\t\ttry {\n"
+"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
+"\t\t\t} on error {msg} {\n"
+"\t\t\t\tcatch {\n"
+"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
+"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
+"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
+"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
+"\t\t\t}\n"
+"\t\t\ttry {\n"
+"\t\t\t\tset value [$my <ReadProp$prop>]\n"
+"\t\t\t} on error {msg opt} {\n"
+"\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t} on return {msg opt} {\n"
+"\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t} on break {} {\n"
+"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\"property getter for $prop did a break\"\n"
+"\t\t\t} on continue {} {\n"
+"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
+"\t\t\t}\n"
+"\t\t\treturn $value\n"
+"\t\t}\n"
+"\t\tproc WriteMany {object my setterMap} {\n"
+"\t\t\tset props [info object properties $object -all -writable]\n"
+"\t\t\tforeach {prop value} $setterMap {\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
+"\t\t\t\t} on error {msg} {\n"
+"\t\t\t\t\tcatch {\n"
+"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
+"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
+"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
+"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
+"\t\t\t\t}\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\t$my <WriteProp$prop> $value\n"
+"\t\t\t\t} on error {msg opt} {\n"
+"\t\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on return {msg opt} {\n"
+"\t\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on break {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
+"\t\t\t\t} on continue {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\t::oo::class create configurable {\n"
+"\t\t\tprivate variable my\n"
+"\t\t\tmethod configure -export args {\n"
+"\t\t\t\t::if {![::info exists my]} {\n"
+"\t\t\t\t\t::set my [::namespace which my]\n"
+"\t\t\t\t}\n"
+"\t\t\t\t::if {[::llength $args] == 0} {\n"
+"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
+"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
+"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
+"\t\t\t\t\t\t[::lindex $args 0]\n"
+"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
+"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
+"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tdefinitionnamespace -instance configurableobject\n"
+"\t\t\tdefinitionnamespace -class configurableclass\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create configurable {\n"
+"\t\tsuperclass class\n"
+"\t\tconstructor {{definitionScript \"\"}} {\n"
+"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
+"\t\t\tnext $definitionScript\n"
+"\t\t}\n"
+"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
+"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;