diff options
Diffstat (limited to 'generic/tclOO.c')
| -rw-r--r-- | generic/tclOO.c | 2977 |
1 files changed, 2977 insertions, 0 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c new file mode 100644 index 0000000..de00733 --- /dev/null +++ b/generic/tclOO.c @@ -0,0 +1,2977 @@ +/* + * tclOO.c -- + * + * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) + * + * Copyright (c) 2005-2012 by Donal K. Fellows + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * Commands in oo::define. + */ + +static const struct { + const char *name; + Tcl_ObjCmdProc *objProc; + int flag; +} defineCmds[] = { + {"constructor", TclOODefineConstructorObjCmd, 0}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"method", TclOODefineMethodObjCmd, 0}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, + {"self", TclOODefineSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, + {NULL, NULL, 0} +}, objdefCmds[] = { + {"class", TclOODefineClassObjCmd, 1}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, + {"export", TclOODefineExportObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 1}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"unexport", TclOODefineUnexportObjCmd, 1}, + {NULL, NULL, 0} +}; + +/* + * What sort of size of things we like to allocate. + */ + +#define ALLOC_CHUNK 8 + +/* + * Function declarations for things defined in this file. + */ + +static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); +static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, + const char *nsNameStr); +static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, + Method *mPtr, Tcl_Obj *namePtr, + Method **newMPtrPtr); +static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, + Method *mPtr, Tcl_Obj *namePtr); +static void DeletedDefineNamespace(ClientData clientData); +static void DeletedObjdefNamespace(ClientData clientData); +static void DeletedHelpersNamespace(ClientData clientData); +static int FinalizeAlloc(ClientData data[], + Tcl_Interp *interp, int result); +static int FinalizeNext(ClientData data[], + Tcl_Interp *interp, int result); +static int FinalizeObjectCall(ClientData data[], + Tcl_Interp *interp, int result); +static int InitFoundation(Tcl_Interp *interp); +static void KillFoundation(ClientData clientData, + Tcl_Interp *interp); +static void MyDeleted(ClientData clientData); +static void ObjectNamespaceDeleted(ClientData clientData); +static void ObjectRenamedTrace(ClientData clientData, + Tcl_Interp *interp, const char *oldName, + const char *newName, int flags); +static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static inline void SquelchCachedName(Object *oPtr); +static void SquelchedNsFirst(ClientData clientData); + +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, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int PrivateNRObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); + +/* + * Methods in the oo::object and oo::class classes. First, we define a helper + * macro that makes building the method type declaration structure a lot + * easier. No point in making life harder than it has to be! + * + * Note that the core methods don't need clone or free proc callbacks. + */ + +#define DCM(name,visibility,proc) \ + {name,visibility,\ + {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}} + +static const DeclaredClassMethod objMethods[] = { + DCM("destroy", 1, TclOO_Object_Destroy), + DCM("eval", 0, TclOO_Object_Eval), + DCM("unknown", 0, TclOO_Object_Unknown), + DCM("variable", 0, TclOO_Object_LinkVar), + DCM("varname", 0, TclOO_Object_VarName), + {NULL, 0, {0, NULL, NULL, NULL, NULL}} +}, clsMethods[] = { + DCM("create", 1, TclOO_Class_Create), + DCM("new", 1, TclOO_Class_New), + DCM("createWithNamespace", 0, TclOO_Class_CreateNs), + {NULL, 0, {0, NULL, NULL, NULL, NULL}} +}; + +/* + * And for the oo::class constructor... + */ + +static const Tcl_MethodType classConstructor = { + TCL_OO_METHOD_VERSION_CURRENT, + "oo::class constructor", + TclOO_Class_Constructor, NULL, NULL +}; + +/* + * Scripted parts of TclOO. First, the master script (cannot be outside this + * file). + */ + +static const char *initScript = +"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" +"namespace eval ::oo { variable version " TCLOO_VERSION " };" +"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +/* "tcl_findLibrary tcloo $oo::version $oo::version" */ +/* " tcloo.tcl OO_LIBRARY oo::library;"; */ + +/* + * The scripted part of the definitions of slots. + */ + +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;" +" }" +" }" +"}"; + +/* + * The actual definition of the variable holding the TclOO stub table. + */ + +MODULE_SCOPE const TclOOStubs tclOOStubs; + +/* + * Convenience macro for getting the foundation from an interpreter. + */ + +#define GetFoundation(interp) \ + ((Foundation *)((Interp *)(interp))->objectFoundation) + +/* + * Macros to make inspecting into the guts of an object cleaner. + * + * The ocPtr parameter (only in these macros) is assumed to work fine with + * either an oPtr or a classPtr. Note that the roots oo::object and oo::class + * have _both_ their object and class flags tagged with ROOT_OBJECT and + * ROOT_CLASS respectively. + */ + +#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) +#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) +#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) + +/* + * ---------------------------------------------------------------------- + * + * TclOOInit -- + * + * Called to initialise the OO system within an interpreter. + * + * Result: + * TCL_OK if the setup succeeded. Currently assumed to always work. + * + * Side effects: + * Creates namespaces, commands, several classes and a number of + * callbacks. Upon return, the OO system is ready for use. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOInit( + Tcl_Interp *interp) /* The interpreter to install into. */ +{ + /* + * Build the core of the OO system. + */ + + if (InitFoundation(interp) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Run our initialization script and, if that works, declare the package + * to be fully provided. + */ + + if (Tcl_Eval(interp, initScript) != TCL_OK) { + return TCL_ERROR; + } + + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, + (ClientData) &tclOOStubs); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetFoundation -- + * + * Get a reference to the OO core class system. + * + * ---------------------------------------------------------------------- + */ + +Foundation * +TclOOGetFoundation( + Tcl_Interp *interp) +{ + return GetFoundation(interp); +} + +/* + * ---------------------------------------------------------------------- + * + * InitFoundation -- + * + * Set up the core of the OO core class system. This is a structure + * holding references to the magical bits that need to be known about in + * other places, plus the oo::object and oo::class classes. + * + * ---------------------------------------------------------------------- + */ + +static int +InitFoundation( + Tcl_Interp *interp) +{ + static Tcl_ThreadDataKey tsdKey; + ThreadLocalData *tsdPtr = + Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); + Foundation *fPtr = ckalloc(sizeof(Foundation)); + Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_DString buffer; + Command *cmdPtr; + int i; + + /* + * Initialize the structure that holds the OO system core. This is + * attached to the interpreter via an assocData entry; not very efficient, + * but the best we can do without hacking the core more. + */ + + memset(fPtr, 0, sizeof(Foundation)); + ((Interp *) interp)->objectFoundation = fPtr; + fPtr->interp = interp; + fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL); + Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1); + fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr, + DeletedDefineNamespace); + fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr, + DeletedObjdefNamespace); + fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr, + DeletedHelpersNamespace); + fPtr->epoch = 0; + fPtr->tsdPtr = tsdPtr; + TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); + TclNewLiteralStringObj(fPtr->constructorName, "<constructor>"); + TclNewLiteralStringObj(fPtr->destructorName, "<destructor>"); + TclNewLiteralStringObj(fPtr->clonedName, "<cloned>"); + TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); + Tcl_IncrRefCount(fPtr->unknownMethodNameObj); + Tcl_IncrRefCount(fPtr->constructorName); + Tcl_IncrRefCount(fPtr->destructorName); + Tcl_IncrRefCount(fPtr->clonedName); + Tcl_IncrRefCount(fPtr->defineName); + Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", + TclOOUnknownDefinition, NULL, NULL); + TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); + Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); + Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); + + /* + * Create the subcommands in the oo::define and oo::objdefine spaces. + */ + + Tcl_DStringInit(&buffer); + for (i=0 ; defineCmds[i].name ; i++) { + TclDStringAppendLiteral(&buffer, "::oo::define::"); + Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL); + Tcl_DStringFree(&buffer); + } + for (i=0 ; objdefCmds[i].name ; i++) { + TclDStringAppendLiteral(&buffer, "::oo::objdefine::"); + Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL); + Tcl_DStringFree(&buffer); + } + + Tcl_CallWhenDeleted(interp, KillFoundation, NULL); + + /* + * Create the objects at the core of the object system. These need to be + * spliced manually. + */ + + fPtr->objectCls = AllocClass(interp, + AllocObject(interp, "::oo::object", NULL)); + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "::oo::class", NULL)); + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + AddRef(fPtr->objectCls->thisPtr); + AddRef(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. + */ + + 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); +} + +/* + * ---------------------------------------------------------------------- + * + * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace -- + * + * Simple helpers used to clear fields of the foundation when they no + * longer hold useful information. + * + * ---------------------------------------------------------------------- + */ + +static void +DeletedDefineNamespace( + ClientData clientData) +{ + Foundation *fPtr = clientData; + + fPtr->defineNs = NULL; +} + +static void +DeletedObjdefNamespace( + ClientData clientData) +{ + Foundation *fPtr = clientData; + + fPtr->objdefNs = NULL; +} + +static void +DeletedHelpersNamespace( + ClientData clientData) +{ + Foundation *fPtr = clientData; + + fPtr->helpersNs = NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * KillFoundation -- + * + * Delete those parts of the OO core that are not deleted automatically + * when the objects and classes themselves are destroyed. + * + * ---------------------------------------------------------------------- + */ + +static void +KillFoundation( + ClientData clientData, /* Pointer to the OO system foundation + * structure. */ + Tcl_Interp *interp) /* The interpreter containing the OO system + * foundation. */ +{ + Foundation *fPtr = GetFoundation(interp); + + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->objectCls); + TclDecrRefCount(fPtr->unknownMethodNameObj); + TclDecrRefCount(fPtr->constructorName); + TclDecrRefCount(fPtr->destructorName); + TclDecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->defineName); + ckfree(fPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * AllocObject -- + * + * Allocate an object of basic type. Does not splice the object into its + * class's instance list. + * + * ---------------------------------------------------------------------- + */ + +static Object * +AllocObject( + Tcl_Interp *interp, /* Interpreter within which to create the + * object. */ + const char *nameStr, /* The name of the object to create, or NULL + * if the OO system should pick the object + * name itself (equal to the namespace + * name). */ + 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 + * a namespace that already exists, the effect + * will be the same as if this was NULL. */ +{ + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + Command *cmdPtr; + CommandTrace *tracePtr; + int creationEpoch, ignored; + + oPtr = ckalloc(sizeof(Object)); + memset(oPtr, 0, sizeof(Object)); + + /* + * Every object has a namespace; make one. Note that this also normally + * computes the creation epoch value for the object, a sequence number + * that is unique to the object (and which allows us to manage method + * caching without comparing pointers). + * + * When creating a namespace, we first check to see if the caller + * specified the name for the namespace. If not, we generate namespace + * names using the epoch until such time as a new namespace is actually + * created. + */ + + if (nsNameStr != NULL) { + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + creationEpoch = ++fPtr->tsdPtr->nsCount; + goto configNamespace; + } + Tcl_ResetResult(interp); + } + + while (1) { + char objName[10 + TCL_INTEGER_SPACE]; + + sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + creationEpoch = fPtr->tsdPtr->nsCount; + break; + } + + /* + * Could not make that namespace, so we make another. But first we + * have to get rid of the error message from Tcl_CreateNamespace, + * since that's something that should not be exposed to the user. + */ + + Tcl_ResetResult(interp); + } + + /* + * Make the namespace know about the helper commands. This grants access + * to the [self] and [next] commands. + */ + + configNamespace: + if (fPtr->helpersNs != NULL) { + TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); + } + TclOOSetupVariableResolver(oPtr->namespacePtr); + + /* + * Suppress use of compiled versions of the commands in this object's + * namespace and its children; causes wrong behaviour without expensive + * recompilation. [Bug 2037727] + */ + + ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION; + + /* + * Set up a callback to get notification of the deletion of a namespace + * when enough of the namespace still remains to execute commands and + * access variables in it. [Bug 2950259] + */ + + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + + /* + * Fill in the rest of the non-zero/NULL parts of the structure. + */ + + oPtr->fPtr = fPtr; + oPtr->selfCls = fPtr->objectCls; + oPtr->creationEpoch = creationEpoch; + oPtr->refCount = 1; + oPtr->flags = USE_CLASS_CACHE; + + /* + * Finally, create the object commands and initialize the trace on the + * public command (so that the object structures are deleted when the + * command is deleted). + */ + + if (!nameStr) { + oPtr->command = Tcl_CreateObjCommand(interp, + oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); + } else if (nameStr[0] == ':' && nameStr[1] == ':') { + oPtr->command = Tcl_CreateObjCommand(interp, nameStr, + PublicObjectCmd, oPtr, NULL); + } else { + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetCurrentNamespace(interp)->fullName, -1); + TclDStringAppendLiteral(&buffer, "::"); + Tcl_DStringAppend(&buffer, nameStr, -1); + oPtr->command = Tcl_CreateObjCommand(interp, + Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); + Tcl_DStringFree(&buffer); + } + + /* + * Add the NRE command and trace directly. While this breaks a number of + * abstractions, it is faster and we're inside Tcl here so we're allowed. + */ + + cmdPtr = (Command *) oPtr->command; + cmdPtr->nreProc = PublicNRObjectCmd; + cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace)); + tracePtr->traceProc = ObjectRenamedTrace; + tracePtr->clientData = oPtr; + tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; + tracePtr->nextPtr = NULL; + tracePtr->refCount = 1; + + /* + * Access the namespace command table directly when creating "my" to avoid + * a bottleneck in string manipulation. Another abstraction-buster. + */ + + cmdPtr = ckalloc(sizeof(Command)); + memset(cmdPtr, 0, sizeof(Command)); + cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; + cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", + &ignored); + cmdPtr->refCount = 1; + cmdPtr->objProc = PrivateObjectCmd; + cmdPtr->deleteProc = MyDeleted; + cmdPtr->objClientData = cmdPtr->deleteData = oPtr; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = cmdPtr; + cmdPtr->nreProc = PrivateNRObjectCmd; + Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); + oPtr->myCommand = (Tcl_Command) cmdPtr; + + return oPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * SquelchCachedName -- + * + * Encapsulates how to throw away a cached object name. Called from + * object rename traces and at object destruction. + * + * ---------------------------------------------------------------------- + */ + +static inline void +SquelchCachedName( + Object *oPtr) +{ + if (oPtr->cachedNameObj) { + Tcl_DecrRefCount(oPtr->cachedNameObj); + oPtr->cachedNameObj = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * MyDeleted -- + * + * 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. + * + * ---------------------------------------------------------------------- + */ + +static void +MyDeleted( + ClientData clientData) /* Reference to the object whose [my] has been + * squelched. */ +{ + register Object *oPtr = clientData; + + oPtr->myCommand = NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * SquelchedNsFirst -- + * + * This callback is triggered when the object's namespace is deleted by + * any mechanism. It deletes the object's public command if it has not + * already been deleted, so ensuring that destructors get run at an + * appropriate time. [Bug 2950259] + * + * ---------------------------------------------------------------------- + */ + +static void +SquelchedNsFirst( + ClientData clientData) +{ + Object *oPtr = clientData; + + if (oPtr->command) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + } +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectRenamedTrace -- + * + * This callback is triggered when the object is deleted by any + * mechanism. It runs the destructors and arranges for the actual cleanup + * of the object's namespace, which in turn triggers cleansing of the + * object data structures. + * + * ---------------------------------------------------------------------- + */ + +static void +ObjectRenamedTrace( + ClientData clientData, /* The object being deleted. */ + Tcl_Interp *interp, /* The interpreter containing the object. */ + const char *oldName, /* What the object was (last) called. */ + const char *newName, /* Always NULL. */ + int flags) /* Why was the object deleted? */ +{ + Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; + + /* + * If this is a rename and not a delete of the object, we just flush the + * cache of the object name. + */ + + if (flags & TCL_TRACE_RENAME) { + SquelchCachedName(oPtr); + return; + } + + /* + * Oh dear, the object really is being deleted. Handle this by running the + * destructors and deleting the object's namespace, which in turn causes + * the real object structures to be deleted. + * + * Note that it is possible for the namespace to be deleted before the + * command. Because of that case, we must take care here to mark the + * command as being deleted so that if we return here we don't run into + * reentrancy problems. + * + * We also do not run destructors on the core class objects when the + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] + */ + + AddRef(oPtr); + AddRef(fPtr->classCls); + AddRef(fPtr->objectCls); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr); + oPtr->command = NULL; + + if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + int result; + Tcl_InterpState state; + + oPtr->flags |= DESTRUCTOR_CALLED; + if (contextPtr != NULL) { + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } + + /* + * OK, the destructor's been run. Time to splat the class data (if any) + * and nuke the namespace (which triggers the final crushing of the object + * structure itself). + * + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] + */ + + if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) + && !Deleted(fPtr->classCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } + + if (oPtr->classPtr != NULL) { + AddRef(oPtr->classPtr); + ReleaseClassContents(interp, oPtr); + } + + /* + * The namespace is only deleted if it hasn't already been deleted. [Bug + * 2950259] + */ + + if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + Tcl_DeleteNamespace(oPtr->namespacePtr); + } + if (oPtr->classPtr) { + DelRef(oPtr->classPtr); + } + DelRef(fPtr->classCls->thisPtr); + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->classCls); + DelRef(fPtr->objectCls); + DelRef(oPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * ReleaseClassContents -- + * + * Tear down the special class data structure, including deleting all + * dependent classes and objects. + * + * ---------------------------------------------------------------------- + */ + +static void +ReleaseClassContents( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Object *oPtr) /* The object representing the class. */ +{ + FOREACH_HASH_DECLS; + int i; + Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; + Object *instancePtr; + Foundation *fPtr = oPtr->fPtr; + + /* + * Sanity check! + */ + + if (!Deleted(oPtr)) { + if (IsRootClass(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::class"); + } else if (IsRootObject(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::object"); + } else { + Tcl_Panic("deleting class structure for non-deleted %s", + "general object"); + } + } + + /* + * Lock a number of dependent objects until we've stopped putting our + * fingers in them. + */ + + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + if (mixinSubclassPtr != NULL) { + AddRef(mixinSubclassPtr); + AddRef(mixinSubclassPtr->thisPtr); + } + } + FOREACH(subclassPtr, clsPtr->subclasses) { + if (subclassPtr != NULL && !IsRoot(subclassPtr)) { + AddRef(subclassPtr); + AddRef(subclassPtr->thisPtr); + } + } + if (!IsRootClass(oPtr)) { + FOREACH(instancePtr, clsPtr->instances) { + if (instancePtr != NULL && !IsRoot(instancePtr)) { + AddRef(instancePtr); + } + } + } + + /* + * Squelch classes that this class has been mixed into. + */ + + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + if (mixinSubclassPtr == NULL) { + continue; + } + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + DelRef(mixinSubclassPtr->thisPtr); + DelRef(mixinSubclassPtr); + } + if (clsPtr->mixinSubs.list != NULL) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; + clsPtr->mixinSubs.num = 0; + } + + /* + * Squelch subclasses of this class. + */ + + FOREACH(subclassPtr, clsPtr->subclasses) { + if (subclassPtr == NULL || IsRoot(subclassPtr)) { + continue; + } + if (!Deleted(subclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + } + DelRef(subclassPtr->thisPtr); + DelRef(subclassPtr); + } + if (clsPtr->subclasses.list != NULL) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.num = 0; + } + + /* + * Squelch instances of this class (includes objects we're mixed into). + */ + + if (!IsRootClass(oPtr)) { + FOREACH(instancePtr, clsPtr->instances) { + if (instancePtr == NULL || IsRoot(instancePtr)) { + continue; + } + if (!Deleted(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + } + DelRef(instancePtr); + } + } + if (clsPtr->instances.list != NULL) { + ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; + clsPtr->instances.num = 0; + } + + /* + * Special: We delete these after everything else. + */ + + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } + + /* + * Squelch method implementation chain caches. + */ + + if (clsPtr->constructorChainPtr) { + TclOODeleteChain(clsPtr->constructorChainPtr); + clsPtr->constructorChainPtr = NULL; + } + if (clsPtr->destructorChainPtr) { + TclOODeleteChain(clsPtr->destructorChainPtr); + clsPtr->destructorChainPtr = NULL; + } + if (clsPtr->classChainCache) { + CallChain *callPtr; + + FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) { + TclOODeleteChain(callPtr); + } + Tcl_DeleteHashTable(clsPtr->classChainCache); + ckfree(clsPtr->classChainCache); + clsPtr->classChainCache = NULL; + } + + /* + * Squelch our filter list. + */ + + if (clsPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, clsPtr->filters) { + TclDecrRefCount(filterObj); + } + ckfree(clsPtr->filters.list); + clsPtr->filters.num = 0; + } + + /* + * Squelch our metadata. + */ + + if (clsPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; + + FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { + metadataTypePtr->deleteProc(value); + } + Tcl_DeleteHashTable(clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); + clsPtr->metadataPtr = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectNamespaceDeleted -- + * + * Callback when the object's namespace is deleted. Used to clean up the + * data structures associated with the object. The complicated bit is + * that this can sometimes happen before the object's command is deleted + * (interpreter teardown is complex!) + * + * ---------------------------------------------------------------------- + */ + +static void +ObjectNamespaceDeleted( + ClientData clientData) /* Pointer to the class whose namespace is + * being deleted. */ +{ + Object *oPtr = clientData; + FOREACH_HASH_DECLS; + Class *clsPtr = oPtr->classPtr, *mixinPtr; + Method *mPtr; + Tcl_Obj *filterObj, *variableObj; + int i; + + /* + * Instruct everyone to no longer use any allocated fields of the object. + * Also delete the commands that refer to the object at this point (if + * they still exist) because otherwise their references to the object + * point into freed memory, allowing crashes. + */ + + if (oPtr->command) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + } + if (oPtr->myCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); + } + + /* + * Splice the object out of its context. After this, we must *not* call + * methods on the object. + */ + + if (!IsRootObject(oPtr)) { + TclOORemoveFromInstances(oPtr, oPtr->selfCls); + } + + FOREACH(mixinPtr, oPtr->mixins) { + TclOORemoveFromInstances(oPtr, mixinPtr); + } + if (i) { + ckfree(oPtr->mixins.list); + } + + FOREACH(filterObj, oPtr->filters) { + TclDecrRefCount(filterObj); + } + if (i) { + ckfree(oPtr->filters.list); + } + + if (oPtr->methodsPtr) { + FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(oPtr->methodsPtr); + ckfree(oPtr->methodsPtr); + } + + FOREACH(variableObj, oPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(oPtr->variables.list); + } + + if (oPtr->chainCache) { + TclOODeleteChainCache(oPtr->chainCache); + } + + SquelchCachedName(oPtr); + + if (oPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; + + FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { + metadataTypePtr->deleteProc(value); + } + Tcl_DeleteHashTable(oPtr->metadataPtr); + ckfree(oPtr->metadataPtr); + oPtr->metadataPtr = NULL; + } + + if (clsPtr != NULL) { + Class *superPtr; + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; + + if (clsPtr->metadataPtr != NULL) { + FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { + metadataTypePtr->deleteProc(value); + } + Tcl_DeleteHashTable(clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); + clsPtr->metadataPtr = NULL; + } + + FOREACH(filterObj, clsPtr->filters) { + TclDecrRefCount(filterObj); + } + if (i) { + ckfree(clsPtr->filters.list); + clsPtr->filters.num = 0; + } + FOREACH(mixinPtr, clsPtr->mixins) { + if (!Deleted(mixinPtr->thisPtr)) { + TclOORemoveFromMixinSubs(clsPtr, mixinPtr); + } + } + if (i) { + ckfree(clsPtr->mixins.list); + clsPtr->mixins.num = 0; + } + FOREACH(superPtr, clsPtr->superclasses) { + if (!Deleted(superPtr->thisPtr)) { + TclOORemoveFromSubclasses(clsPtr, superPtr); + } + } + if (i) { + ckfree(clsPtr->superclasses.list); + clsPtr->superclasses.num = 0; + } + if (clsPtr->subclasses.list) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.num = 0; + } + if (clsPtr->instances.list) { + ckfree(clsPtr->instances.list); + clsPtr->instances.num = 0; + } + if (clsPtr->mixinSubs.list) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.num = 0; + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + DelRef(clsPtr); + } + + /* + * Delete the object structure itself. + */ + + DelRef(oPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromInstances -- + * + * Utility function to remove an object from the list of instances within + * a class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOORemoveFromInstances( + Object *oPtr, /* The instance to remove. */ + Class *clsPtr) /* The class (possibly) containing the + * reference to the instance. */ +{ + int i; + Object *instPtr; + + FOREACH(instPtr, clsPtr->instances) { + if (oPtr == instPtr) { + goto removeInstance; + } + } + return; + + removeInstance: + if (Deleted(clsPtr->thisPtr)) { + clsPtr->instances.list[i] = NULL; + } else { + clsPtr->instances.num--; + if (i < clsPtr->instances.num) { + clsPtr->instances.list[i] = + clsPtr->instances.list[clsPtr->instances.num]; + } + clsPtr->instances.list[clsPtr->instances.num] = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOAddToInstances -- + * + * Utility function to add an object to the list of instances within a + * class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOAddToInstances( + Object *oPtr, /* The instance to add. */ + Class *clsPtr) /* The class to add the instance to. It is + * assumed that the class is not already + * present as an instance in the class. */ +{ + if (Deleted(clsPtr->thisPtr)) { + return; + } + if (clsPtr->instances.num >= clsPtr->instances.size) { + clsPtr->instances.size += ALLOC_CHUNK; + if (clsPtr->instances.size == ALLOC_CHUNK) { + clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK); + } else { + clsPtr->instances.list = ckrealloc(clsPtr->instances.list, + sizeof(Object *) * clsPtr->instances.size); + } + } + clsPtr->instances.list[clsPtr->instances.num++] = oPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromSubclasses -- + * + * Utility function to remove a class from the list of subclasses within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOORemoveFromSubclasses( + Class *subPtr, /* The subclass to remove. */ + Class *superPtr) /* The superclass to (possibly) remove the + * subclass reference from. */ +{ + int i; + Class *subclsPtr; + + FOREACH(subclsPtr, superPtr->subclasses) { + if (subPtr == subclsPtr) { + goto removeSubclass; + } + } + return; + + removeSubclass: + if (Deleted(superPtr->thisPtr)) { + superPtr->subclasses.list[i] = NULL; + } else { + superPtr->subclasses.num--; + if (i < superPtr->subclasses.num) { + superPtr->subclasses.list[i] = + superPtr->subclasses.list[superPtr->subclasses.num]; + } + superPtr->subclasses.list[superPtr->subclasses.num] = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOAddToSubclasses -- + * + * Utility function to add a class to the list of subclasses within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOAddToSubclasses( + Class *subPtr, /* The subclass to add. */ + Class *superPtr) /* The superclass to add the subclass to. It + * is assumed that the class is not already + * present as a subclass in the superclass. */ +{ + if (Deleted(superPtr->thisPtr)) { + return; + } + if (superPtr->subclasses.num >= superPtr->subclasses.size) { + superPtr->subclasses.size += ALLOC_CHUNK; + if (superPtr->subclasses.size == ALLOC_CHUNK) { + superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); + } else { + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, + sizeof(Class *) * superPtr->subclasses.size); + } + } + superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromMixinSubs -- + * + * Utility function to remove a class from the list of mixinSubs within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOORemoveFromMixinSubs( + Class *subPtr, /* The subclass to remove. */ + Class *superPtr) /* The superclass to (possibly) remove the + * subclass reference from. */ +{ + int i; + Class *subclsPtr; + + FOREACH(subclsPtr, superPtr->mixinSubs) { + if (subPtr == subclsPtr) { + goto removeSubclass; + } + } + return; + + removeSubclass: + if (Deleted(superPtr->thisPtr)) { + superPtr->mixinSubs.list[i] = NULL; + } else { + superPtr->mixinSubs.num--; + if (i < superPtr->mixinSubs.num) { + superPtr->mixinSubs.list[i] = + superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + } + superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOAddToMixinSubs -- + * + * Utility function to add a class to the list of mixinSubs within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOAddToMixinSubs( + Class *subPtr, /* The subclass to add. */ + Class *superPtr) /* The superclass to add the subclass to. It + * is assumed that the class is not already + * present as a subclass in the superclass. */ +{ + if (Deleted(superPtr->thisPtr)) { + return; + } + if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { + superPtr->mixinSubs.size += ALLOC_CHUNK; + if (superPtr->mixinSubs.size == ALLOC_CHUNK) { + superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); + } else { + superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list, + sizeof(Class *) * superPtr->mixinSubs.size); + } + } + superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * AllocClass -- + * + * Allocate a basic class. Does not splice the class object into its + * class's instance list. + * + * ---------------------------------------------------------------------- + */ + +static Class * +AllocClass( + Tcl_Interp *interp, /* Interpreter within which to allocate the + * class. */ + Object *useThisObj) /* Object that is to act as the class + * representation, or NULL if a new object + * (with automatic name) is to be used. */ +{ + Foundation *fPtr = GetFoundation(interp); + Class *clsPtr = ckalloc(sizeof(Class)); + + /* + * Make an object if we haven't been given one. + */ + + memset(clsPtr, 0, sizeof(Class)); + if (useThisObj == NULL) { + clsPtr->thisPtr = AllocObject(interp, NULL, NULL); + } else { + clsPtr->thisPtr = useThisObj; + } + + /* + * Configure the namespace path for the class's object. + */ + + 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 objects inherit from the class of classes unless they inherit + * from some subclass of it. Enforce this right now. + */ + + clsPtr->thisPtr->selfCls = fPtr->classCls; + + /* + * Classes are subclasses of oo::object, i.e. the objects they create are + * objects. + */ + + clsPtr->superclasses.num = 1; + clsPtr->superclasses.list = ckalloc(sizeof(Class *)); + clsPtr->superclasses.list[0] = fPtr->objectCls; + + /* + * Finish connecting the class structure to the object structure. + */ + + clsPtr->thisPtr->classPtr = clsPtr; + + /* + * That's the complicated bit. Now fill in the rest of the non-zero/NULL + * fields. + */ + + clsPtr->refCount = 1; + Tcl_InitObjHashTable(&clsPtr->classMethods); + return clsPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_NewObjectInstance -- + * + * Allocate a new instance of an object. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_NewObjectInstance( + Tcl_Interp *interp, /* Interpreter context. */ + Tcl_Class cls, /* Class to create an instance of. */ + const char *nameStr, /* Name of object to create, or NULL to ask + * the code to pick its own unique name. */ + const char *nsNameStr, /* Name of namespace to create inside object, + * or NULL to ask the code to pick its own + * unique name. */ + int objc, /* Number of arguments. Negative value means + * do not call constructor. */ + Tcl_Obj *const *objv, /* Argument list. */ + int skip) /* Number of arguments to _not_ pass to the + * constructor. */ +{ + register Class *classPtr = (Class *) cls; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + + /* + * Check if we're going to create an object over an existing command; + * that's not allowed. + */ + + if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, + TCL_NAMESPACE_ONLY)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } + + /* + * Run constructors, except when objc < 0 (a special flag case used for + * object cloning only). + */ + + if (objc >= 0) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + + if (contextPtr != NULL) { + int result; + Tcl_InterpState state; + + state = Tcl_SaveInterpState(interp, TCL_OK); + contextPtr->callPtr->flags |= CONSTRUCTOR; + contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp*) interp)->ensembleRewrite.sourceObjs) { + ((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1; + ((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1; + } + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, + objc, objv); + + /* + * It's an error if the object was whacked in the constructor. + * Force this if it isn't already an error (don't want to lose + * errors by accident...) [Bug 2903011] + */ + + if (result != TCL_ERROR && Deleted(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); + result = TCL_ERROR; + } + TclOODeleteContext(contextPtr); + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + + /* + * Take care to not delete a deleted object; that would be + * bad. [Bug 2903011] + */ + + if (!Deleted(oPtr)) { + Tcl_DeleteCommandFromToken(interp, oPtr->command); + } + return NULL; + } + Tcl_RestoreInterpState(interp, state); + } + } + + return (Tcl_Object) oPtr; +} + +int +TclNRNewObjectInstance( + Tcl_Interp *interp, /* Interpreter context. */ + Tcl_Class cls, /* Class to create an instance of. */ + const char *nameStr, /* Name of object to create, or NULL to ask + * the code to pick its own unique name. */ + const char *nsNameStr, /* Name of namespace to create inside object, + * or NULL to ask the code to pick its own + * unique name. */ + int objc, /* Number of arguments. Negative value means + * do not call constructor. */ + Tcl_Obj *const *objv, /* Argument list. */ + int skip, /* Number of arguments to _not_ pass to the + * constructor. */ + Tcl_Object *objectPtr) /* Place to write the object reference upon + * successful allocation. */ +{ + register Class *classPtr = (Class *) cls; + Foundation *fPtr = GetFoundation(interp); + CallContext *contextPtr; + Tcl_InterpState state; + Object *oPtr; + + /* + * Check if we're going to create an object over an existing command; + * that's not allowed. + */ + + if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, + TCL_NAMESPACE_ONLY)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return TCL_ERROR; + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } + + /* + * Run constructors, except when objc < 0 (a special flag case used for + * object cloning only). If there aren't any constructors, we do nothing. + */ + + if (objc < 0) { + *objectPtr = (Tcl_Object) oPtr; + return TCL_OK; + } + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + if (contextPtr == NULL) { + *objectPtr = (Tcl_Object) oPtr; + return TCL_OK; + } + + state = Tcl_SaveInterpState(interp, TCL_OK); + contextPtr->callPtr->flags |= CONSTRUCTOR; + contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp *) interp)->ensembleRewrite.sourceObjs) { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1; + ((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1; + } + + /* + * Fire off the constructors non-recursively. + */ + + AddRef(oPtr); + TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, + objectPtr); + TclPushTailcallPoint(interp); + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeAlloc( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallContext *contextPtr = data[0]; + Object *oPtr = data[1]; + Tcl_InterpState state = data[2]; + Tcl_Object *objectPtr = data[3]; + + /* + * It's an error if the object was whacked in the constructor. Force this + * if it isn't already an error (don't want to lose errors by accident...) + * [Bug 2903011] + */ + + if (result != TCL_ERROR && Deleted(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); + result = TCL_ERROR; + } + TclOODeleteContext(contextPtr); + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + + /* + * Take care to not delete a deleted object; that would be bad. [Bug + * 2903011] + */ + + if (!Deleted(oPtr)) { + Tcl_DeleteCommandFromToken(interp, oPtr->command); + } + DelRef(oPtr); + return TCL_ERROR; + } + Tcl_RestoreInterpState(interp, state); + *objectPtr = (Tcl_Object) oPtr; + DelRef(oPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_CopyObjectInstance -- + * + * Creates a copy of an object. Does not copy the backing namespace, + * since the correct way to do that (e.g., shallow/deep) depends on the + * object/class's own policies. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_CopyObjectInstance( + Tcl_Interp *interp, + Tcl_Object sourceObject, + const char *targetName, + const char *targetNamespaceName) +{ + Object *oPtr = (Object *) sourceObject, *o2Ptr; + FOREACH_HASH_DECLS; + Method *mPtr; + Class *mixinPtr; + CallContext *contextPtr; + Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + int i, result; + + /* + * Sanity check. + */ + + if (IsRootClass(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not clone the class of classes", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); + return NULL; + } + + /* + * Build the instance. Note that this does not run any constructors. + */ + + o2Ptr = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1, + NULL, -1); + if (o2Ptr == NULL) { + return NULL; + } + + /* + * Copy the object-local methods to the new object. + */ + + if (oPtr->methodsPtr) { + FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) { + if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + } + + /* + * Copy the object's mixin references to the new object. + */ + + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr != o2Ptr->selfCls) { + TclOORemoveFromInstances(o2Ptr, mixinPtr); + } + } + DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr != o2Ptr->selfCls) { + TclOOAddToInstances(o2Ptr, mixinPtr); + } + } + + /* + * Copy the object's filter list to the new object. + */ + + DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *); + FOREACH(filterObj, o2Ptr->filters) { + Tcl_IncrRefCount(filterObj); + } + + /* + * Copy the object's variable resolution list to the new object. + */ + + DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); + FOREACH(variableObj, o2Ptr->variables) { + Tcl_IncrRefCount(variableObj); + } + + /* + * 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 + * it the root of the object system or in the midst of processing a filter + * call. + */ + + o2Ptr->flags = oPtr->flags & ~( + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + + /* + * Copy the object's metadata. + */ + + if (oPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value, duplicate; + + FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { + if (metadataTypePtr->cloneProc == NULL) { + duplicate = value; + } else { + if (metadataTypePtr->cloneProc(interp, value, + &duplicate) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (duplicate != NULL) { + Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr, + duplicate); + } + } + } + + /* + * Copy the class, if present. Note that if there is a class present in + * the source object, there must also be one in the copy. + */ + + if (oPtr->classPtr != NULL) { + Class *clsPtr = oPtr->classPtr; + Class *cls2Ptr = o2Ptr->classPtr; + Class *superPtr; + + /* + * Copy the class flags across. + */ + + cls2Ptr->flags = clsPtr->flags; + + /* + * Ensure that the new class's superclass structure is the same as the + * old class's. + */ + + FOREACH(superPtr, cls2Ptr->superclasses) { + TclOORemoveFromSubclasses(cls2Ptr, superPtr); + } + if (cls2Ptr->superclasses.num) { + cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, + sizeof(Class *) * clsPtr->superclasses.num); + } else { + cls2Ptr->superclasses.list = + ckalloc(sizeof(Class *) * clsPtr->superclasses.num); + } + memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, + sizeof(Class *) * clsPtr->superclasses.num); + cls2Ptr->superclasses.num = clsPtr->superclasses.num; + FOREACH(superPtr, cls2Ptr->superclasses) { + TclOOAddToSubclasses(cls2Ptr, superPtr); + } + + /* + * Duplicate the source class's filters. + */ + + DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *); + FOREACH(filterObj, cls2Ptr->filters) { + Tcl_IncrRefCount(filterObj); + } + + /* + * Copy the source class's variable resolution list. + */ + + DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); + FOREACH(variableObj, cls2Ptr->variables) { + Tcl_IncrRefCount(variableObj); + } + + /* + * Duplicate the source class's mixins (which cannot be circular + * references to the duplicate). + */ + + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); + } + if (cls2Ptr->mixins.num != 0) { + ckfree(clsPtr->mixins.list); + } + DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOOAddToMixinSubs(cls2Ptr, mixinPtr); + } + + /* + * Duplicate the source class's methods, constructor and destructor. + */ + + FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) { + if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr, + NULL) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (clsPtr->constructorPtr) { + if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr, + NULL, &cls2Ptr->constructorPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (clsPtr->destructorPtr) { + if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL, + &cls2Ptr->destructorPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + + /* + * Duplicate the class's metadata. + */ + + if (clsPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value, duplicate; + + FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { + if (metadataTypePtr->cloneProc == NULL) { + duplicate = value; + } else { + if (metadataTypePtr->cloneProc(interp, value, + &duplicate) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (duplicate != NULL) { + Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr, + duplicate); + } + } + } + } + + TclResetRewriteEnsemble(interp, 1); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + if (contextPtr) { + args[0] = TclOOObjectName(interp, o2Ptr); + args[1] = oPtr->fPtr->clonedName; + args[2] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3, + args); + TclDecrRefCount(args[0]); + TclDecrRefCount(args[1]); + TclDecrRefCount(args[2]); + TclOODeleteContext(contextPtr); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (while performing post-copy callback)"); + } + if (result != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + + return (Tcl_Object) o2Ptr; +} + +/* + * ---------------------------------------------------------------------- + * + * CloneObjectMethod, CloneClassMethod -- + * + * Helper functions used for cloning methods. They work identically to + * each other, except for the difference between them in how they + * register the cloned method on a successful clone. + * + * ---------------------------------------------------------------------- + */ + +static int +CloneObjectMethod( + Tcl_Interp *interp, + Object *oPtr, + Method *mPtr, + Tcl_Obj *namePtr) +{ + if (mPtr->typePtr == NULL) { + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, + &newClientData) != TCL_OK) { + return TCL_ERROR; + } + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); + } else { + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); + } + return TCL_OK; +} + +static int +CloneClassMethod( + Tcl_Interp *interp, + Class *clsPtr, + Method *mPtr, + Tcl_Obj *namePtr, + Method **m2PtrPtr) +{ + Method *m2Ptr; + + if (mPtr->typePtr == NULL) { + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, + &newClientData) != TCL_OK) { + return TCL_ERROR; + } + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + newClientData); + } else { + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + mPtr->clientData); + } + if (m2PtrPtr != NULL) { + *m2PtrPtr = m2Ptr; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata, + * Tcl_ObjectSetMetadata -- + * + * Metadata management API. The metadata system allows code in extensions + * to attach arbitrary non-NULL pointers to objects and classes without + * the different things that might be interested being able to interfere + * with each other. Apart from non-NULL-ness, these routines attach no + * interpretation to the meaning of the metadata pointers. + * + * The Tcl_*GetMetadata routines get the metadata pointer attached that + * has been related with a particular type, or NULL if no metadata + * associated with the given type has been attached. + * + * The Tcl_*SetMetadata routines set or delete the metadata pointer that + * is related to a particular type. The value associated with the type is + * deleted (if present; no-op otherwise) if the value is NULL, and + * attached (replacing the previous value, which is deleted if present) + * otherwise. This means it is impossible to attach a NULL value for any + * metadata type. + * + * ---------------------------------------------------------------------- + */ + +ClientData +Tcl_ClassGetMetadata( + Tcl_Class clazz, + const Tcl_ObjectMetadataType *typePtr) +{ + Class *clsPtr = (Class *) clazz; + Tcl_HashEntry *hPtr; + + /* + * If there's no metadata store attached, the type in question has + * definitely not been attached either! + */ + + if (clsPtr->metadataPtr == NULL) { + return NULL; + } + + /* + * There is a metadata store, so look in it for the given type. + */ + + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); + + /* + * Return the metadata value if we found it, otherwise NULL. + */ + + if (hPtr == NULL) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +void +Tcl_ClassSetMetadata( + Tcl_Class clazz, + const Tcl_ObjectMetadataType *typePtr, + ClientData metadata) +{ + Class *clsPtr = (Class *) clazz; + Tcl_HashEntry *hPtr; + int isNew; + + /* + * Attach the metadata store if not done already. + */ + + if (clsPtr->metadataPtr == NULL) { + if (metadata == NULL) { + return; + } + clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); + } + + /* + * If the metadata is NULL, we're deleting the metadata for the type. + */ + + if (metadata == NULL) { + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); + if (hPtr != NULL) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + return; + } + + /* + * Otherwise we're attaching the metadata. Note that if there was already + * some metadata attached of this type, we delete that first. + */ + + hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew); + if (!isNew) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + } + Tcl_SetHashValue(hPtr, metadata); +} + +ClientData +Tcl_ObjectGetMetadata( + Tcl_Object object, + const Tcl_ObjectMetadataType *typePtr) +{ + Object *oPtr = (Object *) object; + Tcl_HashEntry *hPtr; + + /* + * If there's no metadata store attached, the type in question has + * definitely not been attached either! + */ + + if (oPtr->metadataPtr == NULL) { + return NULL; + } + + /* + * There is a metadata store, so look in it for the given type. + */ + + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); + + /* + * Return the metadata value if we found it, otherwise NULL. + */ + + if (hPtr == NULL) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +void +Tcl_ObjectSetMetadata( + Tcl_Object object, + const Tcl_ObjectMetadataType *typePtr, + ClientData metadata) +{ + Object *oPtr = (Object *) object; + Tcl_HashEntry *hPtr; + int isNew; + + /* + * Attach the metadata store if not done already. + */ + + if (oPtr->metadataPtr == NULL) { + if (metadata == NULL) { + return; + } + oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); + } + + /* + * If the metadata is NULL, we're deleting the metadata for the type. + */ + + if (metadata == NULL) { + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); + if (hPtr != NULL) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + return; + } + + /* + * Otherwise we're attaching the metadata. Note that if there was already + * some metadata attached of this type, we delete that first. + */ + + hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew); + if (!isNew) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + } + Tcl_SetHashValue(hPtr, metadata); +} + +/* + * ---------------------------------------------------------------------- + * + * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- + * + * Main entry point for object invokations. The Public* and Private* + * wrapper functions (implementations of both object instance commands + * and [my]) are just thin wrappers round the main TclOOObjectCmdCore + * function. Note that the core is function is NRE-aware. + * + * ---------------------------------------------------------------------- + */ + +static int +PublicObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv); +} + +static int +PublicNRObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD, + NULL); +} + +static int +PrivateObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv); +} + +static int +PrivateNRObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL); +} + +int +TclOOInvokeObject( + Tcl_Interp *interp, /* Interpreter for commands, variables, + * results, error reporting, etc. */ + Tcl_Object object, /* The object to invoke. */ + Tcl_Class startCls, /* Where in the class chain to start the + * invoke from, or NULL to traverse the whole + * chain including filters. */ + int publicPrivate, /* Whether this is an invoke from a public + * context (PUBLIC_METHOD), a private context + * (PRIVATE_METHOD), or a *really* private + * context (any other value; conventionally + * 0). */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Array of argument objects. It is assumed + * that the name of the method to invoke will + * be at index 1. */ +{ + switch (publicPrivate) { + case PUBLIC_METHOD: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, + PUBLIC_METHOD, (Class *) startCls); + case PRIVATE_METHOD: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, + PRIVATE_METHOD, (Class *) startCls); + default: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0, + (Class *) startCls); + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectCmdCore, FinalizeObjectCall -- + * + * Main function for object invokations. Does call chain creation, + * management and invokation. The function FinalizeObjectCall exists to + * clean up after the non-recursive processing of TclOOObjectCmdCore. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOObjectCmdCore( + Object *oPtr, /* The object being invoked. */ + Tcl_Interp *interp, /* The interpreter containing the object. */ + int objc, /* How many arguments are being passed in. */ + Tcl_Obj *const *objv, /* The array of arguments. */ + int flags, /* Whether this is an invokation through the + * public or the private command interface. */ + Class *startCls) /* Where to start in the call chain, or NULL + * if we are to start at the front with + * filters and the object's methods (which is + * the normal case). */ +{ + CallContext *contextPtr; + Tcl_Obj *methodNamePtr; + int result; + + /* + * If we've no method name, throw this directly into the unknown + * processing. + */ + + if (objc < 2) { + flags |= FORCE_UNKNOWN; + methodNamePtr = NULL; + goto noMapping; + } + + /* + * Give plugged in code a chance to remap the method name. + */ + + methodNamePtr = objv[1]; + if (oPtr->mapMethodNameProc != NULL) { + register Class **startClsPtr = &startCls; + Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr); + + result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, + (Tcl_Class *) startClsPtr, mappedMethodName); + if (result != TCL_OK) { + TclDecrRefCount(mappedMethodName); + if (result == TCL_BREAK) { + goto noMapping; + } else if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (while mapping method name)"); + } + return result; + } + + /* + * Get the call chain for the remapped name. + */ + + Tcl_IncrRefCount(mappedMethodName); + contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, + flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + TclDecrRefCount(mappedMethodName); + if (contextPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", + TclGetString(methodNamePtr), NULL); + return TCL_ERROR; + } + } else { + /* + * Get the call chain. + */ + + noMapping: + contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, + flags | (oPtr->flags & FILTER_HANDLING), NULL); + if (contextPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(methodNamePtr), NULL); + return TCL_ERROR; + } + } + + /* + * Check to see if we need to apply magical tricks to start part way + * through the call chain. + */ + + if (startCls != NULL) { + for (; contextPtr->index < contextPtr->callPtr->numChain; + contextPtr->index++) { + register struct MInvoke *miPtr = + &contextPtr->callPtr->chain[contextPtr->index]; + + if (miPtr->isFilter) { + continue; + } + if (miPtr->mPtr->declaringClassPtr == startCls) { + break; + } + } + if (contextPtr->index >= contextPtr->callPtr->numChain) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no valid method implementation", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(methodNamePtr), NULL); + TclOODeleteContext(contextPtr); + return TCL_ERROR; + } + } + + /* + * Invoke the call chain, locking the object structure against deletion + * for the duration. + */ + + TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL); + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeObjectCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + /* + * Dispose of the call chain, which drops the lock on the object's + * structure. + */ + + TclOODeleteContext(data[0]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext -- + * + * Invokes the next stage of the call chain described in an object + * context. This is the core of the implementation of the [next] command. + * Does not do management of the call-frame stack. Available in public + * (standard API) and private (NRE-aware) forms. FinalizeNext is a + * private function used to clean up in the NRE case. + * + * ---------------------------------------------------------------------- + */ + +int +Tcl_ObjectContextInvokeNext( + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv, + int skip) +{ + CallContext *contextPtr = (CallContext *) context; + int savedIndex = contextPtr->index; + int savedSkip = contextPtr->skip; + int result; + + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless the + * interpreter is being torn down, in which case we might be getting + * here because of methods/destructors doing a [next] (or equivalent) + * unexpectedly. + */ + + const char *methodType; + + if (Tcl_InterpDeleted(interp)) { + return TCL_OK; + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + return TCL_ERROR; + } + + /* + * Advance to the next method implementation in the chain in the method + * call context while we process the body. However, need to adjust the + * argument-skip control because we're guaranteed to have a single prefix + * arg (i.e., 'next') and not the variable amount that can happen because + * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * (i.e., '$cls new' and '$cls create obj') and destructors (no args at + * all) come through the same code. + */ + + contextPtr->index++; + contextPtr->skip = skip; + + /* + * Invoke the (advanced) method call context in the caller context. + */ + + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, + objv); + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = savedIndex; + contextPtr->skip = savedSkip; + + return result; +} + +int +TclNRObjectContextInvokeNext( + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv, + int skip) +{ + register CallContext *contextPtr = (CallContext *) context; + + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless the + * interpreter is being torn down, in which case we might be getting + * here because of methods/destructors doing a [next] (or equivalent) + * unexpectedly. + */ + + const char *methodType; + + if (Tcl_InterpDeleted(interp)) { + return TCL_OK; + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + return TCL_ERROR; + } + + /* + * Advance to the next method implementation in the chain in the method + * call context while we process the body. However, need to adjust the + * argument-skip control because we're guaranteed to have a single prefix + * arg (i.e., 'next') and not the variable amount that can happen because + * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * (i.e., '$cls new' and '$cls create obj') and destructors (no args at + * all) come through the same code. + */ + + TclNRAddCallback(interp, FinalizeNext, contextPtr, + INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL); + contextPtr->index++; + contextPtr->skip = skip; + + /* + * Invoke the (advanced) method call context in the caller context. + */ + + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeNext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallContext *contextPtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[1]); + contextPtr->skip = PTR2INT(data[2]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_GetObjectFromObj -- + * + * Utility function to get an object from a Tcl_Obj containing its name. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_GetObjectFromObj( + Tcl_Interp *interp, /* Interpreter in which to locate the object. + * Will have an error message placed in it if + * the name does not refer to an object. */ + Tcl_Obj *objPtr) /* The name of the object to look up, which is + * exactly the name of its public command. */ +{ + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); + + if (cmdPtr == NULL) { + goto notAnObject; + } + if (cmdPtr->objProc != PublicObjectCmd) { + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + goto notAnObject; + } + } + return cmdPtr->objClientData; + + notAnObject: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to an object", TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), + NULL); + return NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOIsReachable -- + * + * Utility function that tests whether a class is a subclass (whether + * directly or indirectly) of another class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOIsReachable( + Class *targetPtr, + Class *startPtr) +{ + int i; + Class *superPtr; + + tailRecurse: + if (startPtr == targetPtr) { + return 1; + } + if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) { + startPtr = startPtr->superclasses.list[0]; + goto tailRecurse; + } + FOREACH(superPtr, startPtr->superclasses) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + FOREACH(superPtr, startPtr->mixins) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + return 0; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectName, Tcl_GetObjectName -- + * + * Utility function that returns the name of the object. Note that this + * simplifies cache management by keeping the code to do it in one place + * and not sprayed all over. The value returned always has a reference + * count of at least one. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOOObjectName( + Tcl_Interp *interp, + Object *oPtr) +{ + Tcl_Obj *namePtr; + + if (oPtr->cachedNameObj) { + return oPtr->cachedNameObj; + } + namePtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->command, namePtr); + Tcl_IncrRefCount(namePtr); + oPtr->cachedNameObj = namePtr; + return namePtr; +} + +Tcl_Obj * +Tcl_GetObjectName( + Tcl_Interp *interp, + Tcl_Object object) +{ + return TclOOObjectName(interp, (Object *) object); +} + +/* + * ---------------------------------------------------------------------- + * + * assorted trivial 'getter' functions + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_ObjectContextMethod( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr; +} + +int +Tcl_ObjectContextIsFiltering( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return contextPtr->callPtr->chain[contextPtr->index].isFilter; +} + +Tcl_Object +Tcl_ObjectContextObject( + Tcl_ObjectContext context) +{ + return (Tcl_Object) ((CallContext *)context)->oPtr; +} + +int +Tcl_ObjectContextSkippedArgs( + Tcl_ObjectContext context) +{ + return ((CallContext *)context)->skip; +} + +Tcl_Namespace * +Tcl_GetObjectNamespace( + Tcl_Object object) +{ + return ((Object *)object)->namespacePtr; +} + +Tcl_Command +Tcl_GetObjectCommand( + Tcl_Object object) +{ + return ((Object *)object)->command; +} + +Tcl_Class +Tcl_GetObjectAsClass( + Tcl_Object object) +{ + return (Tcl_Class) ((Object *)object)->classPtr; +} + +int +Tcl_ObjectDeleted( + Tcl_Object object) +{ + return Deleted(object) ? 1 : 0; +} + +Tcl_Object +Tcl_GetClassAsObject( + Tcl_Class clazz) +{ + return (Tcl_Object) ((Class *)clazz)->thisPtr; +} + +Tcl_ObjectMapMethodNameProc * +Tcl_ObjectGetMethodNameMapper( + Tcl_Object object) +{ + return ((Object *) object)->mapMethodNameProc; +} + +void +Tcl_ObjectSetMethodNameMapper( + Tcl_Object object, + Tcl_ObjectMapMethodNameProc *mapMethodNameProc) +{ + ((Object *) object)->mapMethodNameProc = mapMethodNameProc; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |