diff options
Diffstat (limited to 'generic/tclOO.c')
| -rw-r--r-- | generic/tclOO.c | 550 |
1 files changed, 332 insertions, 218 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index 1c2277e..e9cc0f0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -26,11 +26,13 @@ static const struct { int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, + {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, @@ -41,7 +43,9 @@ static const struct { {"export", TclOODefineExportObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -69,7 +73,9 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; -static void initClassPath(Tcl_Interp * interp, Class *clsPtr); +static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); +static void InitClassSystemRoots(Tcl_Interp *interp, + Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -78,22 +84,20 @@ static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); +static inline void RemoveClass(Class **list, int num, int idx); +static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); -static int PublicObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateObjectCmd(ClientData clientData, +static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(ClientData clientData, +static int MyClassNRObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static void RemoveClass(Class ** list, int num, int idx); -static void RemoveObject(Object ** list, int num, int idx); +static void MyClassDeleted(ClientData clientData); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -144,65 +148,10 @@ static const char *initScript = /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The scripted part of the definitions of slots. + * The scripted part of the definitions of TclOO. */ -static const char *slotScript = -"::oo::define ::oo::Slot {\n" -" method Get {} {error unimplemented}\n" -" method Set list {error unimplemented}\n" -" method -set args {\n" -" uplevel 1 [list [namespace which my] Set $args]\n" -" }\n" -" method -append args {\n" -" uplevel 1 [list [namespace which my] Set [list" -" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" -" }\n" -" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" -" forward --default-operation my -append\n" -" method unknown {args} {\n" -" set def --default-operation\n" -" if {[llength $args] == 0} {\n" -" return [uplevel 1 [list [namespace which my] $def]]\n" -" } elseif {![string match -* [lindex $args 0]]} {\n" -" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" -" }\n" -" next {*}$args\n" -" }\n" -" export -set -append -clear\n" -" unexport unknown destroy\n" -"}\n" -"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" -"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; - -/* - * The body of the <cloned> method of oo::object. - */ - -static const char *clonedBody = -"foreach p [info procs [info object namespace $originObject]::*] {" -" set args [info args $p];" -" set idx -1;" -" foreach a $args {" -" lset args [incr idx] " -" [if {[info default $p $a d]} {list $a $d} {list $a}]" -" };" -" set b [info body $p];" -" set p [namespace tail $p];" -" proc $p $args $b;" -"};" -"foreach v [info vars [info object namespace $originObject]::*] {" -" upvar 0 $v vOrigin;" -" namespace upvar [namespace current] [namespace tail $v] vNew;" -" if {[info exists vOrigin]} {" -" if {[array exists vOrigin]} {" -" array set vNew [array get vOrigin];" -" } else {" -" set vNew $vOrigin;" -" }" -" }" -"}"; +#include "tclOOScript.h" /* * The actual definition of the variable holding the TclOO stub table. @@ -232,14 +181,50 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ - do { \ - Remove ## type ((lst).list, (lst).num, i); \ - (lst).num--; \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ } while (0) /* * ---------------------------------------------------------------------- * + * RemoveClass, RemoveObject -- + * + * Helpers for the RemoveItem macro for deleting a class or object from a + * list. Setting the "empty" location to NULL makes debugging a little + * easier. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RemoveClass( + Class **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +static inline void +RemoveObject( + Object **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +/* + * ---------------------------------------------------------------------- + * * TclOOInit -- * * Called to initialise the OO system within an interpreter. @@ -271,7 +256,7 @@ TclOOInit( * to be fully provided. */ - if (Tcl_Eval(interp, initScript) != TCL_OK) { + if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { return TCL_ERROR; } @@ -316,11 +301,7 @@ InitFoundation( ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); - Tcl_Obj *namePtr, *argsPtr, *bodyPtr; - - Class fakeCls; - Object fakeObject; - + Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; @@ -383,28 +364,98 @@ InitFoundation( Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the objects at the core of the object system. These need to be - * spliced manually. + * Create the special objects at the core of the object system. */ + InitClassSystemRoots(interp, fPtr); + /* - * Stand up a phony class for bootstrapping. + * Basic method declarations for the core classes. */ - fPtr->objectCls = &fakeCls; + for (i = 0 ; objMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); + } + for (i = 0 ; clsMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); + } /* - * Referenced in TclOOAllocClass to increment the refCount. + * Finish setting up the class of classes by marking the 'new' method as + * private; classes, unlike general objects, must have explicit names. We + * also need to create the constructor for classes. */ - fakeCls.thisPtr = &fakeObject; + TclNewLiteralStringObj(namePtr, "new"); + Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, + namePtr /* keeps ref */, 0 /* private */, NULL, NULL); + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); - fPtr->objectCls = TclOOAllocClass(interp, - AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); /* - * Corresponding TclOODecrRefCount in KillFoudation. + * Create non-object commands and plug ourselves into the Tcl [info] + * ensemble. */ + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextToCmd; + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", + TclOOSelfObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectSelfCmd; + Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); + TclOOInitInfo(interp); + + /* + * Now make the class of slots. + */ + + if (TclOODefineSlots(fPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Evaluate the remaining definitions, which are a compiled-in Tcl script. + */ + + return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); +} + +/* + * ---------------------------------------------------------------------- + * + * InitClassSystemRoots -- + * + * Creates the objects at the core of the object system. These need to be + * spliced manually. + * + * ---------------------------------------------------------------------- + */ + +static void +InitClassSystemRoots( + Tcl_Interp *interp, + Foundation *fPtr) +{ + Class fakeCls; + Object fakeObject; + Tcl_Obj *defNsName; + + /* Stand up a phony class for bootstrapping. */ + fPtr->objectCls = &fakeCls; + /* referenced in TclOOAllocClass to increment the refCount. */ + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = TclOOAllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); /* @@ -423,14 +474,13 @@ InitFoundation( fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; + TclNewLiteralStringObj(defNsName, "::oo::objdefine"); + fPtr->objectCls->objDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - - /* - * Corresponding TclOODecrRefCount in KillFoudation. - */ - + /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->classCls->thisPtr); /* @@ -455,77 +505,17 @@ InitFoundation( fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; + TclNewLiteralStringObj(defNsName, "::oo::define"); + fPtr->classCls->clsDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); - /* - * Standard initialization for new Objects. - */ - + /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* - * Basic method declarations for the core classes. - */ - - for (i = 0 ; objMethods[i].name ; i++) { - TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); - } - for (i = 0 ; clsMethods[i].name ; i++) { - TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); - } - - /* - * Create the default <cloned> method implementation, used when 'oo::copy' - * is called to finish the copying of one object to another. + * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. + * Everything else is careful to prohibit looping. */ - - TclNewLiteralStringObj(argsPtr, "originObject"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(clonedBody, -1); - TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, - bodyPtr, NULL); - TclDecrRefCount(argsPtr); - - /* - * Finish setting up the class of classes by marking the 'new' method as - * private; classes, unlike general objects, must have explicit names. We - * also need to create the constructor for classes. - */ - - TclNewLiteralStringObj(namePtr, "new"); - Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, - namePtr /* keeps ref */, 0 /* private */, NULL, NULL); - fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, - (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); - - /* - * Create non-object commands and plug ourselves into the Tcl [info] - * ensemble. - */ - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", - NULL, TclOONextObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectNextCmd; - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", - NULL, TclOONextToObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectNextToCmd; - cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", - TclOOSelfObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectSelfCmd; - Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); - TclOOInitInfo(interp); - - /* - * Now make the class of slots. - */ - - if (TclOODefineSlots(fPtr) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_Eval(interp, slotScript); } /* @@ -620,8 +610,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ - Namespace *nsPtr, /* The namespace to create the object in, - or NULL if *nameStr is NULL */ + Namespace *nsPtr, /* The namespace to create the object in, or + * NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -718,8 +708,8 @@ AllocObject( * destruction it occur: A call to ObjectRenamedTrace(), and a call to * ObjectNamespaceDeleted(). */ - oPtr->refCount = 2; + oPtr->refCount = 2; oPtr->flags = USE_CLASS_CACHE; /* @@ -734,10 +724,9 @@ AllocObject( if (nsPtr->parentPtr != NULL) { nsPtr = nsPtr->parentPtr; } - } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, - (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); + (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of @@ -754,7 +743,10 @@ AllocObject( tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, - PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", + oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, + MyClassDeleted); return oPtr; } @@ -782,12 +774,12 @@ SquelchCachedName( /* * ---------------------------------------------------------------------- * - * MyDeleted -- + * MyDeleted, MyClassDeleted -- * - * This callback is triggered when the object's [my] command is deleted - * by any mechanism. It just marks the object as not having a [my] - * command, and so prevents cleanup of that when the object itself is - * deleted. + * These callbacks are triggered when the object's [my] or [myclass] + * commands are deleted by any mechanism. They just mark the object as + * not having a [my] command or [myclass] command, and so prevent cleanup + * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ @@ -801,6 +793,14 @@ MyDeleted( oPtr->myCommand = NULL; } + +static void +MyClassDeleted( + ClientData clientData) +{ + Object *oPtr = clientData; + oPtr->myclassCommand = NULL; +} /* * ---------------------------------------------------------------------- @@ -824,6 +824,7 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; + /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. @@ -891,6 +892,7 @@ TclOODeleteDescendants( ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.size = 0; } + /* * Squelch subclasses of this class. */ @@ -960,6 +962,7 @@ TclOOReleaseClassContents( Method *mPtr; Foundation *fPtr = oPtr->fPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVariable; /* * Sanity check! @@ -976,6 +979,19 @@ TclOOReleaseClassContents( } /* + * Stop using the class for definition information. + */ + + if (clsPtr->clsDefinitionNs) { + Tcl_DecrRefCount(clsPtr->clsDefinitionNs); + clsPtr->clsDefinitionNs = NULL; + } + if (clsPtr->objDefinitionNs) { + Tcl_DecrRefCount(clsPtr->objDefinitionNs); + clsPtr->objDefinitionNs = NULL; + } + + /* * Squelch method implementation chain caches. */ @@ -1063,6 +1079,14 @@ TclOOReleaseClassContents( ckfree(clsPtr->variables.list); } + FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(clsPtr->privateVariables.list); + } + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } @@ -1092,6 +1116,7 @@ ObjectNamespaceDeleted( Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; + PrivateVariableMapping *privateVariable; Tcl_Interp *interp = oPtr->fPtr->interp; int i; @@ -1100,6 +1125,7 @@ ObjectNamespaceDeleted( * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, * this guard could be removed. */ + return; } @@ -1108,6 +1134,7 @@ ObjectNamespaceDeleted( * process of being deleted, nothing else may modify its bookeeping * records. This is the flag that */ + oPtr->flags |= OBJECT_DELETED; /* @@ -1127,7 +1154,7 @@ ObjectNamespaceDeleted( if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); int result; Tcl_InterpState state; @@ -1168,6 +1195,9 @@ ObjectNamespaceDeleted( Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } + if (oPtr->myclassCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); + } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } @@ -1212,6 +1242,14 @@ ObjectNamespaceDeleted( ckfree(oPtr->variables.list); } + FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(oPtr->privateVariables.list); + } + if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } @@ -1244,7 +1282,6 @@ ObjectNamespaceDeleted( if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) && !Tcl_InterpDeleted(interp)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } @@ -1267,7 +1304,7 @@ ObjectNamespaceDeleted( /* * ---------------------------------------------------------------------- * - * TclOODecrRef -- + * TclOODecrRefCount -- * * Decrement the refcount of an object and deallocate storage then object * is no longer referenced. Returns 1 if storage was deallocated, and 0 @@ -1275,8 +1312,13 @@ ObjectNamespaceDeleted( * * ---------------------------------------------------------------------- */ -int TclOODecrRefCount(Object *oPtr) { + +int +TclOODecrRefCount( + Object *oPtr) +{ if (oPtr->refCount-- <= 1) { + if (oPtr->classPtr != NULL) { ckfree(oPtr->classPtr); } @@ -1287,21 +1329,6 @@ int TclOODecrRefCount(Object *oPtr) { } /* - * Setting the "empty" location to NULL makes debugging a little easier. - */ - -#define REMOVEBODY { \ - for (; idx < num - 1; idx++) { \ - list[idx] = list[idx + 1]; \ - } \ - list[idx] = NULL; \ - return; \ -} -void RemoveClass(Class **list, int num, int idx) REMOVEBODY - -void RemoveObject(Object **list, int num, int idx) REMOVEBODY - -/* * ---------------------------------------------------------------------- * * TclOORemoveFromInstances -- @@ -1538,6 +1565,25 @@ TclOOAddToMixinSubs( * ---------------------------------------------------------------------- */ +static inline void +InitClassPath( + Tcl_Interp *interp, + Class *clsPtr) +{ + Foundation *fPtr = GetFoundation(interp); + + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } +} + Class * TclOOAllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the @@ -1554,7 +1600,8 @@ TclOOAllocClass( /* * Configure the namespace path for the class's object. */ - initClassPath(interp, clsPtr); + + InitClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1580,19 +1627,6 @@ TclOOAllocClass( Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } -static void -initClassPath(Tcl_Interp *interp, Class *clsPtr) { - Foundation *fPtr = GetFoundation(interp); - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } -} /* * ---------------------------------------------------------------------- @@ -1623,7 +1657,9 @@ Tcl_NewObjectInstance( ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return NULL;} + if (oPtr == NULL) { + return NULL; + } /* * Run constructors, except when objc < 0, which is a special flag case @@ -1632,7 +1668,7 @@ Tcl_NewObjectInstance( if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr != NULL) { int isRoot, result; @@ -1692,7 +1728,9 @@ TclNRNewObjectInstance( Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return TCL_ERROR;} + if (oPtr == NULL) { + return TCL_ERROR; + } /* * Run constructors, except when objc < 0 (a special flag case used for @@ -1703,7 +1741,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -1742,8 +1780,8 @@ TclNewObjectInstanceCommon( Foundation *fPtr = GetFoundation(interp); Object *oPtr; const char *simpleName = NULL; - Namespace *nsPtr = NULL, *dummy, - *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); + Namespace *nsPtr = NULL, *dummy; + Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if (nameStr) { TclGetNamespaceForQualName(interp, nameStr, inNsPtr, @@ -1805,8 +1843,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * Ensure an error if the object was deleted in the constructor. - * Don't want to lose errors by accident. [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. Don't + * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1872,6 +1910,7 @@ Tcl_CopyObjectInstance( Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + PrivateVariableMapping *privateVariable; int i, result; /* @@ -1945,7 +1984,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the object's variable resolution list to the new object. + * Copy the object's variable resolution lists to the new object. */ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); @@ -1953,6 +1992,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is @@ -2044,7 +2090,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the source class's variable resolution list. + * Copy the source class's variable resolution lists. */ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); @@ -2052,6 +2098,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). @@ -2128,7 +2181,8 @@ Tcl_CopyObjectInstance( } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; @@ -2416,7 +2470,7 @@ Tcl_ObjectSetMetadata( /* * ---------------------------------------------------------------------- * - * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- + * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- * * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands @@ -2426,8 +2480,8 @@ Tcl_ObjectSetMetadata( * ---------------------------------------------------------------------- */ -static int -PublicObjectCmd( +int +TclOOPublicObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2447,8 +2501,8 @@ PublicNRObjectCmd( NULL); } -static int -PrivateObjectCmd( +int +TclOOPrivateObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2501,6 +2555,43 @@ TclOOInvokeObject( /* * ---------------------------------------------------------------------- * + * TclOOMyClassObjCmd, MyClassNRObjCmd -- + * + * Special trap door to allow an object to delegate simply to its class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOMyClassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); +} + +static int +MyClassNRObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = clientData; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?"); + return TCL_ERROR; + } + return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, + NULL); +} + +/* + * ---------------------------------------------------------------------- + * * TclOOObjectCmdCore, FinalizeObjectCall -- * * Main function for object invocations. Does call chain creation, @@ -2525,6 +2616,9 @@ TclOOObjectCmdCore( { CallContext *contextPtr; Tcl_Obj *methodNamePtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + Object *callerObjPtr = NULL; + Class *callerClsPtr = NULL; int result; /* @@ -2539,6 +2633,24 @@ TclOOObjectCmdCore( } /* + * Determine if we're in a context that can see the extra, private methods + * in this class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContextPtr = framePtr->clientData; + Method *callerMethodPtr = + callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; + + if (callerMethodPtr->declaringObjectPtr) { + callerObjPtr = callerMethodPtr->declaringObjectPtr; + } + if (callerMethodPtr->declaringClassPtr) { + callerClsPtr = callerMethodPtr->declaringClassPtr; + } + } + + /* * Give plugged in code a chance to remap the method name. */ @@ -2565,7 +2677,8 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2582,7 +2695,8 @@ TclOOObjectCmdCore( noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), NULL); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" @@ -2832,9 +2946,9 @@ Tcl_GetObjectFromObj( if (cmdPtr == NULL) { goto notAnObject; } - if (cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr->objProc != TclOOPublicObjectCmd) { cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) { goto notAnObject; } } |