summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclOO.c53
-rw-r--r--generic/tclOOCall.c200
-rw-r--r--generic/tclOODefineCmds.c475
-rw-r--r--generic/tclOOInfo.c183
-rw-r--r--generic/tclOOInt.h42
-rw-r--r--generic/tclOOScript.h114
-rw-r--r--tools/tclOOScript.tcl131
7 files changed, 1139 insertions, 59 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index af5ea50..8710a89 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 (c) 2005-2012 by Donal K. Fellows
+ * Copyright (c) 2005-2019 by Donal K. Fellows
* Copyright (c) 2017 by Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
@@ -323,6 +323,7 @@ InitFoundation(
DeletedObjdefNamespace);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
+ Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
fPtr->epoch = 0;
fPtr->tsdPtr = tsdPtr;
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
@@ -961,7 +962,7 @@ TclOOReleaseClassContents(
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
- Tcl_Obj *variableObj;
+ Tcl_Obj *variableObj, *propertyObj;
PrivateVariableMapping *privateVariable;
/*
@@ -1015,6 +1016,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.
*/
@@ -1115,7 +1139,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;
int i;
@@ -1269,6 +1293,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 f3474b6..f647fb7 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 (c) 2005-2012 by Donal K. Fellows
+ * Copyright (c) 2005-2019 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -2100,6 +2101,201 @@ AddDefinitionNamespaceToChain(
definePtr->num++;
}
+static void
+FindClassProps(
+ Class *clsPtr,
+ int writable,
+ Tcl_HashTable *accumulator)
+{
+ 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);
+ }
+}
+
+static void
+FindObjectProps(
+ Object *oPtr,
+ int writable,
+ Tcl_HashTable *accumulator)
+{
+ 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);
+}
+
+Tcl_Obj *
+TclOOGetAllClassProperties(
+ Class *clsPtr,
+ int writable,
+ int *allocated)
+{
+ 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;
+}
+
+Tcl_Obj *
+TclOOGetAllObjectProperties(
+ Object *oPtr,
+ int writable,
+ int *allocated)
+{
+ 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
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index f259954..7b70c79 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 (c) 2006-2013 by Donal K. Fellows
+ * Copyright (c) 2006-2019 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -78,51 +78,18 @@ static inline void RecomputeClassCacheFlag(Object *oPtr);
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
-static int ClassFilterGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassFilterSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassMixinGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassMixinSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassSuperGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassSuperSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassVarsGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassVarsSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjFilterGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjFilterSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjMixinGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjMixinSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjVarsGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjVarsSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ResolveClass(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
+static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet;
+static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet;
+static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
+static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet;
+static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet;
+static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
+static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet;
+static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet;
+static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
+static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet;
+static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
+static Tcl_MethodCallProc ResolveClass;
/*
* Now define the slots used in declarations.
@@ -136,6 +103,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 +176,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++;
@@ -482,6 +470,7 @@ TclOOClassSetMixins(
*
* ----------------------------------------------------------------------
*/
+
static inline void
InstallStandardVariableMapping(
VariableNameList *vnlPtr,
@@ -3080,6 +3069,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 = ckrealloc(props->readable.list,
+ sizeof(Tcl_Obj *) * objc);
+ } else {
+ props->readable.list = 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 = ckrealloc(props->readable.list,
+ sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static int
+ClassRPropsGet(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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 = ckrealloc(props->writable.list,
+ sizeof(Tcl_Obj *) * objc);
+ } else {
+ props->writable.list = 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 = ckrealloc(props->writable.list,
+ sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static int
+ClassWPropsGet(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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 99918ae..ed44cc8 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 (c) 2006-2011 by Donal K. Fellows
+ * Copyright (c) 2006-2019 by 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},
+ {"property", 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},
+ {"property", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
@@ -1714,6 +1719,182 @@ InfoClassCallCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassPropCmd, InfoObjectPropCmd --
+ *
+ * Implements [info class property $clsName ?$option...?] and
+ * [info object property $objName ?$option...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+enum PropOpt {
+ PROP_ALL, PROP_READABLE, PROP_WRITABLE
+};
+static const char *const propOptNames[] = {
+ "-all", "-readable", "-writable",
+ NULL
+};
+
+static int
+InfoClassPropCmd(
+ ClientData clientData,
+ 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(
+ ClientData clientData,
+ 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.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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 ca984d0..e8b8f4a 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. */
int 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;
/*
@@ -568,6 +594,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 a1e4624..c8a79a9 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -248,6 +248,120 @@ static const char *tclOOSetupScript =
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
+"\tnamespace eval configuresupport {\n"
+"\t\tproc property {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 -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\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 {[string match \"-*\" [set next [lindex $args [expr {$i + 1}]]]]} {\n"
+"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
+"\t\t\t\t\tswitch [::tcl::prefix match {-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 -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 -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 getter $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 -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 [::tcl::prefix match -message \"kind\" {\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\tswitch $kind {\n"
+"\t\t\t\t\treadable {\n"
+"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 1 [list method <ReadProp$realprop> {} $getter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\twritable {\n"
+"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 1 [list method <WriteProp$realprop> {value} $setter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\treadwrite {\n"
+"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 1 [list method <ReadProp$realprop> {} $getter]\n"
+"\t\t\t\t\t\tuplevel 1 [list method <WriteProp$realprop> {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\tproc property args {\n"
+"\t\t\t\ttailcall ::oo::configuresupport::property \\\n"
+"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
+"\t\t\t\t\t::oo::configuresupport::writableproperties \\\n"
+"\t\t\t\t\t{*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnamespace path ::oo::define\n"
+"\t\t}\n"
+"\t\tnamespace eval configurableobject {\n"
+"\t\t\tproc property args {\n"
+"\t\t\t\ttailcall ::oo::configuresupport::property \\\n"
+"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
+"\t\t\t\t\t::oo::configuresupport::objwritableproperties \\\n"
+"\t\t\t\t\t{*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnamespace path ::oo::objdefine\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\tdefinitionnamespace -instance configuresupport::configurableobject\n"
+"\t}\n"
+"\tclass create configuresupport::configurable {\n"
+"\t\tprivate method Configure:Match {prop kind} {\n"
+"\t\t\tset props [info object property [self] -all $kind]\n"
+"\t\t\t::tcl::prefix match -message \"property\" $props $prop\n"
+"\t\t}\n"
+"\t\tmethod configure args {\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\tset result {}\n"
+"\t\t\t\tforeach prop [info object property [self] -all -readable] {\n"
+"\t\t\t\t\tdict set result $prop [my <ReadProp$prop>]\n"
+"\t\t\t\t}\n"
+"\t\t\t\treturn $result\n"
+"\t\t\t} elseif {[llength $args] == 1} {\n"
+"\t\t\t\tset prop [my Configure:Match [lindex $args 0] -readable]\n"
+"\t\t\t\treturn [my <ReadProp$prop>]\n"
+"\t\t\t} elseif {[llength $args] % 2 == 0} {\n"
+"\t\t\t\tforeach {prop value} $args {\n"
+"\t\t\t\t\tset prop [my Configure:Match $prop -writable]\n"
+"\t\t\t\t\tmy <WriteProp$prop> $value\n"
+"\t\t\t\t}\n"
+"\t\t\t\treturn\n"
+"\t\t\t} else {\n"
+"\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t[format \"wrong # args: should be \\\"%s\\\"\" \\\n"
+"\t\t\t\t\t\t \"[self] configure \?-option value ...\?\"]\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 5e0145f..8cc9627 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -447,6 +447,137 @@
superclass class
unexport create createWithNamespace new
}
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::configurable --
+ #
+ # A metaclass that is used to make classes that can be configured. Also
+ # its supporting classes and namespaces.
+ #
+ # ----------------------------------------------------------------------
+
+ namespace eval configuresupport {
+ proc property {readslot writeslot args} {
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ # Parse the property name
+ set prop [lindex $args $i]
+ if {[string match "-*" $prop]} {
+ return -code error -errorcode {TCLOO PROPERTY_FORMAT} \
+ "bad property name \"$prop\"; must not begin with -"
+ }
+ set realprop [string cat "-" $prop]
+ set getter [format {::set [my varname %s]} $prop]
+ set setter [format {::set [my varname %s] $value} $prop]
+ set kind readwrite
+
+ # Parse the extra options
+ while {[string match "-*" [set next [lindex $args [expr {$i + 1}]]]]} {
+ set arg [lindex $args [incr i 2]]
+ switch [::tcl::prefix match {-get -kind -set} $next] {
+ -get {
+ if {$i >= [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "missing body to go with -get option"
+ }
+ set getter $arg
+ }
+ -set {
+ if {$i >= [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "missing body to go with -set option"
+ }
+ set getter $arg
+ }
+ -kind {
+ if {$i >= [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "missing kind value to go with -kind option"
+ }
+ set kind [::tcl::prefix match -message "kind" {
+ readable readwrite writable
+ } $arg]
+ }
+ }
+ }
+
+ # Install the option
+ switch $kind {
+ readable {
+ uplevel 1 [list $readslot -append $realprop]
+ uplevel 1 [list method <ReadProp$realprop> {} $getter]
+ }
+ writable {
+ uplevel 1 [list $writeslot -append $realprop]
+ uplevel 1 [list method <WriteProp$realprop> {value} $setter]
+ }
+ readwrite {
+ uplevel 1 [list $readslot -append $realprop]
+ uplevel 1 [list $writeslot -append $realprop]
+ uplevel 1 [list method <ReadProp$realprop> {} $getter]
+ uplevel 1 [list method <WriteProp$realprop> {value} $setter]
+ }
+ }
+ }
+ }
+ namespace eval configurableclass {
+ proc property args {
+ tailcall ::oo::configuresupport::property \
+ ::oo::configuresupport::readableproperties \
+ ::oo::configuresupport::writableproperties \
+ {*}$args
+ }
+ namespace path ::oo::define
+ }
+ namespace eval configurableobject {
+ proc property args {
+ tailcall ::oo::configuresupport::property \
+ ::oo::configuresupport::objreadableproperties \
+ ::oo::configuresupport::objwritableproperties \
+ {*}$args
+ }
+ namespace path ::oo::objdefine
+ }
+ }
+
+ class create configurable {
+ superclass class
+ constructor {{definitionScript ""}} {
+ next {mixin ::oo::configuresupport::configurable}
+ next $definitionScript
+ }
+ definitionnamespace -class configuresupport::configurableclass
+ definitionnamespace -instance configuresupport::configurableobject
+ }
+
+ class create configuresupport::configurable {
+ private method Configure:Match {prop kind} {
+ set props [info object property [self] -all $kind]
+ ::tcl::prefix match -message "property" $props $prop
+ }
+ method configure args {
+ if {[llength $args] == 0} {
+ set result {}
+ foreach prop [info object property [self] -all -readable] {
+ dict set result $prop [my <ReadProp$prop>]
+ }
+ return $result
+ } elseif {[llength $args] == 1} {
+ set prop [my Configure:Match [lindex $args 0] -readable]
+ return [my <ReadProp$prop>]
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {prop value} $args {
+ set prop [my Configure:Match $prop -writable]
+ my <WriteProp$prop> $value
+ }
+ return
+ } else {
+ return -code error -errorcode {TCL WRONGARGS} \
+ [format "wrong # args: should be \"%s\"" \
+ "[self] configure ?-option value ...?"]
+ }
+ }
+ }
}
# Local Variables:
generated by cgit v0.12 at 2025-12-04 06:43:05 (GMT)