summaryrefslogtreecommitdiffstats
path: root/generic/tclOODefineCmds.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOODefineCmds.c')
-rw-r--r--generic/tclOODefineCmds.c882
1 files changed, 562 insertions, 320 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 5b0dfc3..b4ff283 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,12 @@
#include "tclOOInt.h"
/*
+ * The actual value used to mark private declaration frames.
+ */
+
+#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE)
+
+/*
* The maximum length of fully-qualified object name to use in an errorinfo
* message. Longer than this will be curtailed.
*/
@@ -31,14 +37,17 @@ struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
+ const Tcl_MethodType resolverType;
};
-#define SLOT(name,getter,setter) \
+#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
- setter, NULL, NULL}}
+ setter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+ resolver, NULL, NULL}}
/*
* Forward declarations.
@@ -47,8 +56,11 @@ struct DeclaredSlot {
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
-static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
+static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
Tcl_Obj *savedNameObj, const char *typeOfSubject);
+static inline int MagicDefinitionInvoke(Tcl_Interp *interp,
+ Tcl_Namespace *nsPtr, int cmdIndex,
+ int objc, Tcl_Obj *const *objv);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
static inline int InitDefineContext(Tcl_Interp *interp,
@@ -100,26 +112,59 @@ static int ObjVarsGet(ClientData clientData,
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);
/*
* Now define the slots used in declarations.
*/
static const struct DeclaredSlot slots[] = {
- SLOT("define::filter", ClassFilterGet, ClassFilterSet),
- SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
- SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
- SLOT("define::variable", ClassVarsGet, ClassVarsSet),
- SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
- SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
- SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
- {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
+ {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
+
+/*
+ * How to build the in-namespace name of a private variable. This is a pattern
+ * used with Tcl_ObjPrintf().
+ */
+
+#define PRIVATE_VARIABLE_PATTERN "%d : %s"
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * IsPrivateDefine --
+ *
+ * Extracts whether the current context is handling private definitions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+IsPrivateDefine(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (!iPtr->varFramePtr) {
+ return 0;
+ }
+ return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
+}
/*
* ----------------------------------------------------------------------
*
* BumpGlobalEpoch --
+ *
* Utility that ensures that call chains that are invalid will get thrown
* away at an appropriate time. Note that exactly which epoch gets
* advanced will depend on exactly what the class is tangled up in; in
@@ -164,6 +209,7 @@ BumpGlobalEpoch(
* ----------------------------------------------------------------------
*
* RecomputeClassCacheFlag --
+ *
* Determine whether the object is prototypical of its class, and hence
* able to use the class's method chain cache.
*
@@ -186,6 +232,7 @@ RecomputeClassCacheFlag(
* ----------------------------------------------------------------------
*
* TclOOObjectSetFilters --
+ *
* Install a list of filter method names into an object.
*
* ----------------------------------------------------------------------
@@ -244,6 +291,7 @@ TclOOObjectSetFilters(
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
+ *
* Install a list of filter method names into a class.
*
* ----------------------------------------------------------------------
@@ -306,6 +354,7 @@ TclOOClassSetFilters(
* ----------------------------------------------------------------------
*
* TclOOObjectSetMixins --
+ *
* Install a list of mixin classes into an object.
*
* ----------------------------------------------------------------------
@@ -323,9 +372,8 @@ TclOOObjectSetMixins(
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(oPtr->mixins.list);
oPtr->mixins.num = 0;
@@ -337,6 +385,7 @@ TclOOObjectSetMixins(
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
@@ -349,6 +398,8 @@ TclOOObjectSetMixins(
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
+ /* For the new copy created by memcpy */
+ AddRef(mixinPtr->thisPtr);
}
}
}
@@ -359,6 +410,7 @@ TclOOObjectSetMixins(
* ----------------------------------------------------------------------
*
* TclOOClassSetMixins --
+ *
* Install a list of mixin classes into a class.
*
* ----------------------------------------------------------------------
@@ -378,6 +430,7 @@ TclOOClassSetMixins(
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(classPtr->mixins.list);
classPtr->mixins.num = 0;
@@ -386,6 +439,7 @@ TclOOClassSetMixins(
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
@@ -396,6 +450,8 @@ TclOOClassSetMixins(
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
+ /* For the new copy created by memcpy */
+ AddRef(mixinPtr->thisPtr);
}
}
BumpGlobalEpoch(interp, classPtr);
@@ -404,7 +460,125 @@ TclOOClassSetMixins(
/*
* ----------------------------------------------------------------------
*
+ * InstallStandardVariableMapping, InstallPrivateVariableMapping --
+ *
+ * Helpers for installing standard and private variable maps.
+ *
+ * ----------------------------------------------------------------------
+ */
+static inline void
+InstallStandardVariableMapping(
+ VariableNameList *vnlPtr,
+ int varc,
+ Tcl_Obj *const *varv)
+{
+ Tcl_Obj *variableObj;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH(variableObj, *vnlPtr) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree(vnlPtr->list);
+ } else if (i) {
+ vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
+ } else {
+ vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc);
+ }
+ }
+ vnlPtr->num = 0;
+ if (varc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<varc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ if (created) {
+ vnlPtr->list[n++] = varv[i];
+ } else {
+ Tcl_DecrRefCount(varv[i]);
+ }
+ }
+ vnlPtr->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != varc) {
+ vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static inline void
+InstallPrivateVariableMapping(
+ PrivateVariableList *pvlPtr,
+ int varc,
+ Tcl_Obj *const *varv,
+ int creationEpoch)
+{
+ PrivateVariableMapping *privatePtr;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH_STRUCT(privatePtr, *pvlPtr) {
+ Tcl_DecrRefCount(privatePtr->variableObj);
+ Tcl_DecrRefCount(privatePtr->fullNameObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree(pvlPtr->list);
+ } else if (i) {
+ pvlPtr->list = ckrealloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * varc);
+ } else {
+ pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc);
+ }
+ }
+
+ pvlPtr->num = 0;
+ if (varc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<varc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ if (created) {
+ privatePtr = &(pvlPtr->list[n++]);
+ privatePtr->variableObj = varv[i];
+ privatePtr->fullNameObj = Tcl_ObjPrintf(
+ PRIVATE_VARIABLE_PATTERN,
+ creationEpoch, Tcl_GetString(varv[i]));
+ Tcl_IncrRefCount(privatePtr->fullNameObj);
+ } else {
+ Tcl_DecrRefCount(varv[i]);
+ }
+ }
+ pvlPtr->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != varc) {
+ pvlPtr->list = ckrealloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* RenameDeleteMethod --
+ *
* Core of the code to rename and delete methods.
*
* ----------------------------------------------------------------------
@@ -494,6 +668,7 @@ RenameDeleteMethod(
* ----------------------------------------------------------------------
*
* TclOOUnknownDefinition --
+ *
* Handles what happens when an unknown command is encountered during the
* processing of a definition script. Works by finding a command in the
* operating definition namespace that the requested command is a unique
@@ -572,6 +747,7 @@ TclOOUnknownDefinition(
* ----------------------------------------------------------------------
*
* FindCommand --
+ *
* Specialized version of Tcl_FindCommand that handles command prefixes
* and disallows namespace magic.
*
@@ -632,6 +808,7 @@ FindCommand(
* ----------------------------------------------------------------------
*
* InitDefineContext --
+ *
* Does the magic incantations necessary to push the special stack frame
* used when processing object definitions. It is up to the caller to
* dispose of the frame (with TclPopStackFrame) when finished.
@@ -657,7 +834,9 @@ InitDefineContext(
return TCL_ERROR;
}
- /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
+ /*
+ * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
+ */
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, FRAME_IS_OO_DEFINE);
@@ -672,6 +851,7 @@ InitDefineContext(
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext --
+ *
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
@@ -686,7 +866,8 @@ TclOOGetDefineCmdContext(
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
- || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+ || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
+ && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command may only be called from within the context of"
" an ::oo::define or ::oo::objdefine command", -1));
@@ -708,6 +889,7 @@ TclOOGetDefineCmdContext(
* ----------------------------------------------------------------------
*
* GetClassInOuterContext --
+ *
* Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
* context that called oo::define (or equivalent). Note that this may
* have to go up multiple levels to get the level that we started doing
@@ -726,7 +908,8 @@ GetClassInOuterContext(
Object *oPtr;
CallFrame *savedFramePtr = iPtr->varFramePtr;
- while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+ || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
if (iPtr->varFramePtr->callerVarPtr == NULL) {
Tcl_Panic("getting outer context when already in global context");
}
@@ -750,12 +933,13 @@ GetClassInOuterContext(
* ----------------------------------------------------------------------
*
* GenerateErrorInfo --
+ *
* Factored out code to generate part of the error trace messages.
*
* ----------------------------------------------------------------------
*/
-static void
+static inline void
GenerateErrorInfo(
Tcl_Interp *interp, /* Where to store the error info trace. */
Object *oPtr, /* What object (or class) was being configured
@@ -787,7 +971,72 @@ GenerateErrorInfo(
/*
* ----------------------------------------------------------------------
*
+ * MagicDefinitionInvoke --
+ *
+ * Part of the implementation of the "oo::define" and "oo::objdefine"
+ * commands that is used to implement the more-than-one-argument case,
+ * applying ensemble-like tricks with dispatch so that error messages are
+ * clearer. Doesn't handle the management of the stack frame.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+MagicDefinitionInvoke(
+ Tcl_Interp *interp,
+ Tcl_Namespace *nsPtr,
+ int cmdIndex,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Tcl_Command cmd;
+ int isRoot, dummy, result, offset = cmdIndex + 1;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go
+ * through Tcl_EvalObjv without the extra work to pre-find the command, as
+ * that finds command names in the wrong namespace at the moment. Ugly!
+ */
+
+ isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv);
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ /* TODO: overflow? */
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
+ if (isRoot) {
+ TclResetRewriteEnsemble(interp, 1);
+ }
+ Tcl_DecrRefCount(objPtr);
+
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineObjCmd --
+ *
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
* object to be modified is known to the commands in the target
@@ -805,8 +1054,8 @@ TclOODefineObjCmd(
Tcl_Obj *const *objv)
{
Foundation *fPtr = TclOOGetFoundation(interp);
- int result;
Object *oPtr;
+ int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
@@ -846,48 +1095,9 @@ TclOODefineObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Tcl_Command cmd;
- int isRoot, dummy;
-
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
-
- isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv);
-
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
-
- objPtr = Tcl_NewObj();
- obj2Ptr = Tcl_NewObj();
- cmd = FindCommand(interp, objv[2], fPtr->defineNs);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[2]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
- result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
- if (isRoot) {
- TclResetRewriteEnsemble(interp, 1);
- }
- Tcl_DecrRefCount(objPtr);
+ result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -901,6 +1111,7 @@ TclOODefineObjCmd(
* ----------------------------------------------------------------------
*
* TclOOObjDefObjCmd --
+ *
* Implementation of the "oo::objdefine" command. Works by effectively
* doing the same as 'namespace eval', but with extra magic applied so
* that the object to be modified is known to the commands in the target
@@ -918,8 +1129,8 @@ TclOOObjDefObjCmd(
Tcl_Obj *const *objv)
{
Foundation *fPtr = TclOOGetFoundation(interp);
- int isRoot, result;
Object *oPtr;
+ int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
@@ -952,49 +1163,9 @@ TclOOObjDefObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Tcl_Command cmd;
- int dummy;
-
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
-
- isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv);
-
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
-
- objPtr = Tcl_NewObj();
- obj2Ptr = Tcl_NewObj();
- cmd = FindCommand(interp, objv[2], fPtr->objdefNs);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[2]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
- result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
-
- if (isRoot) {
- TclResetRewriteEnsemble(interp, 1);
- }
- Tcl_DecrRefCount(objPtr);
+ result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -1008,6 +1179,7 @@ TclOOObjDefObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineSelfObjCmd --
+ *
* Implementation of the "self" subcommand of the "oo::define" command.
* Works by effectively doing the same as 'namespace eval', but with
* extra magic applied so that the object to be modified is known to the
@@ -1025,19 +1197,21 @@ TclOODefineSelfObjCmd(
Tcl_Obj *const *objv)
{
Foundation *fPtr = TclOOGetFoundation(interp);
- int result;
Object *oPtr;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
+ int result, private;
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
+ if (objc < 2) {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+ }
+
+ private = IsPrivateDefine(interp);
+
/*
* Make the oo::objdefine namespace the current namespace and evaluate the
* command(s).
@@ -1046,6 +1220,9 @@ TclOODefineSelfObjCmd(
if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
return TCL_ERROR;
}
+ if (private) {
+ ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+ }
AddRef(oPtr);
if (objc == 2) {
@@ -1053,60 +1230,128 @@ TclOODefineSelfObjCmd(
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
- ((Interp *)interp)->cmdFramePtr, 2);
+ ((Interp *)interp)->cmdFramePtr, 1);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
TclDecrRefCount(objNameObj);
} else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Tcl_Command cmd;
- int isRoot, dummy;
+ result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
+ }
+ TclOODecrRefCount(oPtr);
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
+ /*
+ * Restore the previous "current" namespace.
+ */
- isRoot = TclInitRewriteEnsemble(interp, 2, 1, objv);
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineObjSelfObjCmd --
+ *
+ * Implementation of the "self" subcommand of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
+int
+TclOODefineObjSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
- objPtr = Tcl_NewObj();
- obj2Ptr = Tcl_NewObj();
- cmd = FindCommand(interp, objv[1], fPtr->objdefNs);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[1]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefinePrivateObjCmd --
+ *
+ * Implementation of the "private" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
- result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE);
- if (isRoot) {
- TclResetRewriteEnsemble(interp, 1);
+int
+TclOODefinePrivateObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstancePrivate = (clientData != NULL);
+ /* Just so that we can generate the correct
+ * error message depending on the context of
+ * usage of this function. */
+ Interp *iPtr = (Interp *) interp;
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int saved; /* The saved flag. We restore it on exit so
+ * that [private private ...] doesn't make
+ * things go weird. */
+ int result;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 1) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
+ return TCL_OK;
+ }
+
+ /*
+ * Change the frame type flag while evaluating the body.
+ */
+
+ saved = iPtr->varFramePtr->isProcCallFrame;
+ iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+
+ /*
+ * Evaluate the body; standard pattern.
+ */
+
+ AddRef(oPtr);
+ if (objc == 2) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
+ result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+ if (result == TCL_ERROR) {
+ GenerateErrorInfo(interp, oPtr, objNameObj,
+ isInstancePrivate ? "object" : "class");
}
- Tcl_DecrRefCount(objPtr);
+ TclDecrRefCount(objNameObj);
+ } else {
+ result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp),
+ 1, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
- * Restore the previous "current" namespace.
+ * Restore the frame type flag to what it was previously.
*/
- TclPopStackFrame(interp);
+ iPtr->varFramePtr->isProcCallFrame = saved;
return result;
}
@@ -1114,6 +1359,7 @@ TclOODefineSelfObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineClassObjCmd --
+ *
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
*
@@ -1130,6 +1376,7 @@ TclOODefineClassObjCmd(
Object *oPtr;
Class *clsPtr;
Foundation *fPtr = TclOOGetFoundation(interp);
+ int wasClass, willBeClass;
/*
* Parse the context to get the object to operate on.
@@ -1165,19 +1412,10 @@ TclOODefineClassObjCmd(
if (clsPtr == NULL) {
return TCL_ERROR;
}
-
- /*
- * Apply semantic checks. In particular, classes and non-classes are not
- * interchangable (too complicated to do the conversion!) so we must
- * produce an error if any attempt is made to swap from one to the other.
- */
-
- if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "may not change a %sclass object into a %sclass object",
- (oPtr->classPtr==NULL ? "non-" : ""),
- (oPtr->classPtr==NULL ? "" : "non-")));
- Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
+ if (oPtr == clsPtr->thisPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not change classes into an instance of themselves", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1185,13 +1423,36 @@ TclOODefineClassObjCmd(
* Set the object's class.
*/
+ wasClass = (oPtr->classPtr != NULL);
+ willBeClass = (TclOOIsReachable(fPtr->classCls, clsPtr));
+
if (oPtr->selfCls != clsPtr) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ TclOODecrRefCount(oPtr->selfCls->thisPtr);
oPtr->selfCls = clsPtr;
+ AddRef(oPtr->selfCls->thisPtr);
TclOOAddToInstances(oPtr, oPtr->selfCls);
- if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) {
- oPtr->flags &= ~CLASS_GONE;
+
+ /*
+ * Create or delete the class guts if necessary.
+ */
+
+ if (wasClass && !willBeClass) {
+ /*
+ * This is the most global of all epochs. Bump it! No cache can be
+ * trusted!
+ */
+
+ TclOORemoveFromMixins(oPtr->classPtr, oPtr);
+ oPtr->fPtr->epoch++;
+ oPtr->flags |= DONT_DELETE;
+ TclOODeleteDescendants(interp, oPtr);
+ oPtr->flags &= ~DONT_DELETE;
+ TclOOReleaseClassContents(interp, oPtr);
+ } else if (!wasClass && willBeClass) {
+ TclOOAllocClass(interp, oPtr);
}
+
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
@@ -1205,6 +1466,7 @@ TclOODefineClassObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineConstructorObjCmd --
+ *
* Implementation of the "constructor" subcommand of the "oo::define"
* command.
*
@@ -1273,6 +1535,7 @@ TclOODefineConstructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDeleteMethodObjCmd --
+ *
* Implementation of the "deletemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1329,6 +1592,7 @@ TclOODefineDeleteMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDestructorObjCmd --
+ *
* Implementation of the "destructor" subcommand of the "oo::define"
* command.
*
@@ -1393,6 +1657,7 @@ TclOODefineDestructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineExportObjCmd --
+ *
* Implementation of the "export" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1463,8 +1728,9 @@ TclOODefineExportObjCmd(
} else {
mPtr = Tcl_GetHashValue(hPtr);
}
- if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+ if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
mPtr->flags |= PUBLIC_METHOD;
+ mPtr->flags &= ~TRUE_PRIVATE_METHOD;
changed = 1;
}
}
@@ -1487,6 +1753,7 @@ TclOODefineExportObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineForwardObjCmd --
+ *
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1523,6 +1790,9 @@ TclOODefineForwardObjCmd(
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
? PUBLIC_METHOD : 0;
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ }
/*
* Create the method structure.
@@ -1547,6 +1817,7 @@ TclOODefineForwardObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
+ *
* Implementation of the "method" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1581,6 +1852,9 @@ TclOODefineMethodObjCmd(
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
? PUBLIC_METHOD : 0;
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ }
/*
* Create the method by using the right back-end API.
@@ -1603,70 +1877,8 @@ TclOODefineMethodObjCmd(
/*
* ----------------------------------------------------------------------
*
- * TclOODefineMixinObjCmd --
- * Implementation of the "mixin" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineMixinObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- const int objc,
- Tcl_Obj *const *objv)
-{
- int isInstanceMixin = (clientData != NULL);
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Class **mixins;
- int i;
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (!isInstanceMixin && !oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
- return TCL_ERROR;
- }
- mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Class *clsPtr = GetClassInOuterContext(interp, objv[i],
- "may only mix in classes");
-
- if (clsPtr == NULL) {
- goto freeAndError;
- }
- if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "may not mix a class into itself", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
- goto freeAndError;
- }
- mixins[i-1] = clsPtr;
- }
-
- if (isInstanceMixin) {
- TclOOObjectSetMixins(oPtr, objc-1, mixins);
- } else {
- TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
- }
-
- TclStackFree(interp, mixins);
- return TCL_OK;
-
- freeAndError:
- TclStackFree(interp, mixins);
- return TCL_ERROR;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* TclOODefineRenameMethodObjCmd --
+ *
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1723,6 +1935,7 @@ TclOODefineRenameMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineUnexportObjCmd --
+ *
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1793,8 +2006,8 @@ TclOODefineUnexportObjCmd(
} else {
mPtr = Tcl_GetHashValue(hPtr);
}
- if (isNew || mPtr->flags & PUBLIC_METHOD) {
- mPtr->flags &= ~PUBLIC_METHOD;
+ if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+ mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
changed = 1;
}
}
@@ -1817,6 +2030,7 @@ TclOODefineUnexportObjCmd(
* ----------------------------------------------------------------------
*
* Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *
* How to install a constructor or destructor into a class; API to call
* from C.
*
@@ -1871,6 +2085,7 @@ Tcl_ClassSetDestructor(
* ----------------------------------------------------------------------
*
* TclOODefineSlots --
+ *
* Create the "::oo::Slot" class and its standard instances. Class
* definition is empty at the stage (added by scripting).
*
@@ -1884,6 +2099,7 @@ TclOODefineSlots(
const struct DeclaredSlot *slotInfoPtr;
Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
Class *slotCls;
slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
@@ -1893,9 +2109,10 @@ TclOODefineSlots(
}
Tcl_IncrRefCount(getName);
Tcl_IncrRefCount(setName);
+ Tcl_IncrRefCount(resolveName);
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
- (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
+ (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
if (slotObject == NULL) {
continue;
@@ -1904,9 +2121,14 @@ TclOODefineSlots(
&slotInfoPtr->getterType, NULL);
Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
+ if (slotInfoPtr->resolverType.callProc) {
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ &slotInfoPtr->resolverType, NULL);
+ }
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
+ Tcl_DecrRefCount(resolveName);
return TCL_OK;
}
@@ -1914,6 +2136,7 @@ TclOODefineSlots(
* ----------------------------------------------------------------------
*
* ClassFilterGet, ClassFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
@@ -1993,6 +2216,7 @@ ClassFilterSet(
* ----------------------------------------------------------------------
*
* ClassMixinGet, ClassMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
@@ -2074,6 +2298,7 @@ ClassMixinSet(
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
+ i--;
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
@@ -2097,6 +2322,7 @@ ClassMixinSet(
* ----------------------------------------------------------------------
*
* ClassSuperGet, ClassSuperSet --
+ *
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
@@ -2191,16 +2417,19 @@ ClassSuperSet(
if (superc == 0) {
superclasses = ckrealloc(superclasses, sizeof(Class *));
- superclasses[0] = oPtr->fPtr->objectCls;
- superc = 1;
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
+ } else {
+ superclasses[0] = oPtr->fPtr->objectCls;
}
+ superc = 1;
+ AddRef(superclasses[0]->thisPtr);
} else {
for (i=0 ; i<superc ; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
+ i--;
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
@@ -2217,9 +2446,19 @@ ClassSuperSet(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
+ for (; i > 0; i--) {
+ TclOODecrRefCount(superclasses[i]->thisPtr);
+ }
ckfree(superclasses);
return TCL_ERROR;
}
+
+ /*
+ * Corresponding TclOODecrRefCount() is near the end of this
+ * function.
+ */
+
+ AddRef(superclasses[i]->thisPtr);
}
}
@@ -2233,6 +2472,7 @@ ClassSuperSet(
if (oPtr->classPtr->superclasses.num != 0) {
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ TclOODecrRefCount(superPtr->thisPtr);
}
ckfree(oPtr->classPtr->superclasses.list);
}
@@ -2250,6 +2490,7 @@ ClassSuperSet(
* ----------------------------------------------------------------------
*
* ClassVarsGet, ClassVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
@@ -2265,7 +2506,7 @@ ClassVarsGet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *variableObj;
+ Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2283,8 +2524,18 @@ ClassVarsGet(
}
resultObj = Tcl_NewObj();
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (IsPrivateDefine(interp)) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2300,7 +2551,7 @@ ClassVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
int i;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
@@ -2341,49 +2592,11 @@ ClassVarsSet(
}
}
- for (i=0 ; i<varc ; i++) {
- Tcl_IncrRefCount(varv[i]);
- }
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != varc) {
- if (varc == 0) {
- ckfree(oPtr->classPtr->variables.list);
- } else if (i) {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
- } else {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
- }
- }
-
- oPtr->classPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
-
- Tcl_InitObjHashTable(&uniqueTable);
- for (i=n=0 ; i<varc ; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
- if (created) {
- oPtr->classPtr->variables.list[n++] = varv[i];
- } else {
- Tcl_DecrRefCount(varv[i]);
- }
- }
- oPtr->classPtr->variables.num = n;
-
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
-
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
- Tcl_DeleteHashTable(&uniqueTable);
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
+ varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
}
return TCL_OK;
}
@@ -2392,6 +2605,7 @@ ClassVarsSet(
* ----------------------------------------------------------------------
*
* ObjectFilterGet, ObjectFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
@@ -2459,6 +2673,7 @@ ObjFilterSet(
* ----------------------------------------------------------------------
*
* ObjectMixinGet, ObjectMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
@@ -2544,6 +2759,7 @@ ObjMixinSet(
* ----------------------------------------------------------------------
*
* ObjectVarsGet, ObjectVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
@@ -2559,7 +2775,7 @@ ObjVarsGet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *variableObj;
+ Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2571,8 +2787,18 @@ ObjVarsGet(
}
resultObj = Tcl_NewObj();
- FOREACH(variableObj, oPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (IsPrivateDefine(interp)) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2588,7 +2814,7 @@ ObjVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2621,50 +2847,66 @@ ObjVarsSet(
return TCL_ERROR;
}
}
- for (i=0 ; i<varc ; i++) {
- Tcl_IncrRefCount(varv[i]);
- }
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != varc) {
- if (varc == 0) {
- ckfree(oPtr->variables.list);
- } else if (i) {
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
- } else {
- oPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
- }
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
+ oPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->variables, varc, varv);
}
- oPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ResolveClass --
+ *
+ * Implementation of the "Resolve" support method for some slots (those
+ * that are slots around a list of classes). This resolves possible class
+ * names to their fully-qualified names if possible.
+ *
+ * ----------------------------------------------------------------------
+ */
- Tcl_InitObjHashTable(&uniqueTable);
- for (i=n=0 ; i<varc ; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
- if (created) {
- oPtr->variables.list[n++] = varv[i];
- } else {
- Tcl_DecrRefCount(varv[i]);
- }
- }
- oPtr->variables.num = n;
+static int
+ResolveClass(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int idx = Tcl_ObjectContextSkippedArgs(context);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr;
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
+ /*
+ * Check if were called wrongly. The definition context isn't used...
+ * except that GetClassInOuterContext() assumes that it is there.
+ */
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
- Tcl_DeleteHashTable(&uniqueTable);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (objc != idx + 1) {
+ Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Resolve the class if possible. If not, remove any resolution error and
+ * return what we've got anyway as the failure might not be fatal overall.
+ */
+
+ clsPtr = GetClassInOuterContext(interp, objv[idx],
+ "USER SHOULD NOT SEE THIS MESSAGE");
+ if (clsPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, objv[idx]);
+ } else {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
}
+
return TCL_OK;
}
generated by cgit v0.12 at 2025-12-05 14:50:43 (GMT)