summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclInterp.c20
-rw-r--r--generic/tclOO.c102
-rw-r--r--generic/tclOOBasic.c451
-rw-r--r--generic/tclOODefineCmds.c727
-rw-r--r--generic/tclOOInt.h14
-rw-r--r--generic/tclOOScript.h265
-rw-r--r--tests/ooUtil.test10
-rw-r--r--tools/tclOOScript.tcl481
9 files changed, 1381 insertions, 693 deletions
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c227b0c..c450c80 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3318,6 +3318,10 @@ MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next,
int loc);
MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start,
const char *end);
+MODULE_SCOPE int TclAliasCreate(Tcl_Interp *interp,
+ Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
+ Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, Tcl_Size len);
MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 90af06e..5e54749 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -221,10 +221,6 @@ enum LimitHandlerFlags {
* Prototypes for local static functions:
*/
-static int AliasCreate(Tcl_Interp *interp,
- Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
- Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
- Tcl_Obj *const objv[]);
static int AliasDelete(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Obj *namePtr);
static int AliasDescribe(Tcl_Interp *interp,
@@ -701,7 +697,7 @@ NRInterpCmd(
return TCL_ERROR;
}
- return AliasCreate(interp, childInterp, parentInterp, objv[3],
+ return TclAliasCreate(interp, childInterp, parentInterp, objv[3],
objv[5], objc - 6, objv + 6);
}
@@ -1232,7 +1228,7 @@ Tcl_CreateAlias(
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
- result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
+ result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
targetObjPtr, argc, objv);
for (i = 0; i < argc; i++) {
@@ -1279,7 +1275,7 @@ Tcl_CreateAliasObj(
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
- result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
+ result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
targetObjPtr, objc, objv);
Tcl_DecrRefCount(childObjPtr);
@@ -1452,7 +1448,7 @@ TclPreventAliasLoop(
/*
*----------------------------------------------------------------------
*
- * AliasCreate --
+ * TclAliasCreate --
*
* Helper function to do the work to actually create an alias.
*
@@ -1466,8 +1462,8 @@ TclPreventAliasLoop(
*----------------------------------------------------------------------
*/
-static int
-AliasCreate(
+int
+TclAliasCreate(
Tcl_Interp *interp, /* Interp for error reporting. */
Tcl_Interp *childInterp, /* Interp where alias cmd will live or from
* which alias will be deleted. */
@@ -2468,7 +2464,7 @@ ChildCreate(
TclNewLiteralStringObj(clockObj, "clock");
Tcl_IncrRefCount(clockObj);
- status = AliasCreate(interp, childInterp, parentInterp, clockObj,
+ status = TclAliasCreate(interp, childInterp, parentInterp, clockObj,
clockObj, 0, NULL);
Tcl_DecrRefCount(clockObj);
if (status != TCL_OK) {
@@ -2558,7 +2554,7 @@ NRChildCmd(
return AliasDelete(interp, childInterp, objv[2]);
}
} else {
- return AliasCreate(interp, childInterp, interp, objv[2],
+ return TclAliasCreate(interp, childInterp, interp, objv[2],
objv[3], objc - 4, objv + 4);
}
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 76e2016..0da8b7f 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -17,20 +17,49 @@
#include "tclOOInt.h"
/*
+ * Commands in oo and oo::Helpers.
+ */
+
+static const struct StdCommands {
+ const char *name;
+ Tcl_ObjCmdProc *objProc;
+ Tcl_ObjCmdProc *nreProc;
+ CompileProc *compileProc;
+} ooCmds[] = {
+ {"define", TclOODefineObjCmd, NULL, NULL},
+ {"objdefine", TclOOObjDefObjCmd, NULL, NULL},
+ {"copy", TclOOCopyObjectCmd, NULL, NULL},
+ {"DelegateName", TclOODelegateNameObjCmd, NULL, NULL},
+ {NULL, NULL, NULL, NULL}
+}, helpCmds[] = {
+ {"callback", TclOOCallbackObjCmd, NULL, NULL},
+ {"mymethod", TclOOCallbackObjCmd, NULL, NULL},
+ {"classvariable", TclOOClassVariableObjCmd, NULL, NULL},
+ {"link", TclOOLinkObjCmd, NULL, NULL},
+ {"next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd},
+ {"nextto", NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd},
+ {"self", TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd},
+ {NULL, NULL, NULL, NULL}
+};
+
+/*
* Commands in oo::define and oo::objdefine.
*/
-static const struct {
+static const struct DefineCommands {
const char *name;
Tcl_ObjCmdProc *objProc;
int flag;
} defineCmds[] = {
+ {"classmethod", TclOODefineClassMethodObjCmd, 0},
{"constructor", TclOODefineConstructorObjCmd, 0},
{"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
+ {"initialise", TclOODefineInitialiseObjCmd, 0},
+ {"initialize", TclOODefineInitialiseObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
{"private", TclOODefinePrivateObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
@@ -366,14 +395,20 @@ InitFoundation(
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
TclNewLiteralStringObj(fPtr->myName, "my");
- TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates");
+ TclNewLiteralStringObj(fPtr->slotGetName, "Get");
+ TclNewLiteralStringObj(fPtr->slotSetName, "Set");
+ TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
+ TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
Tcl_IncrRefCount(fPtr->clonedName);
Tcl_IncrRefCount(fPtr->defineName);
Tcl_IncrRefCount(fPtr->myName);
- Tcl_IncrRefCount(fPtr->mcdName);
+ Tcl_IncrRefCount(fPtr->slotGetName);
+ Tcl_IncrRefCount(fPtr->slotSetName);
+ Tcl_IncrRefCount(fPtr->slotResolveName);
+ Tcl_IncrRefCount(fPtr->slotDefOpName);
TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
TclOOUnknownDefinition, NULL, NULL);
@@ -428,16 +463,16 @@ InitFoundation(
* ensemble.
*/
- CreateCmdInNS(interp, fPtr->helpersNs, "next",
- NULL, TclOONextObjCmd, TclCompileObjectNextCmd);
- CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
- NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd);
- CreateCmdInNS(interp, fPtr->helpersNs, "self",
- TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd);
-
- CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL);
- CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL);
- CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL);
+ for (i = 0 ; helpCmds[i].name ; i++) {
+ CreateCmdInNS(interp, fPtr->helpersNs, helpCmds[i].name,
+ helpCmds[i].objProc, helpCmds[i].nreProc,
+ helpCmds[i].compileProc);
+ }
+ for (i = 0 ; ooCmds[i].name ; i++) {
+ CreateCmdInNS(interp, fPtr->ooNs, ooCmds[i].name,
+ ooCmds[i].objProc, ooCmds[i].nreProc,
+ ooCmds[i].compileProc);
+ }
TclOOInitInfo(interp);
@@ -612,7 +647,10 @@ KillFoundation(
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
TclDecrRefCount(fPtr->myName);
- TclDecrRefCount(fPtr->mcdName);
+ TclDecrRefCount(fPtr->slotGetName);
+ TclDecrRefCount(fPtr->slotSetName);
+ TclDecrRefCount(fPtr->slotResolveName);
+ TclDecrRefCount(fPtr->slotDefOpName);
TclOODecrRefCount(fPtr->objectCls->thisPtr);
TclOODecrRefCount(fPtr->classCls->thisPtr);
@@ -796,6 +834,7 @@ AllocObject(
oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
MyClassDeleted);
+ oPtr->linkedCmdsList = NULL;
return oPtr;
}
@@ -839,7 +878,18 @@ MyDeleted(
* squelched. */
{
Object *oPtr = (Object *) clientData;
+ Tcl_Size linkc, i;
+ Tcl_Obj **linkv, *link;
+ if (oPtr->linkedCmdsList) {
+ TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv);
+ for (i=0 ; i<linkc ; i++) {
+ link = linkv[i];
+ (void) Tcl_DeleteCommand(oPtr->fPtr->interp, TclGetString(link));
+ }
+ Tcl_DecrRefCount(oPtr->linkedCmdsList);
+ oPtr->linkedCmdsList = NULL;
+ }
oPtr->myCommand = NULL;
}
@@ -3144,6 +3194,30 @@ Tcl_GetObjectName(
/*
* ----------------------------------------------------------------------
*
+ * TclOOObjectMyName --
+ *
+ * Utility function that returns the name of the object's [my], or NULL
+ * if it has been deleted (or otherwise doesn't exist).
+ *
+ * ----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclOOObjectMyName(
+ Tcl_Interp *interp,
+ Object *oPtr)
+{
+ Tcl_Obj *namePtr;
+ if (!oPtr->myCommand) {
+ return NULL;
+ }
+ TclNewObj(namePtr);
+ Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr);
+ return namePtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* assorted trivial 'getter' functions
*
* ----------------------------------------------------------------------
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index f7bb969..740e2cb 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,7 +19,7 @@
static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static Tcl_NRPostProc AfterNRDestructor;
-static Tcl_NRPostProc DecrRefsPostClassConstructor;
+static Tcl_NRPostProc PostClassConstructor;
static Tcl_NRPostProc FinalizeConstruction;
static Tcl_NRPostProc FinalizeEval;
static Tcl_NRPostProc NextRestoreFrame;
@@ -68,6 +68,126 @@ FinalizeConstruction(
/*
* ----------------------------------------------------------------------
*
+ * MixinClassDelegates --
+ *
+ * Internal utility for setting up the class delegate.
+ * Runs after the class has called [oo::define] on its argument.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+/*
+ * Look up the delegate for a class.
+ */
+static inline Class *
+GetClassDelegate(
+ Tcl_Interp *interp,
+ Class *clsPtr)
+{
+ Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
+ clsPtr->thisPtr->namespacePtr->fullName);
+ Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+ Tcl_DecrRefCount(delegateName);
+ return delegatePtr;
+}
+
+/*
+ * Patches in the appropriate class delegates' superclasses.
+ * Sonewhat nessy because the list of superclasses isn't modified frequently.
+ */
+static inline void
+SetDelegateSuperclasses(
+ Tcl_Interp *interp,
+ Class *clsPtr,
+ Class *delegatePtr)
+{
+ /* Build new list of superclasses */
+ int i, j = delegatePtr->superclasses.num, k;
+ Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) *
+ (delegatePtr->superclasses.num + clsPtr->superclasses.num));
+ if (delegatePtr->superclasses.num) {
+ memcpy(supers, delegatePtr->superclasses.list,
+ sizeof(Class *) * delegatePtr->superclasses.num);
+ }
+ FOREACH(superPtr, clsPtr->superclasses) {
+ Class *superDelegatePtr = GetClassDelegate(interp, superPtr);
+ if (!superDelegatePtr) {
+ continue;
+ }
+ for (k=0 ; k<=j ; k++) {
+ if (k == j) {
+ supers[j++] = superDelegatePtr;
+ TclOOAddToSubclasses(delegatePtr, superDelegatePtr);
+ AddRef(superDelegatePtr->thisPtr);
+ break;
+ } else if (supers[k] == superDelegatePtr) {
+ break;
+ }
+ }
+ }
+
+ /* Install new list of superclasses */
+ if (delegatePtr->superclasses.num) {
+ Tcl_Free(delegatePtr->superclasses.list);
+ }
+ delegatePtr->superclasses.list = supers;
+ delegatePtr->superclasses.num = j;
+
+ /* Definitely don't need to bump any epoch here */
+}
+
+/*
+ * Mixes the delegate into its controlling class.
+ */
+static inline void
+InstallDelegateAsMixin(
+ Tcl_Interp *interp,
+ Class *clsPtr,
+ Class *delegatePtr)
+{
+ Class **mixins;
+ int i;
+
+ if (clsPtr->thisPtr->mixins.num == 0) {
+ TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr);
+ return;
+ }
+ mixins = (Class **) TclStackAlloc(interp,
+ sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1));
+ for (i = 0; i < clsPtr->thisPtr->mixins.num; i++) {
+ mixins[i] = clsPtr->thisPtr->mixins.list[i];
+ if (mixins[i] == delegatePtr) {
+ TclStackFree(interp, (void *) mixins);
+ return;
+ }
+ }
+ mixins[clsPtr->thisPtr->mixins.num] = delegatePtr;
+ TclOOObjectSetMixins(clsPtr->thisPtr, clsPtr->thisPtr->mixins.num + 1, mixins);
+ TclStackFree(interp, mixins);
+}
+
+/*
+ * Patches in the appropriate class delegates.
+ */
+static void
+MixinClassDelegates(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ Tcl_Obj *delegateName)
+{
+ Class *clsPtr = oPtr->classPtr, *delegatePtr;
+ if (clsPtr) {
+ delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+ if (delegatePtr) {
+ SetDelegateSuperclasses(interp, clsPtr, delegatePtr);
+ InstallDelegateAsMixin(interp, clsPtr, delegatePtr);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOO_Class_Constructor --
*
* Implementation for oo::class constructor.
@@ -84,9 +204,9 @@ TclOO_Class_Constructor(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj **invoke, *nameObj;
-
size_t skip = Tcl_ObjectContextSkippedArgs(context);
+ Tcl_Obj **invoke, *delegateName;
+
if ((size_t) objc > skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv,
"?definitionScript?");
@@ -101,18 +221,21 @@ TclOO_Class_Constructor(
* argument to [oo::define]. [Bug 680503]
*/
- nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
+ delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
oPtr->namespacePtr->fullName);
+ Tcl_IncrRefCount(delegateName);
Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
- TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, 0);
- Tcl_BounceRefCount(nameObj);
+ TclGetString(delegateName), NULL, TCL_INDEX_NONE, NULL, 0);
/*
* If there's nothing else to do, we're done.
*/
if ((size_t) objc == skip) {
- return TCL_OK;
+ Tcl_InterpState saved = Tcl_SaveInterpState(interp, TCL_OK);
+ MixinClassDelegates(interp, oPtr, delegateName);
+ Tcl_DecrRefCount(delegateName);
+ return Tcl_RestoreInterpState(interp, saved);
}
/*
@@ -132,8 +255,8 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[0]);
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
- TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke, oPtr, NULL, NULL);
+ TclNRAddCallback(interp, PostClassConstructor,
+ invoke, oPtr, delegateName, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -143,33 +266,29 @@ TclOO_Class_Constructor(
return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
}
+/*
+ * Called *after* [oo::define] inside the constructor of a class.
+ * Cleans up some temporary storage and sets up the delegate.
+ */
static int
-DecrRefsPostClassConstructor(
+PostClassConstructor(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **invoke = (Tcl_Obj **) data[0];
Object *oPtr = (Object *) data[1];
+ Tcl_Obj *delegateName = (Tcl_Obj *) data[2];
Tcl_InterpState saved;
- int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
- invoke[0] = oPtr->fPtr->mcdName;
- invoke[1] = TclOOObjectName(interp, oPtr);
- Tcl_IncrRefCount(invoke[0]);
- Tcl_IncrRefCount(invoke[1]);
- saved = Tcl_SaveInterpState(interp, result);
- code = Tcl_EvalObjv(interp, 2, invoke, 0);
- TclDecrRefCount(invoke[0]);
- TclDecrRefCount(invoke[1]);
TclStackFree(interp, invoke);
- if (code != TCL_OK) {
- Tcl_DiscardInterpState(saved);
- return code;
- }
+
+ saved = Tcl_SaveInterpState(interp, result);
+ MixinClassDelegates(interp, oPtr, delegateName);
+ Tcl_DecrRefCount(delegateName);
return Tcl_RestoreInterpState(interp, saved);
}
@@ -904,6 +1023,102 @@ TclOO_Object_VarName(
/*
* ----------------------------------------------------------------------
*
+ * TclOOLinkObjCmd --
+ *
+ * Implementation of the [link] command, that makes a command that
+ * invokes a method on the current object. The name of the command and
+ * the name of the method match by default. Note that this command is
+ * only ever to be used inside the body of a procedure-like method,
+ * and is typically intended for constructors.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOLinkObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ /* Set up common bits. */
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+ CallContext *context;
+ Object *oPtr;
+ Tcl_Obj *myCmd, **linkv, *src, *dst;
+ Tcl_Size linkc;
+ const char *srcStr;
+ int i;
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
+ OO_ERROR(interp, CONTEXT_REQUIRED);
+ return TCL_ERROR;
+ }
+ context = (CallContext *) framePtr->clientData;
+ oPtr = context->oPtr;
+ if (!oPtr->myCommand) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot link to non-existent callback handle"));
+ OO_ERROR(interp, MY_GONE);
+ return TCL_ERROR;
+ }
+ myCmd = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd);
+ if (!oPtr->linkedCmdsList) {
+ oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(oPtr->linkedCmdsList);
+ }
+
+ /* For each argument */
+ for (i=1; i<objc; i++) {
+ /* Parse as list of (one or) two items: source and destination names */
+ if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) {
+ Tcl_BounceRefCount(myCmd);
+ return TCL_ERROR;
+ }
+ switch (linkc) {
+ case 1:
+ /* Degenerate case */
+ src = dst = linkv[0];
+ break;
+ case 2:
+ src = linkv[0];
+ dst = linkv[1];
+ break;
+ default:
+ Tcl_BounceRefCount(myCmd);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad link description; must only have one or two elements"));
+ OO_ERROR(interp, CMDLINK_FORMAT);
+ return TCL_ERROR;
+ }
+
+ /* Qualify the source if necessary */
+ srcStr = TclGetString(src);
+ if (srcStr[0] != ':' || srcStr[1] != ':') {
+ src = Tcl_ObjPrintf("%s::%s",
+ context->oPtr->namespacePtr->fullName, srcStr);
+ }
+
+ /* Make the alias command */
+ if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) {
+ Tcl_BounceRefCount(myCmd);
+ Tcl_BounceRefCount(src);
+ return TCL_ERROR;
+ }
+
+ /* Remember the alias for cleanup if necessary */
+ Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src);
+ }
+ Tcl_BounceRefCount(myCmd);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOONextObjCmd, TclOONextToObjCmd --
*
* Implementation of the [next] and [nextto] commands. Note that these
@@ -1373,6 +1588,196 @@ TclOOCopyObjectCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOCallbackObjCmd --
+ *
+ * Implementation of the [callback] command, which constructs callbacks
+ * into the current object.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOCallbackObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ Tcl_Obj *namePtr, *listPtr;
+
+ /*
+ * Start with sanity checks on the calling context to make sure that we
+ * are invoked from a suitable method context. If so, we can safely
+ * retrieve the handle to the object call context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
+ OO_ERROR(interp, CONTEXT_REQUIRED);
+ return TCL_ERROR;
+ }
+
+ contextPtr = (CallContext *) framePtr->clientData;
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "method ...");
+ return TCL_ERROR;
+ }
+
+ /* Get the [my] real name. */
+ namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
+ if (!namePtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no possible safe callback without my", TCL_AUTO_LENGTH));
+ OO_ERROR(interp, NO_MY);
+ return TCL_ERROR;
+ }
+
+ /* No check that the method exists; could be dynamically added. */
+
+ listPtr = Tcl_NewListObj(1, &namePtr);
+ (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassVariableObjCmd --
+ *
+ * Implementation of the [classvariable] command, which links to
+ * variables in the class of the current object.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOClassVariableObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ Class *clsPtr;
+ Tcl_Namespace *clsNsPtr, *ourNsPtr;
+ Var *arrayPtr, *otherPtr;
+ int i;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ...");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Start with sanity checks on the calling context to make sure that we
+ * are invoked from a suitable method context. If so, we can safely
+ * retrieve the handle to the object call context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
+ OO_ERROR(interp, CONTEXT_REQUIRED);
+ return TCL_ERROR;
+ }
+
+ /* Get a reference to the class's namespace */
+ contextPtr = (CallContext *) framePtr->clientData;
+ clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
+ if (clsPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method not defined by a class", TCL_AUTO_LENGTH));
+ OO_ERROR(interp, UNMATCHED_CONTEXT);
+ return TCL_ERROR;
+ }
+ clsNsPtr = clsPtr->thisPtr->namespacePtr;
+
+ /* Check the list of variable names */
+ for (i = 1; i < objc; i++) {
+ const char *varName = TclGetString(objv[i]);
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad variable name \"%s\": can't create a %s",
+ varName, "scalar variable that looks like an array element"));
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_StringMatch(varName, "*::*")) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad variable name \"%s\": can't create a %s",
+ varName, "local variable with a namespace separator in it"));
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ /* Lastly, link the caller's local variables to the class's variables */
+ ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+ for (i = 1; i < objc; i++) {
+ /* Locate the other variable. */
+ iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
+ otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
+ (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
+ "access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
+ iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr;
+ if (otherPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* Create the new variable and link it to otherPtr. */
+ if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
+ TCL_INDEX_NONE) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODelegateNameObjCmd --
+ *
+ * Implementation of the [oo::DelegateName] command, which is a utility
+ * that gets the name of the class delegate for a class. It's trivial,
+ * but makes working with them much easier as delegate names are
+ * intentionally hard to create by accident.
+ *
+ * Not part of TclOO public API. No public documentation.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOODelegateNameObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "class");
+ return TCL_ERROR;
+ }
+ Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate",
+ clsPtr->thisPtr->namespacePtr->fullName));
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index e029649..8d99b07 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -39,15 +39,25 @@ typedef struct DeclaredSlot {
const Tcl_MethodType resolverType;
} DeclaredSlot;
-#define SLOT(name,getter,setter,resolver) \
+#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
- {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+ {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \
getter, NULL, NULL}, \
- {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+ {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \
setter, NULL, NULL}, \
- {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+ {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \
resolver, NULL, NULL}}
+typedef struct DeclaredSlotMethod {
+ const char *name;
+ int flags;
+ const Tcl_MethodType implType;
+} DeclaredSlotMethod;
+
+#define SLOT_METHOD(name,impl,flags) \
+ {name, flags, {TCL_OO_METHOD_VERSION_1, \
+ "core method: " name " slot", impl, NULL, NULL}}
+
/*
* A [string match] pattern used to determine if a method should be exported.
*/
@@ -78,6 +88,33 @@ 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 Slot_Append(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_AppendNew(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_Clear(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_Prepend(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_Remove(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_Resolve(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_Set(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Slot_Unimplemented(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext,
+ int, Tcl_Obj *const *);
+static int Slot_Unknown(void *,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
static int ClassFilter_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -175,6 +212,20 @@ static const DeclaredSlot slots[] = {
{NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
+static const DeclaredSlotMethod slotMethods[] = {
+ SLOT_METHOD("Get", Slot_Unimplemented, 0),
+ SLOT_METHOD("Resolve", Slot_Resolve, 0),
+ SLOT_METHOD("Set", Slot_Unimplemented, 0),
+ SLOT_METHOD("-append", Slot_Append, PUBLIC_METHOD),
+ SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD),
+ SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD),
+ SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD),
+ SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD),
+ SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD),
+ SLOT_METHOD("unknown", Slot_Unknown, 0),
+ {NULL, 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().
@@ -2032,6 +2083,53 @@ TclOODefineForwardObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineInitialiseObjCmd --
+ *
+ * Implementation of the "initialise" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineInitialiseObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Object object;
+ Tcl_Obj *lambdaWords[3], *applyArgs[2];
+ int result;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "body");
+ return TCL_ERROR;
+ }
+
+ /* Build the lambda */
+ object = TclOOGetDefineCmdContext(interp);
+ if (object == NULL) {
+ return TCL_ERROR;
+ }
+ lambdaWords[0] = Tcl_NewObj();
+ lambdaWords[1] = objv[1];
+ lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object));
+
+ /* Delegate to [apply] to run it */
+ applyArgs[0] = Tcl_NewStringObj("apply", -1);
+ applyArgs[1] = Tcl_NewListObj(3, lambdaWords);
+ Tcl_IncrRefCount(applyArgs[0]);
+ Tcl_IncrRefCount(applyArgs[1]);
+ result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs);
+ Tcl_DecrRefCount(applyArgs[0]);
+ Tcl_DecrRefCount(applyArgs[1]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineMethodObjCmd --
*
* Implementation of the "method" subcommand of the "oo::define" and
@@ -2130,6 +2228,78 @@ TclOODefineMethodObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineClassMethodObjCmd --
+ *
+ * Implementation of the "classmethod" subcommand of the "oo::define"
+ * command. Defines a class method. See define(n) for details.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineClassMethodObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Class *clsPtr;
+ int isPublic;
+ Tcl_Obj *forwardArgs[2], *prefixObj;
+ Method *mPtr;
+
+ if (objc != 2 && objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?");
+ return TCL_ERROR;
+ }
+ clsPtr = TclOOGetClassDefineCmdContext(interp);
+ if (!clsPtr) {
+ return TCL_ERROR;
+ }
+
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
+ ? PUBLIC_METHOD : 0;
+
+ /*
+ * Create the method on the delegate class if the caller gave arguments
+ * and body.
+ */
+ if (objc == 4) {
+ Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
+ clsPtr->thisPtr->namespacePtr->fullName);
+ Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+
+ Tcl_DecrRefCount(delegateName);
+ if (!delegatePtr) {
+ return TCL_ERROR;
+ }
+ if (IsPrivateDefine(interp)) {
+ isPublic = 0;
+ }
+ if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1],
+ objv[2], objv[3], NULL) == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ /* Make the connection to the delegate by forwarding */
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ }
+ forwardArgs[0] = Tcl_NewStringObj("myclass", -1);
+ forwardArgs[1] = objv[1];
+ prefixObj = Tcl_NewListObj(2, forwardArgs);
+ mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, objv[1], prefixObj);
+ if (mPtr == NULL) {
+ Tcl_DecrRefCount(prefixObj);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineRenameMethodObjCmd --
*
* Implementation of the "renamemethod" subcommand of the "oo::define"
@@ -2350,50 +2520,559 @@ int
TclOODefineSlots(
Foundation *fPtr)
{
- const DeclaredSlot *slotInfoPtr;
Tcl_Interp *interp = fPtr->interp;
- Tcl_Obj *getName, *setName, *resolveName;
Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
- Class *slotCls;
+ Tcl_Class slotCls;
+ const DeclaredSlotMethod *smPtr;
+ const DeclaredSlot *slotPtr;
if (object == NULL) {
return TCL_ERROR;
}
- slotCls = ((Object *) object)->classPtr;
+ slotCls = (Tcl_Class) ((Object *) object)->classPtr;
if (slotCls == NULL) {
return TCL_ERROR;
}
- TclNewLiteralStringObj(getName, "Get");
- TclNewLiteralStringObj(setName, "Set");
- TclNewLiteralStringObj(resolveName, "Resolve");
- for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+ for (smPtr = slotMethods; smPtr->name; smPtr++) {
+ Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1);
+ Tcl_NewMethod(interp, slotCls, name, smPtr->flags,
+ &smPtr->implType, NULL);
+ Tcl_BounceRefCount(name);
+ }
+
+ for (slotPtr = slots ; slotPtr->name ; slotPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
- (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
- NULL, 0);
+ slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
if (slotObject == NULL) {
continue;
}
- TclNewInstanceMethod(interp, slotObject, getName, 0,
- &slotInfoPtr->getterType, NULL);
- TclNewInstanceMethod(interp, slotObject, setName, 0,
- &slotInfoPtr->setterType, NULL);
- if (slotInfoPtr->resolverType.callProc) {
- TclNewInstanceMethod(interp, slotObject, resolveName, 0,
- &slotInfoPtr->resolverType, NULL);
+ TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0,
+ &slotPtr->getterType, NULL);
+ TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0,
+ &slotPtr->setterType, NULL);
+ if (slotPtr->resolverType.callProc) {
+ TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
+ &slotPtr->resolverType, NULL);
}
}
- Tcl_BounceRefCount(getName);
- Tcl_BounceRefCount(setName);
- Tcl_BounceRefCount(resolveName);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
+ * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll --
+ *
+ * How to call the standard low-level methods of a slot.
+ * ResolveAll is the lifting of CallSlotResolve to work over a whole
+ * list of items.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+/* Call [$slot Get] to retrieve the list of contents of the slot */
+static inline Tcl_Obj *
+CallSlotGet(
+ Tcl_Interp *interp,
+ Object *slot)
+{
+ Tcl_Obj *getArgs[2];
+ int code;
+
+ getArgs[0] = slot->fPtr->myName;
+ getArgs[1] = slot->fPtr->slotGetName;
+ code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs);
+ if (code != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+}
+
+/* Call [$slot Set $list] to set the list of contents of the slot */
+static inline int
+CallSlotSet(
+ Tcl_Interp *interp,
+ Object *slot,
+ Tcl_Obj *list)
+{
+ Tcl_Obj *setArgs[3];
+ setArgs[0] = slot->fPtr->myName;
+ setArgs[1] = slot->fPtr->slotSetName;
+ setArgs[2] = list;
+ return TclOOPrivateObjectCmd(slot, interp, 3, setArgs);
+}
+
+/* Call [$slot Resolve $item] to convert a slot item into canonical form */
+static inline Tcl_Obj *
+CallSlotResolve(
+ Tcl_Interp *interp,
+ Object *slot,
+ Tcl_Obj *item)
+{
+ Tcl_Obj *resolveArgs[3];
+ int code;
+
+ resolveArgs[0] = slot->fPtr->myName;
+ resolveArgs[1] = slot->fPtr->slotResolveName;
+ resolveArgs[2] = item;
+ code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs);
+ if (code != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+}
+
+static inline Tcl_Obj *
+ResolveAll(
+ Tcl_Interp *interp,
+ Object *slot,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp,
+ sizeof(Tcl_Obj *) * objc);
+ Tcl_Obj *resolvedList;
+ int i;
+
+ for (i = 0; i < objc; i++) {
+ resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]);
+ if (resolvedItems[i] == NULL) {
+ for (int j = 0; j < i; j++) {
+ Tcl_DecrRefCount(resolvedItems[j]);
+ }
+ TclStackFree(interp, (void *) resolvedItems);
+ return NULL;
+ }
+ Tcl_IncrRefCount(resolvedItems[i]);
+ Tcl_ResetResult(interp);
+ }
+ resolvedList = Tcl_NewListObj(objc, resolvedItems);
+ for (i = 0; i < objc; i++) {
+ TclDecrRefCount(resolvedItems[i]);
+ }
+ TclStackFree(interp, (void *) resolvedItems);
+ return resolvedList;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Append --
+ *
+ * Implementation of the "-append" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Append(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code;
+ Tcl_Obj *resolved, *list;
+
+ if (skip == objc) {
+ return TCL_OK;
+ }
+
+ /* Resolve all values */
+ resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+ if (resolved == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* Get slot contents; store in list */
+ list = CallSlotGet(interp, oPtr);
+ if (list == NULL) {
+ Tcl_DecrRefCount(resolved);
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(list);
+ Tcl_ResetResult(interp);
+
+ /* Append */
+ if (Tcl_IsShared(list)) {
+ Tcl_Obj *dup = Tcl_DuplicateObj(list);
+ Tcl_IncrRefCount(dup);
+ Tcl_DecrRefCount(list);
+ list = dup;
+ }
+ if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ Tcl_DecrRefCount(resolved);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(resolved);
+
+ /* Set slot contents */
+ code = CallSlotSet(interp, oPtr, list);
+ Tcl_DecrRefCount(list);
+ return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_AppendNew --
+ *
+ * Implementation of the "-appendifnew" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_AppendNew(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew;
+ Tcl_Obj *resolved, *list, **listv;
+ Tcl_Size listc, i;
+ Tcl_HashTable unique;
+
+ if (skip == objc) {
+ return TCL_OK;
+ }
+
+ /* Resolve all values */
+ resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+ if (resolved == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* Get slot contents; store in list */
+ list = CallSlotGet(interp, oPtr);
+ if (list == NULL) {
+ Tcl_DecrRefCount(resolved);
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(list);
+ Tcl_ResetResult(interp);
+
+ /* Prepare a set of items in the list to set */
+ if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ Tcl_DecrRefCount(resolved);
+ return TCL_ERROR;
+ }
+ Tcl_InitObjHashTable(&unique);
+ for (i=0 ; i<listc; i++) {
+ Tcl_CreateHashEntry(&unique, listv[i], &isNew);
+ }
+
+ /* Append the new items if they're not already there */
+ if (Tcl_IsShared(list)) {
+ Tcl_Obj *dup = Tcl_DuplicateObj(list);
+ Tcl_IncrRefCount(dup);
+ Tcl_DecrRefCount(list);
+ list = dup;
+ }
+ TclListObjGetElements(NULL, resolved, &listc, &listv);
+ for (i=0 ; i<listc; i++) {
+ Tcl_CreateHashEntry(&unique, listv[i], &isNew);
+ if (isNew) {
+ Tcl_ListObjAppendElement(interp, list, listv[i]);
+ }
+ }
+ Tcl_DecrRefCount(resolved);
+ Tcl_DeleteHashTable(&unique);
+
+ /* Set slot contents */
+ code = CallSlotSet(interp, oPtr, list);
+ Tcl_DecrRefCount(list);
+ return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Clear --
+ *
+ * Implementation of the "-clear" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Clear(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code;
+ Tcl_Obj *list;
+
+ if (skip != objc) {
+ Tcl_WrongNumArgs(interp, skip, objv, NULL);
+ return TCL_ERROR;
+ }
+ list = Tcl_NewObj();
+ Tcl_IncrRefCount(list);
+ code = CallSlotSet(interp, oPtr, list);
+ Tcl_DecrRefCount(list);
+ return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Prepend --
+ *
+ * Implementation of the "-prepend" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Prepend(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code;
+ Tcl_Obj *list, *oldList;
+ if (skip == objc) {
+ return TCL_OK;
+ }
+
+ /* Resolve all values */
+ list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+ if (list == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(list);
+
+ /* Get slot contents and append to list */
+ oldList = CallSlotGet(interp, oPtr);
+ if (oldList == NULL) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ Tcl_ListObjAppendList(NULL, list, oldList);
+ Tcl_ResetResult(interp);
+
+ /* Set slot contents */
+ code = CallSlotSet(interp, oPtr, list);
+ Tcl_DecrRefCount(list);
+ return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Remove --
+ *
+ * Implementation of the "-remove" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Remove(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew;
+ Tcl_Size listc, i;
+ Tcl_Obj *resolved, *oldList, *newList, **listv;
+ Tcl_HashTable removeSet;
+
+ if (skip == objc) {
+ return TCL_OK;
+ }
+
+ /* Resolve all values */
+ resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+ if (resolved == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* Get slot contents; store in list */
+ oldList = CallSlotGet(interp, oPtr);
+ if (oldList == NULL) {
+ Tcl_DecrRefCount(resolved);
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(oldList);
+ Tcl_ResetResult(interp);
+
+ /* Prepare a set of items in the list to remove */
+ TclListObjGetElements(NULL, resolved, &listc, &listv);
+ Tcl_InitObjHashTable(&removeSet);
+ for (i=0 ; i<listc; i++) {
+ Tcl_CreateHashEntry(&removeSet, listv[i], &isNew);
+ }
+ Tcl_DecrRefCount(resolved);
+
+ /* Append the new items from the old items if they're not in the remove set */
+ if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) {
+ Tcl_DecrRefCount(oldList);
+ Tcl_DeleteHashTable(&removeSet);
+ return TCL_ERROR;
+ }
+ newList = Tcl_NewObj();
+ for (i=0 ; i<listc; i++) {
+ if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) {
+ Tcl_ListObjAppendElement(NULL, newList, listv[i]);
+ }
+ }
+ Tcl_DecrRefCount(oldList);
+ Tcl_DeleteHashTable(&removeSet);
+
+ /* Set slot contents */
+ Tcl_IncrRefCount(newList);
+ code = CallSlotSet(interp, oPtr, newList);
+ Tcl_DecrRefCount(newList);
+ return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Resolve --
+ *
+ * Default implementation of the "Resolve" slot accessor. Just returns
+ * its argument unchanged; particular slots may override.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Resolve(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int skip = Tcl_ObjectContextSkippedArgs(context);
+ if (skip + 1 != objc) {
+ Tcl_WrongNumArgs(interp, skip, objv, "list");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objv[objc - 1]);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Set --
+ *
+ * Implementation of the "-set" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Set(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code;
+ Tcl_Obj *list;
+
+ /* Resolve all values */
+ if (skip == objc) {
+ list = Tcl_NewObj();
+ } else {
+ list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+ if (list == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_IncrRefCount(list);
+
+ /* Set slot contents */
+ code = CallSlotSet(interp, oPtr, list);
+ Tcl_DecrRefCount(list);
+ return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Unimplemented --
+ *
+ * Default implementation of the "Get" and "Set" slot accessors. Just
+ * returns an error; actual slots must override.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Unimplemented(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_ObjectContext),
+ TCL_UNUSED(int),
+ TCL_UNUSED(Tcl_Obj *const *))
+{
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
+ OO_ERROR(interp, ABSTRACT_SLOT);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Unknown --
+ *
+ * Unknown method name handler for slots. Delegates to the default slot
+ * operation (--default-operation forwarded method) unless the first
+ * argument starts with a dash.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Unknown(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ int skip = Tcl_ObjectContextSkippedArgs(context), code;
+ if (skip >= objc) {
+ Tcl_Obj *args[2];
+ args[0] = oPtr->fPtr->myName;
+ args[1] = oPtr->fPtr->slotDefOpName;
+ return TclOOPrivateObjectCmd(oPtr, interp, 2, args);
+ } else if (TclGetString(objv[skip])[0] != '-') {
+ Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp,
+ sizeof(Tcl_Obj *) * (objc - skip + 2));
+ args[0] = oPtr->fPtr->myName;
+ args[1] = oPtr->fPtr->slotDefOpName;
+ memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip));
+ code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args);
+ TclStackFree(interp, args);
+ return code;
+ }
+ return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* ClassFilter_Get, ClassFilter_Set --
*
* Implementation of the "filter" slot accessors of the "oo::define"
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index ec91971..70b4a32 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -255,6 +255,7 @@ struct Object {
PropertyStorage properties; /* Information relating to the lists of
* properties that this object *claims* to
* support. */
+ Tcl_Obj *linkedCmdsList; /* List of names of linked commands. */
};
enum ObjectFlags {
@@ -405,8 +406,10 @@ struct Foundation {
* "<cloned>" pseudo-constructor. */
Tcl_Obj *defineName; /* Fully qualified name of oo::define. */
Tcl_Obj *myName; /* The "my" shared object. */
- Tcl_Obj *mcdName; /* The shared object for calling the helper to
- * mix in class delegates. */
+ Tcl_Obj *slotGetName; /* The "Get" name used by slots. */
+ Tcl_Obj *slotSetName; /* The "Set" name used by slots. */
+ Tcl_Obj *slotResolveName; /* The "Resolve" name used by slots. */
+ Tcl_Obj *slotDefOpName; /* The "--default-operation" name used by slots. */
};
/*
@@ -498,12 +501,14 @@ struct DeclaredClassMethod {
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefineInitialiseObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd;
@@ -513,7 +518,11 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePropertyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODelegateNameObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOLinkObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd;
@@ -608,6 +617,7 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
MODULE_SCOPE void TclOODefineBasicMethods(Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
+MODULE_SCOPE Tcl_Obj * TclOOObjectMyName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 98fa20e..318a7ac 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,178 +27,8 @@
static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
-"\t::namespace path {}\n"
-"\tnamespace eval Helpers {\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"
-"\t\tnamespace export callback\n"
-"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
-"\t\tnamespace export -clear\n"
-"\t\trename tmp::callback mymethod\n"
-"\t\tnamespace delete tmp\n"
-"\t\tproc classvariable {name args} {\n"
-"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
-"\t\t\tforeach v [list $name {*}$args] {\n"
-"\t\t\t\tif {[string match *(*) $v]} {\n"
-"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
-"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {[string match *::* $v]} {\n"
-"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
-"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t\t}\n"
-"\t\t\t\tlappend vs $v $v\n"
-"\t\t\t}\n"
-"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
-"\t\t}\n"
-"\t\tproc link {args} {\n"
-"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
-"\t\t\tforeach link $args {\n"
-"\t\t\t\tif {[llength $link] == 2} {\n"
-"\t\t\t\t\tlassign $link src dst\n"
-"\t\t\t\t} elseif {[llength $link] == 1} {\n"
-"\t\t\t\t\tlassign $link src\n"
-"\t\t\t\t\tset dst $src\n"
-"\t\t\t\t} else {\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
-"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {![string match ::* $src]} {\n"
-"\t\t\t\t\tset src [string cat $ns :: $src]\n"
-"\t\t\t\t}\n"
-"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
-"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
-"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
-"\t\t\t}\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc UnlinkLinkedCommand {cmd args} {\n"
-"\t\tif {[namespace which $cmd] ne {}} {\n"
-"\t\t\trename $cmd {}\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc DelegateName {class} {\n"
-"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
-"\t}\n"
-"\tproc MixinClassDelegates {class} {\n"
-"\t\tif {![info object isa class $class]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tset delegate [DelegateName $class]\n"
-"\t\tif {![info object isa class $delegate]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tforeach c [info class superclass $class] {\n"
-"\t\t\tset d [DelegateName $c]\n"
-"\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 -appendifnew $d\n"
-"\t\t}\n"
-"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
-"\t}\n"
-"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
-"\t\tset originDelegate [DelegateName $originObject]\n"
-"\t\tset targetDelegate [DelegateName $targetObject]\n"
-"\t\tif {\n"
-"\t\t\t[info object isa class $originDelegate]\n"
-"\t\t\t&& ![info object isa class $targetDelegate]\n"
-"\t\t} then {\n"
-"\t\t\tcopy $originDelegate $targetDelegate\n"
-"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
-"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
-"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
-"\t\t\t\t}]\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc define::classmethod {name args} {\n"
-"\t\t::set argc [::llength [::info level 0]]\n"
-"\t\t::if {$argc == 3} {\n"
-"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
-"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
-"\t\t\t\t[::lindex [::info level 0] 0]]\n"
-"\t\t}\n"
-"\t\t::set cls [::uplevel 1 self]\n"
-"\t\t::if {$argc == 4} {\n"
-"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
-"\t\t}\n"
-"\t\t::tailcall forward $name myclass $name\n"
-"\t}\n"
-"\tproc define::initialise {body} {\n"
-"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
-"\t\t::tailcall apply [::list {} $body $clsns]\n"
-"\t}\n"
-"\tnamespace eval define {\n"
-"\t\t::namespace export initialise\n"
-"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
-"\t\t::namespace export -clear\n"
-"\t\t::rename tmp::initialise initialize\n"
-"\t\t::namespace delete tmp\n"
-"\t}\n"
-"\tdefine Slot {\n"
-"\t\tmethod Get -unexport {} {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Set -unexport list {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Resolve -unexport list {\n"
-"\t\t\treturn $list\n"
-"\t\t}\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 -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 -appendifnew -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\tforeach a $args {\n"
-"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
-"\t\t\t\tif {$a ni $current} {\n"
-"\t\t\t\t\tlappend current $a\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\ttailcall my Set $current\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 -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 [lmap val $current {\n"
-"\t\t\t\tif {$val in $args} continue else {set val}\n"
-"\t\t\t}]\n"
-"\t\t}\n"
-"\t\tforward --default-operation my -append\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"
-"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
-"\t\t\t\ttailcall my $def {*}$args\n"
-"\t\t\t}\n"
-"\t\t\tnext {*}$args\n"
-"\t\t}\n"
-"\t\tunexport destroy\n"
-"\t}\n"
+"\tdefine Slot forward --default-operation my -append\n"
+"\tdefine Slot unexport destroy\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"
@@ -230,58 +60,65 @@ static const char *tclOOSetupScript =
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
+"\t\tset targetObject [self]\n"
"\t\tnext $originObject\n"
-"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t\tset originDelegate [::oo::DelegateName $originObject]\n"
+"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\t::oo::copy $originDelegate $targetDelegate\n"
+"\t\t\t::oo::objdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
"\t}\n"
-"\tclass create singleton {\n"
-"\t\tsuperclass class\n"
-"\t\tvariable object\n"
-"\t\tunexport create createWithNamespace\n"
-"\t\tmethod new args {\n"
-"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
-"\t\t\t\tset object [next {*}$args]\n"
-"\t\t\t\t::oo::objdefine $object {\n"
-"\t\t\t\t\tmethod destroy {} {\n"
-"\t\t\t\t\t\t::return -code error -errorcode {TCL OO 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> -unexport {originObject} {\n"
-"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
-"\t\t\t\t\t}\n"
+"\tclass create singleton\n"
+"\tdefine singleton superclass -set class\n"
+"\tdefine singleton variable -set object\n"
+"\tdefine singleton unexport create createWithNamespace\n"
+"\tdefine singleton method new args {\n"
+"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\tset object [next {*}$args]\n"
+"\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
-"\t\t\treturn $object\n"
"\t\t}\n"
+"\t\treturn $object\n"
"\t}\n"
-"\tclass create abstract {\n"
-"\t\tsuperclass class\n"
-"\t\tunexport create createWithNamespace new\n"
+"\tclass create abstract\n"
+"\tdefine abstract superclass -set class\n"
+"\tdefine abstract unexport create createWithNamespace new\n"
+"\tnamespace eval configuresupport::configurableclass {\n"
+"\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t::namespace path ::oo::define\n"
+"\t\t::namespace export property\n"
"\t}\n"
-"\tnamespace eval configuresupport {\n"
-"\t\t::namespace eval configurableclass {\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\t::namespace eval configurableobject {\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\t::oo::define configurable {\n"
-"\t\t\tdefinitionnamespace -instance configurableobject\n"
-"\t\t\tdefinitionnamespace -class configurableclass\n"
-"\t\t}\n"
+"\tnamespace eval configuresupport::configurableobject {\n"
+"\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t::namespace path ::oo::objdefine\n"
+"\t\t::namespace export property\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"
+"\tdefine configuresupport::configurable {\n"
+"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
"\t}\n"
+"\tclass create configurable\n"
+"\tdefine configurable superclass -set class\n"
+"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
+"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
+"\t\tnext $definitionScript\n"
+"\t}\n"
+"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
"}\n"
/* !END!: Do not edit above this line. */
;
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index 20607b0..5a8a25b 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -366,7 +366,7 @@ test ooUtil-3.4 {TIP 478: class initialisation} -setup {
trace add execution oo::define::initialise enter appendToResultVar
oo::class create ::cls {
superclass parent
- initialize {proc xyzzy {} {}}
+ initialise {proc xyzzy {} {}}
}
return $result
} -cleanup {
@@ -375,13 +375,7 @@ test ooUtil-3.4 {TIP 478: class initialisation} -setup {
}
rename ::appendToResultVar {}
parent destroy
-} -result {{initialize {proc xyzzy {} {}}} enter}
-test ooUtil-3.5 {TIP 478: class initialisation} -body {
- oo::define oo::object {
- ::list [::namespace which initialise] [::namespace which initialize] \
- [::namespace origin initialise] [::namespace origin initialize]
- }
-} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
+} -result {{initialise {proc xyzzy {} {}}} enter}
test ooUtil-4.1 {TIP 478: singleton} -setup {
oo::class create parent
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2110861..66e125d 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -12,231 +12,6 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
::namespace eval ::oo {
- ::namespace path {}
-
- #
- # Commands that are made available to objects by default.
- #
- namespace eval Helpers {
- namespace path {}
-
- # ------------------------------------------------------------------
- #
- # callback, mymethod --
- #
- # Create a script prefix that calls a method on the current
- # object. Same operation, two names.
- #
- # ------------------------------------------------------------------
-
- proc callback {method args} {
- list [uplevel 1 {::namespace which my}] $method {*}$args
- }
-
- # Make the [callback] command appear as [mymethod] too.
- namespace export callback
- namespace eval tmp {namespace import ::oo::Helpers::callback}
- namespace export -clear
- rename tmp::callback mymethod
- namespace delete tmp
-
- # ------------------------------------------------------------------
- #
- # classvariable --
- #
- # Link to a variable in the class of the current object.
- #
- # ------------------------------------------------------------------
-
- proc classvariable {name args} {
- # Get a reference to the class's namespace
- set ns [info object namespace [uplevel 1 {self class}]]
- # Double up the list of variable names
- foreach v [list $name {*}$args] {
- if {[string match *(*) $v]} {
- set reason "can't create a scalar variable that looks like an array element"
- return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
- [format {bad variable name "%s": %s} $v $reason]
- }
- if {[string match *::* $v]} {
- set reason "can't create a local variable with a namespace separator in it"
- return -code error -errorcode {TCL UPVAR INVERTED} \
- [format {bad variable name "%s": %s} $v $reason]
- }
- lappend vs $v $v
- }
- # Lastly, link the caller's local variables to the class's variables
- tailcall namespace upvar $ns {*}$vs
- }
-
- # ------------------------------------------------------------------
- #
- # link --
- #
- # Make a command that invokes a method on the current object.
- # The name of the command and the name of the method match by
- # default.
- #
- # ------------------------------------------------------------------
-
- proc link {args} {
- set ns [uplevel 1 {::namespace current}]
- foreach link $args {
- if {[llength $link] == 2} {
- lassign $link src dst
- } elseif {[llength $link] == 1} {
- lassign $link src
- set dst $src
- } else {
- return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
- "bad link description; must only have one or two elements"
- }
- if {![string match ::* $src]} {
- set src [string cat $ns :: $src]
- }
- interp alias {} $src {} ${ns}::my $dst
- trace add command ${ns}::my delete [list \
- ::oo::UnlinkLinkedCommand $src]
- }
- return
- }
- }
-
- # ----------------------------------------------------------------------
- #
- # UnlinkLinkedCommand --
- #
- # Callback used to remove linked command when the underlying mechanism
- # that supports it is deleted.
- #
- # ----------------------------------------------------------------------
-
- proc UnlinkLinkedCommand {cmd args} {
- if {[namespace which $cmd] ne {}} {
- rename $cmd {}
- }
- }
-
- # ----------------------------------------------------------------------
- #
- # DelegateName --
- #
- # Utility that gets the name of the class delegate for a class. It's
- # trivial, but makes working with them much easier as delegate names are
- # intentionally hard to create by accident.
- #
- # ----------------------------------------------------------------------
-
- proc DelegateName {class} {
- string cat [info object namespace $class] {:: oo ::delegate}
- }
-
- # ----------------------------------------------------------------------
- #
- # MixinClassDelegates --
- #
- # Support code called *after* [oo::define] inside the constructor of a
- # class that patches in the appropriate class delegates.
- #
- # ----------------------------------------------------------------------
-
- proc MixinClassDelegates {class} {
- if {![info object isa class $class]} {
- return
- }
- set delegate [DelegateName $class]
- if {![info object isa class $delegate]} {
- return
- }
- foreach c [info class superclass $class] {
- set d [DelegateName $c]
- if {![info object isa class $d]} {
- continue
- }
- define $delegate ::oo::define::superclass -appendifnew $d
- }
- objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
- }
-
- # ----------------------------------------------------------------------
- #
- # UpdateClassDelegatesAfterClone --
- #
- # Support code that is like [MixinClassDelegates] except for when a
- # class is cloned.
- #
- # ----------------------------------------------------------------------
-
- proc UpdateClassDelegatesAfterClone {originObject targetObject} {
- # Rebuild the class inheritance delegation class
- set originDelegate [DelegateName $originObject]
- set targetDelegate [DelegateName $targetObject]
- if {
- [info object isa class $originDelegate]
- && ![info object isa class $targetDelegate]
- } then {
- copy $originDelegate $targetDelegate
- objdefine $targetObject ::oo::objdefine::mixin -set \
- {*}[lmap c [info object mixin $targetObject] {
- if {$c eq $originDelegate} {set targetDelegate} {set c}
- }]
- }
- }
-
- # ----------------------------------------------------------------------
- #
- # oo::define::classmethod --
- #
- # Defines a class method. See define(n) for details.
- #
- # Note that the ::oo::define namespace is semi-public and a bit weird
- # anyway, so we don't regard the namespace path as being under control:
- # fully qualified names are used for everything.
- #
- # ----------------------------------------------------------------------
-
- proc define::classmethod {name args} {
- # Create the method on the class if the caller gave arguments and body
- ::set argc [::llength [::info level 0]]
- ::if {$argc == 3} {
- ::return -code error -errorcode {TCL WRONGARGS} [::format \
- {wrong # args: should be "%s name ?args body?"} \
- [::lindex [::info level 0] 0]]
- }
- ::set cls [::uplevel 1 self]
- ::if {$argc == 4} {
- ::oo::define [::oo::DelegateName $cls] method $name {*}$args
- }
- # Make the connection by forwarding
- ::tailcall forward $name myclass $name
- }
-
- # ----------------------------------------------------------------------
- #
- # oo::define::initialise, oo::define::initialize --
- #
- # Do specific initialisation for a class. See define(n) for details.
- #
- # Note that the ::oo::define namespace is semi-public and a bit weird
- # anyway, so we don't regard the namespace path as being under control:
- # fully qualified names are used for everything.
- #
- # ----------------------------------------------------------------------
-
- proc define::initialise {body} {
- ::set clsns [::info object namespace [::uplevel 1 self]]
- ::tailcall apply [::list {} $body $clsns]
- }
-
- # Make the [initialise] definition appear as [initialize] too
- namespace eval define {
- ::namespace export initialise
- ::namespace eval tmp {::namespace import ::oo::define::initialise}
- ::namespace export -clear
- ::rename tmp::initialise initialize
- ::namespace delete tmp
- }
-
# ----------------------------------------------------------------------
#
# Slot --
@@ -246,110 +21,18 @@
#
# ----------------------------------------------------------------------
- define Slot {
- # ------------------------------------------------------------------
- #
- # Slot Get --
- #
- # Basic slot getter. Retrieves the contents of the slot.
- # Particular slots must provide concrete non-erroring
- # implementation.
- #
- # ------------------------------------------------------------------
-
- method Get -unexport {} {
- return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
- }
-
- # ------------------------------------------------------------------
- #
- # Slot Set --
- #
- # Basic slot setter. Sets the contents of the slot. Particular
- # slots must provide concrete non-erroring implementation.
- #
- # ------------------------------------------------------------------
-
- method Set -unexport list {
- return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
- }
-
- # ------------------------------------------------------------------
- #
- # Slot Resolve --
- #
- # Helper that lets a slot convert a list of arguments of a
- # particular type to their canonical forms. Defaults to doing
- # nothing (suitable for simple strings).
- #
- # ------------------------------------------------------------------
-
- method Resolve -unexport list {
- return $list
- }
-
- # ------------------------------------------------------------------
- #
- # Slot -set, -append, -clear, --default-operation --
- #
- # Standard public slot operations. If a slot can't figure out
- # what method to call directly, it uses --default-operation.
- #
- # ------------------------------------------------------------------
-
- method -set -export args {
- set my [namespace which my]
- set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
- tailcall my Set $args
- }
- method -append -export args {
- set my [namespace which my]
- set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
- set current [uplevel 1 [list $my Get]]
- tailcall my Set [list {*}$current {*}$args]
- }
- method -appendifnew -export args {
- set my [namespace which my]
- set current [uplevel 1 [list $my Get]]
- foreach a $args {
- set a [uplevel 1 [list $my Resolve $a]]
- if {$a ni $current} {
- lappend current $a
- }
- }
- tailcall my Set $current
- }
- method -clear -export {} {tailcall my Set {}}
- method -prepend -export args {
- set my [namespace which my]
- set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
- set current [uplevel 1 [list $my Get]]
- tailcall my Set [list {*}$args {*}$current]
- }
- method -remove -export args {
- set my [namespace which my]
- set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
- set current [uplevel 1 [list $my Get]]
- tailcall my Set [lmap val $current {
- if {$val in $args} continue else {set val}
- }]
- }
-
- # Default handling
- forward --default-operation my -append
- method unknown -unexport {args} {
- set def --default-operation
- if {[llength $args] == 0} {
- tailcall my $def
- } elseif {![string match -* [lindex $args 0]]} {
- tailcall my $def {*}$args
- }
- next {*}$args
- }
+ # ------------------------------------------------------------------
+ #
+ # Slot --default-operation --
+ #
+ # If a slot can't figure out what method to call directly, it
+ # uses --default-operation.
+ #
+ # ------------------------------------------------------------------
+ define Slot forward --default-operation my -append
- # Hide destroy
- unexport destroy
- }
+ # Hide destroy
+ define Slot unexport destroy
# Set the default operation differently for these slots
objdefine define::superclass forward --default-operation my -set
@@ -408,9 +91,21 @@
# ----------------------------------------------------------------------
define class method <cloned> -unexport {originObject} {
+ set targetObject [self]
next $originObject
# Rebuild the class inheritance delegation class
- ::oo::UpdateClassDelegatesAfterClone $originObject [self]
+ set originDelegate [::oo::DelegateName $originObject]
+ set targetDelegate [::oo::DelegateName $targetObject]
+ if {
+ [info object isa class $originDelegate]
+ && ![info object isa class $targetDelegate]
+ } then {
+ ::oo::copy $originDelegate $targetDelegate
+ ::oo::objdefine $targetObject mixin -set \
+ {*}[lmap c [info object mixin $targetObject] {
+ if {$c eq $originDelegate} {set targetDelegate} {set c}
+ }]
+ }
}
# ----------------------------------------------------------------------
@@ -422,26 +117,25 @@
#
# ----------------------------------------------------------------------
- class create singleton {
- superclass class
- variable object
- unexport create createWithNamespace
- method new args {
- if {![info exists object] || ![info object isa object $object]} {
- set object [next {*}$args]
- ::oo::objdefine $object {
- method destroy {} {
- ::return -code error -errorcode {TCL OO SINGLETON} \
- "may not destroy a singleton object"
- }
- method <cloned> -unexport {originObject} {
- ::return -code error -errorcode {TCL OO SINGLETON} \
- "may not clone a singleton object"
- }
+ class create singleton
+ define singleton superclass -set class
+ define singleton variable -set object
+ define singleton unexport create createWithNamespace
+ define singleton method new args {
+ if {![info exists object] || ![info object isa object $object]} {
+ set object [next {*}$args]
+ ::oo::objdefine $object {
+ method destroy {} {
+ return -code error -errorcode {TCL OO SINGLETON} \
+ "may not destroy a singleton object"
+ }
+ method <cloned> -unexport {originObject} {
+ return -code error -errorcode {TCL OO SINGLETON} \
+ "may not clone a singleton object"
}
}
- return $object
}
+ return $object
}
# ----------------------------------------------------------------------
@@ -453,10 +147,9 @@
#
# ----------------------------------------------------------------------
- class create abstract {
- superclass class
- unexport create createWithNamespace new
- }
+ class create abstract
+ define abstract superclass -set class
+ define abstract unexport create createWithNamespace new
# ----------------------------------------------------------------------
#
@@ -483,47 +176,45 @@
#
# ----------------------------------------------------------------------
- namespace eval configuresupport {
- # ------------------------------------------------------------------
- #
- # oo::configuresupport::configurableclass,
- # oo::configuresupport::configurableobject --
- #
- # Namespaces used as implementation vectors for oo::define and
- # oo::objdefine when the class/instance is configurable.
- # Note that these also contain commands implemented in C,
- # especially the [property] definition command.
- #
- # ------------------------------------------------------------------
+ # ------------------------------------------------------------------
+ #
+ # oo::configuresupport::configurableclass,
+ # oo::configuresupport::configurableobject --
+ #
+ # Namespaces used as implementation vectors for oo::define and
+ # oo::objdefine when the class/instance is configurable.
+ # Note that these also contain commands implemented in C,
+ # especially the [property] definition command.
+ #
+ # ------------------------------------------------------------------
- ::namespace eval configurableclass {
- # Plural alias just in case; deliberately NOT documented!
- ::proc properties args {::tailcall property {*}$args}
- ::namespace path ::oo::define
- ::namespace export property
- }
+ namespace eval configuresupport::configurableclass {
+ # Plural alias just in case; deliberately NOT documented!
+ ::proc properties args {::tailcall property {*}$args}
+ ::namespace path ::oo::define
+ ::namespace export property
+ }
- ::namespace eval configurableobject {
- # Plural alias just in case; deliberately NOT documented!
- ::proc properties args {::tailcall property {*}$args}
- ::namespace path ::oo::objdefine
- ::namespace export property
- }
+ namespace eval configuresupport::configurableobject {
+ # Plural alias just in case; deliberately NOT documented!
+ ::proc properties args {::tailcall property {*}$args}
+ ::namespace path ::oo::objdefine
+ ::namespace export property
+ }
- # ------------------------------------------------------------------
- #
- # oo::configuresupport::configurable --
- #
- # The class that contains the implementation of the actual
- # 'configure' method (mixed into actually configurable classes).
- # The 'configure' method is in tclOOBasic.c.
- #
- # ------------------------------------------------------------------
+ # ------------------------------------------------------------------
+ #
+ # oo::configuresupport::configurable --
+ #
+ # The class that contains the implementation of the actual
+ # 'configure' method (mixed into actually configurable classes).
+ # The 'configure' method is in tclOOBasic.c.
+ #
+ # ------------------------------------------------------------------
- ::oo::define configurable {
- definitionnamespace -instance configurableobject
- definitionnamespace -class configurableclass
- }
+ define configuresupport::configurable {
+ definitionnamespace -instance configuresupport::configurableobject
+ definitionnamespace -class configuresupport::configurableclass
}
# ----------------------------------------------------------------------
@@ -538,16 +229,14 @@
#
# ----------------------------------------------------------------------
- class create configurable {
- superclass class
-
- constructor {{definitionScript ""}} {
- next {mixin ::oo::configuresupport::configurable}
- next $definitionScript
- }
-
- definitionnamespace -class configuresupport::configurableclass
+ class create configurable
+ define configurable superclass -set class
+ define configurable constructor {{definitionScript ""}} {
+ ::oo::define [self] {mixin -append ::oo::configuresupport::configurable}
+ next $definitionScript
}
+
+ define configurable definitionnamespace -class configuresupport::configurableclass
}
# Local Variables:
generated by cgit v0.12 at 2025-12-26 11:58:27 (GMT)