--- /dev/null
+/*
+ * tclOO.c --
+ *
+ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2005-2012 by Donal K. Fellows
+ * Copyright (c) 2017 by Nathan Coulter
+ *
+ * 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 Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
+ Namespace *nsPtr, 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 Tcl_NRPostProc FinalizeAlloc;
+static Tcl_NRPostProc FinalizeNext;
+static Tcl_NRPostProc FinalizeObjectCall;
+static void initClassPath(Tcl_Interp * interp, Class *clsPtr);
+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 inline void SquelchCachedName(Object *oPtr);
+
+static int PublicObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PublicNRObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateNRObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static void RemoveClass(Class ** list, int num, int idx);
+static void RemoveObject(Object ** list, int num, int idx);
+
+/*
+ * 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 main 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 Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING)
+#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
+
+#define RemoveItem(type, lst, i) \
+ do { \
+ Remove ## type ((lst).list, (lst).num, i); \
+ (lst).num--; \
+ } while (0)
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetFoundation --
+ *
+ * Get a reference to the OO core class system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Foundation *
+TclOOGetFoundation(
+ Tcl_Interp *interp)
+{
+ return GetFoundation(interp);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+
+ Class fakeCls;
+ Object fakeObject;
+
+ 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.
+ */
+
+ /*
+ * Stand up a phony class for bootstrapping.
+ */
+
+ fPtr->objectCls = &fakeCls;
+
+ /*
+ * Referenced in TclOOAllocClass to increment the refCount.
+ */
+
+ fakeCls.thisPtr = &fakeObject;
+
+ fPtr->objectCls = TclOOAllocClass(interp,
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
+ /*
+ * Corresponding TclOODecrRefCount in KillFoudation.
+ */
+
+ AddRef(fPtr->objectCls->thisPtr);
+
+ /*
+ * This is why it is unnecessary in this routine to replace the
+ * incremented reference count of fPtr->objectCls that was swallowed by
+ * fakeObject.
+ */
+
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree(fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+
+ /*
+ * Special initialization for the primordial objects.
+ */
+
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
+
+ fPtr->classCls = TclOOAllocClass(interp,
+ AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
+
+ /*
+ * Corresponding TclOODecrRefCount in KillFoudation.
+ */
+
+ AddRef(fPtr->classCls->thisPtr);
+
+ /*
+ * Increment reference counts for each reference because these
+ * relationships can be dynamically changed.
+ *
+ * Corresponding TclOODecrRefCount for all incremented refcounts is in
+ * KillFoundation.
+ */
+
+ /*
+ * Rewire bootstrapped objects.
+ */
+
+ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+ AddRef(fPtr->classCls->thisPtr);
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ AddRef(fPtr->classCls->thisPtr);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+
+ fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ fPtr->classCls->flags |= ROOT_CLASS;
+
+ /*
+ * Standard initialization for new Objects.
+ */
+
+ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
+
+ /*
+ * Basic method declarations for the core classes.
+ */
+
+ for (i = 0 ; objMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
+ }
+ for (i = 0 ; clsMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
+ }
+
+ /*
+ * Create the default <cloned> method implementation, used when 'oo::copy'
+ * is called to finish the copying of one object to another.
+ */
+
+ 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);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+
+ TclDecrRefCount(fPtr->unknownMethodNameObj);
+ TclDecrRefCount(fPtr->constructorName);
+ TclDecrRefCount(fPtr->destructorName);
+ TclDecrRefCount(fPtr->clonedName);
+ TclDecrRefCount(fPtr->defineName);
+ TclOODecrRefCount(fPtr->objectCls->thisPtr);
+ TclOODecrRefCount(fPtr->classCls->thisPtr);
+
+ ckfree(fPtr);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocObject --
+ *
+ * Allocate an object of basic type. Does not splice the object into its
+ * class's instance list. The caller must set the classPtr on the object
+ * to either a class or NULL, call TclOOAddToInstances to add the object
+ * to the class's instance list, and if the object itself is a class, use
+ * call TclOOAddToSubclasses() to add it to the right class's list of
+ * subclasses.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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). */
+ Namespace *nsPtr, /* The namespace to create the object in,
+ or NULL if *nameStr is NULL */
+ const char *nsNameStr) /* The name of the namespace to create, or
+ * NULL if the OO system should pick a unique
+ * name itself. If this is non-NULL but names
+ * 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;
+
+ 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, NULL);
+ 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, NULL);
+ 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);
+ }
+
+ configNamespace:
+ ((Namespace *) oPtr->namespacePtr)->refCount++;
+
+ /*
+ * Make the namespace know about the helper commands. This grants access
+ * to the [self] and [next] commands.
+ */
+
+ 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 = ObjectNamespaceDeleted;
+
+ /*
+ * Fill in the rest of the non-zero/NULL parts of the structure.
+ */
+
+ oPtr->fPtr = fPtr;
+ oPtr->creationEpoch = creationEpoch;
+
+ /*
+ * An object starts life with a refCount of 2 to mark the two stages of
+ * destruction it occur: A call to ObjectRenamedTrace(), and a call to
+ * ObjectNamespaceDeleted().
+ */
+ oPtr->refCount = 2;
+
+ 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) {
+ nameStr = oPtr->namespacePtr->name;
+ nsPtr = (Namespace *)oPtr->namespacePtr;
+ if (nsPtr->parentPtr != NULL) {
+ nsPtr = nsPtr->parentPtr;
+ }
+
+ }
+ oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
+ (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
+
+ /*
+ * 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;
+
+ oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
+ PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ return oPtr;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+ }
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ Object *oPtr = clientData;
+
+ oPtr->myCommand = NULL;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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, /* What it's getting renamed to. (unused) */
+ int flags) /* Why was the object deleted? */
+{
+ Object *oPtr = clientData;
+ /*
+ * If this is a rename and not a delete of the object, we just flush the
+ * cache of the object name.
+ */
+
+ if (flags & TCL_TRACE_RENAME) {
+ SquelchCachedName(oPtr);
+ return;
+ }
+
+ /*
+ * The namespace is only deleted if it hasn't already been deleted. [Bug
+ * 2950259].
+ */
+
+ if (!Destructing(oPtr)) {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ }
+ oPtr->command = NULL;
+ TclOODecrRefCount(oPtr);
+ return;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteDescendants --
+ *
+ * Delete all descendants of a particular class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteDescendants(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
+{
+ Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
+ Object *instancePtr;
+
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
+
+ if (clsPtr->mixinSubs.num > 0) {
+ while (clsPtr->mixinSubs.num > 0) {
+ mixinSubclassPtr =
+ clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
+
+ /*
+ * This condition also covers the case where mixinSubclassPtr ==
+ * clsPtr
+ */
+
+ if (!Destructing(mixinSubclassPtr->thisPtr)
+ && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
+ }
+ }
+ if (clsPtr->mixinSubs.size > 0) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.size = 0;
+ }
+ /*
+ * Squelch subclasses of this class.
+ */
+
+ if (clsPtr->subclasses.num > 0) {
+ while (clsPtr->subclasses.num > 0) {
+ subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
+ if (!Destructing(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
+ && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
+ Tcl_DeleteCommandFromToken(interp,
+ subclassPtr->thisPtr->command);
+ }
+ TclOORemoveFromSubclasses(subclassPtr, clsPtr);
+ }
+ }
+ if (clsPtr->subclasses.size > 0) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.size = 0;
+ }
+
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (clsPtr->instances.num > 0) {
+ while (clsPtr->instances.num > 0) {
+ instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
+
+ /*
+ * This condition also covers the case where instancePtr == oPtr
+ */
+
+ if (!Destructing(instancePtr) && !IsRoot(instancePtr) &&
+ !(instancePtr->flags & DONT_DELETE)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ }
+ TclOORemoveFromInstances(instancePtr, clsPtr);
+ }
+ }
+ if (clsPtr->instances.size > 0) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.size = 0;
+ }
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOReleaseClassContents --
+ *
+ * Tear down the special class data structure, including deleting all
+ * dependent classes and objects.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOReleaseClassContents(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
+{
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
+ Method *mPtr;
+ Foundation *fPtr = oPtr->fPtr;
+ Tcl_Obj *variableObj;
+
+ /*
+ * Sanity check!
+ */
+
+ if (!Destructing(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");
+ }
+ }
+
+ /*
+ * 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.list = NULL;
+ 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;
+ }
+
+ if (clsPtr->mixins.num) {
+ FOREACH(tmpClsPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
+ TclOODecrRefCount(tmpClsPtr->thisPtr);
+ }
+ ckfree(clsPtr->mixins.list);
+ clsPtr->mixins.list = NULL;
+ clsPtr->mixins.num = 0;
+ }
+
+ if (clsPtr->superclasses.num > 0) {
+ FOREACH(tmpClsPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
+ TclOODecrRefCount(tmpClsPtr->thisPtr);
+ }
+ ckfree(clsPtr->superclasses.list);
+ clsPtr->superclasses.num = 0;
+ clsPtr->superclasses.list = NULL;
+ }
+
+ 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);
+ }
+
+ if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
+ }
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+ Foundation *fPtr = oPtr->fPtr;
+ FOREACH_HASH_DECLS;
+ Class *mixinPtr;
+ Method *mPtr;
+ Tcl_Obj *filterObj, *variableObj;
+ Tcl_Interp *interp = oPtr->fPtr->interp;
+ int i;
+
+ if (Destructing(oPtr)) {
+ /*
+ * TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
+ * this guard could be removed.
+ */
+ return;
+ }
+
+ /*
+ * One rule for the teardown routines is that if an object is in the
+ * process of being deleted, nothing else may modify its bookeeping
+ * records. This is the flag that
+ */
+ oPtr->flags |= OBJECT_DESTRUCTING;
+
+ /*
+ * Let the dominoes fall!
+ */
+
+ if (oPtr->classPtr) {
+ TclOODeleteDescendants(interp, oPtr);
+ }
+
+ /*
+ * We 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]
+ */
+
+ if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
+ 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);
+ }
+ }
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ * Also delete the command that refers to the object at this point (if it
+ * still exists) because otherwise its pointer to the object points into
+ * freed memory.
+ */
+
+ if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
+ /*
+ * Something has already started the command deletion process. We can
+ * go ahead and clean up the the namespace,
+ */
+ } else {
+ /*
+ * The namespace must have been deleted directly. Delete the command
+ * as well.
+ */
+
+ 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.
+ */
+
+ /* TODO: Should this be protected with a !IsRoot() condition? */
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+
+ if (oPtr->mixins.num > 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
+ }
+ if (oPtr->mixins.list != NULL) {
+ 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;
+ }
+
+ /*
+ * Because an object can be a class that is an instance of itself, the
+ * class object's class structure should only be cleaned after most of
+ * the cleanup on the object is done.
+ *
+ * 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 (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
+ && !Tcl_InterpDeleted(interp)) {
+
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
+ }
+
+ if (oPtr->classPtr != NULL) {
+ TclOOReleaseClassContents(interp, oPtr);
+ }
+
+ /*
+ * Delete the object structure itself.
+ */
+
+ TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
+ oPtr->namespacePtr = NULL;
+ TclOODecrRefCount(oPtr->selfCls->thisPtr);
+ oPtr->selfCls = NULL;
+ TclOODecrRefCount(oPtr);
+ return;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODecrRef --
+ *
+ * Decrement the refcount of an object and deallocate storage then object
+ * is no longer referenced. Returns 1 if storage was deallocated, and 0
+ * otherwise.
+ *
+ * ----------------------------------------------------------------------
+ */
+int TclOODecrRefCount(Object *oPtr) {
+ if (oPtr->refCount-- <= 1) {
+ if (oPtr->classPtr != NULL) {
+ ckfree(oPtr->classPtr);
+ }
+ ckfree(oPtr);
+ return 1;
+ }
+ return 0;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectDestroyed --
+ *
+ * Returns TCL_OK if an object is entirely deleted, i.e. the destruction
+ * sequence has completed.
+ *
+ * ----------------------------------------------------------------------
+ */
+int TclOOObjectDestroyed(Object *oPtr) {
+ return (oPtr->namespacePtr == NULL);
+}
+\f
+/*
+ * Setting the "empty" location to NULL makes debugging a little easier.
+ */
+
+#define REMOVEBODY { \
+ for (; idx < num - 1; idx++) { \
+ list[idx] = list[idx + 1]; \
+ } \
+ list[idx] = NULL; \
+ return; \
+}
+void RemoveClass(Class **list, int num, int idx) REMOVEBODY
+\f
+void RemoveObject(Object **list, int num, int idx) REMOVEBODY
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromInstances --
+ *
+ * Utility function to remove an object from the list of instances within
+ * a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOORemoveFromInstances(
+ Object *oPtr, /* The instance to remove. */
+ Class *clsPtr) /* The class (possibly) containing the
+ * reference to the instance. */
+{
+ int i, res = 0;
+ Object *instPtr;
+
+ FOREACH(instPtr, clsPtr->instances) {
+ if (oPtr == instPtr) {
+ RemoveItem(Object, clsPtr->instances, i);
+ TclOODecrRefCount(oPtr);
+ res++;
+ break;
+ }
+ }
+ return res;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 (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;
+ AddRef(oPtr);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromMixins --
+ *
+ * Utility function to remove a class from the list of mixins within an
+ * object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOORemoveFromMixins(
+ Class *mixinPtr, /* The mixin to remove. */
+ Object *oPtr) /* The object (possibly) containing the
+ * reference to the mixin. */
+{
+ int i, res = 0;
+ Class *mixPtr;
+
+ FOREACH(mixPtr, oPtr->mixins) {
+ if (mixinPtr == mixPtr) {
+ RemoveItem(Class, oPtr->mixins, i);
+ TclOODecrRefCount(mixPtr->thisPtr);
+ res++;
+ break;
+ }
+ }
+ if (oPtr->mixins.num == 0) {
+ ckfree(oPtr->mixins.list);
+ oPtr->mixins.list = NULL;
+ }
+ return res;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromSubclasses --
+ *
+ * Utility function to remove a class from the list of subclasses within
+ * another class. Returns the number of removals performed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOORemoveFromSubclasses(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to possibly remove the
+ * subclass reference from. */
+{
+ int i, res = 0;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->subclasses) {
+ if (subPtr == subclsPtr) {
+ RemoveItem(Class, superPtr->subclasses, i);
+ TclOODecrRefCount(subPtr->thisPtr);
+ res++;
+ }
+ }
+ return res;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 (Destructing(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;
+ AddRef(subPtr->thisPtr);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromMixinSubs --
+ *
+ * Utility function to remove a class from the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOORemoveFromMixinSubs(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to possibly remove the
+ * subclass reference from. */
+{
+ int i, res = 0;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->mixinSubs) {
+ if (subPtr == subclsPtr) {
+ RemoveItem(Class, superPtr->mixinSubs, i);
+ TclOODecrRefCount(subPtr->thisPtr);
+ res++;
+ break;
+ }
+ }
+ return res;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 (Destructing(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;
+ AddRef(subPtr->thisPtr);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAllocClass --
+ *
+ * Allocate a basic class. Does not add class to its class's instance
+ * list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Class *
+TclOOAllocClass(
+ Tcl_Interp *interp, /* Interpreter within which to allocate the
+ * class. */
+ Object *useThisObj) /* Object that is to act as the class
+ * representation. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Class *clsPtr = ckalloc(sizeof(Class));
+
+ memset(clsPtr, 0, sizeof(Class));
+ clsPtr->thisPtr = useThisObj;
+
+ /*
+ * Configure the namespace path for the class's object.
+ */
+ initClassPath(interp, clsPtr);
+
+ /*
+ * 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;
+ AddRef(fPtr->objectCls->thisPtr);
+
+ /*
+ * 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.
+ */
+
+ Tcl_InitObjHashTable(&clsPtr->classMethods);
+ return clsPtr;
+}
+static void
+initClassPath(Tcl_Interp *interp, Class *clsPtr) {
+ Foundation *fPtr = GetFoundation(interp);
+ if (fPtr->helpersNs != NULL) {
+ Tcl_Namespace *path[2];
+ path[0] = fPtr->helpersNs;
+ path[1] = fPtr->ooNs;
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+ } else {
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
+ &fPtr->ooNs);
+ }
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ Class *classPtr = (Class *) cls;
+ Object *oPtr;
+ ClientData clientData[4];
+
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return NULL;}
+
+ /*
+ * Run constructors, except when objc < 0, which is a special flag case
+ * used for object cloning only.
+ */
+
+ if (objc >= 0) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+
+ if (contextPtr != NULL) {
+ int isRoot, result;
+ Tcl_InterpState state;
+
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+
+ /*
+ * Adjust the ensemble tracking record if necessary. [Bug 3514761]
+ */
+
+ isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
+ objc, objv);
+
+ if (isRoot) {
+ TclResetRewriteEnsemble(interp, 1);
+ }
+
+ clientData[0] = contextPtr;
+ clientData[1] = oPtr;
+ clientData[2] = state;
+ clientData[3] = &oPtr;
+
+ result = FinalizeAlloc(clientData, interp, result);
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ }
+ }
+
+ 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. */
+{
+ Class *classPtr = (Class *) cls;
+ CallContext *contextPtr;
+ Tcl_InterpState state;
+ Object *oPtr;
+
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return TCL_ERROR;}
+
+ /*
+ * 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 ensemble tracking record if necessary. [Bug 3514761]
+ */
+
+ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
+
+ /*
+ * Fire off the constructors non-recursively.
+ */
+
+ TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
+ objectPtr);
+ TclPushTailcallPoint(interp);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+\f
+Object *
+TclNewObjectInstanceCommon(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ const char *nameStr,
+ const char *nsNameStr)
+{
+ Tcl_HashEntry *hPtr;
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+ const char *simpleName = NULL;
+ Namespace *nsPtr = NULL, *dummy,
+ *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+
+ if (nameStr) {
+ TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
+ TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);
+
+ /*
+ * Disallow creation of an object over an existing command.
+ */
+
+ hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
+ if (hPtr) {
+ 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, simpleName, nsPtr, nsNameStr);
+ oPtr->selfCls = classPtr;
+ AddRef(classPtr->thisPtr);
+ 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
+ * TclOOAllocClass 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 TclOOAllocClass interferes with that.
+ */
+
+ TclOOAllocClass(interp, oPtr);
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ } else {
+ oPtr->classPtr = NULL;
+ }
+ return oPtr;
+}
+\f
+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];
+
+ /*
+ * Ensure an error if the object was deleted in the constructor.
+ * Don't want to lose errors by accident. [Bug 2903011]
+ */
+
+ if (result != TCL_ERROR && Destructing(oPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
+ result = TCL_ERROR;
+ }
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+
+ /*
+ * Take care to not delete a deleted object; that would be bad. [Bug
+ * 2903011] Also take care to make sure that we have the name of the
+ * command before we delete it. [Bug 9dd1bd7a74]
+ */
+
+ if (!Destructing(oPtr)) {
+ (void) TclOOObjectName(interp, oPtr);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+
+ /*
+ * This decrements the refcount of oPtr.
+ */
+
+ TclOODeleteContext(contextPtr);
+ return TCL_ERROR;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ *objectPtr = (Tcl_Object) oPtr;
+
+ /*
+ * This decrements the refcount of oPtr.
+ */
+
+ TclOODeleteContext(contextPtr);
+ return TCL_OK;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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.
+ */
+
+ if (o2Ptr->mixins.num != 0) {
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+ TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ }
+ TclOODecrRefCount(mixinPtr->thisPtr);
+ }
+ ckfree(o2Ptr->mixins.list);
+ }
+ DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+ TclOOAddToInstances(o2Ptr, mixinPtr);
+ }
+
+ /*
+ * For the reference just created in DUPLICATE.
+ */
+
+ AddRef(mixinPtr->thisPtr);
+ }
+
+ /*
+ * 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_DESTRUCTING | 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);
+ TclOODecrRefCount(superPtr->thisPtr);
+ }
+ 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);
+
+ /*
+ * For the new item in cls2Ptr->superclasses that memcpy just
+ * created.
+ */
+
+ AddRef(superPtr->thisPtr);
+ }
+
+ /*
+ * 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).
+ */
+
+ if (cls2Ptr->mixins.num != 0) {
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
+ }
+ ckfree(clsPtr->mixins.list);
+ }
+ DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+
+ /*
+ * For the copy just created in DUPLICATE.
+ */
+
+ AddRef(mixinPtr->thisPtr);
+ }
+
+ /*
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ *
+ * Main entry point for object invocations. 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);
+ }
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectCmdCore, FinalizeObjectCall --
+ *
+ * Main function for object invocations. Does call chain creation,
+ * management and invocation. 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 invocation 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) {
+ 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++) {
+ 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 invocations (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)
+{
+ 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 invocations (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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 ((Object *)object)->command == NULL;
+}
+
+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;
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
