diff options
Diffstat (limited to 'generic/tclOO.c')
| -rw-r--r-- | generic/tclOO.c | 2977 |
1 files changed, 0 insertions, 2977 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c deleted file mode 100644 index de00733..0000000 --- a/generic/tclOO.c +++ /dev/null @@ -1,2977 +0,0 @@ -/* - * 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: - */ |