summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c6
-rw-r--r--generic/tclInt.h19
-rw-r--r--generic/tclOO.c2179
-rw-r--r--generic/tclOO.decls190
-rw-r--r--generic/tclOO.h128
-rw-r--r--generic/tclOOBasic.c925
-rw-r--r--generic/tclOOCall.c1211
-rw-r--r--generic/tclOODecls.h282
-rw-r--r--generic/tclOODefineCmds.c1831
-rw-r--r--generic/tclOOInfo.c1271
-rw-r--r--generic/tclOOInt.h579
-rw-r--r--generic/tclOOIntDecls.h209
-rw-r--r--generic/tclOOMethod.c1425
-rw-r--r--generic/tclOOStubInit.c79
-rw-r--r--generic/tclOOStubLib.c82
15 files changed, 10414 insertions, 2 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4b7593a..0a45567 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.298 2008/05/02 20:08:51 patthoyts Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.299 2008/05/31 11:42:13 dkf Exp $
*/
#include "tclInt.h"
@@ -815,6 +815,10 @@ Tcl_CreateInterp(void)
Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp)));
}
+ if (TclOOInit(interp) != TCL_OK) {
+ Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+
return interp;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index eab070c..3ec57b4 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.368 2008/05/09 04:58:54 georgeps Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.369 2008/05/31 11:42:14 dkf Exp $
*/
#ifndef _TCLINT
@@ -1058,6 +1058,14 @@ typedef struct CallFrame {
#define FRAME_IS_PROC 0x1
#define FRAME_IS_LAMBDA 0x2
+#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
+ * clientData field contains a CallContext
+ * reference. Part of TIP#257. */
+#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of
+ * the [oo::define] command; the clientData
+ * field contains an Object reference that has
+ * been confirmed to refer to a class. Part of
+ * TIP#257. */
/*
* TIP #280
@@ -1878,6 +1886,15 @@ typedef struct Interp {
* TclpCheckStackSpace in the platform's
* directory. */
+ /*
+ * The pointer to the object system root ekeko. c.f. TIP #257.
+ */
+
+ void *objectFoundation; /* Pointer to the Foundation structure of the
+ * object system, which contains things like
+ * references to key namespaces. See
+ * tclOOInt.h and tclOO.c for real definition
+ * and setup. */
#ifdef TCL_COMPILE_STATS
/*
diff --git a/generic/tclOO.c b/generic/tclOO.c
new file mode 100644
index 0000000..de0b36b
--- /dev/null
+++ b/generic/tclOO.c
@@ -0,0 +1,2179 @@
+/*
+ * tclOO.c --
+ *
+ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2005-2008 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.
+ *
+ * RCS: @(#) $Id: tclOO.c,v 1.4 2008/05/31 11:42:16 dkf Exp $
+ */
+
+#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},
+ {"filter", TclOODefineFilterObjCmd, 0},
+ {"forward", TclOODefineForwardObjCmd, 0},
+ {"method", TclOODefineMethodObjCmd, 0},
+ {"mixin", TclOODefineMixinObjCmd, 0},
+ {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
+ {"self", TclOODefineSelfObjCmd, 0},
+ {"superclass", TclOODefineSuperclassObjCmd, 0},
+ {"unexport", TclOODefineUnexportObjCmd, 0},
+ {NULL, NULL, 0}
+}, objdefCmds[] = {
+ {"class", TclOODefineClassObjCmd, 1},
+ {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
+ {"export", TclOODefineExportObjCmd, 1},
+ {"filter", TclOODefineFilterObjCmd, 1},
+ {"forward", TclOODefineForwardObjCmd, 1},
+ {"method", TclOODefineMethodObjCmd, 1},
+ {"mixin", TclOODefineMixinObjCmd, 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 InitFoundation(Tcl_Interp *interp);
+static void KillFoundation(ClientData clientData,
+ Tcl_Interp *interp);
+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 int PublicObjectCmd(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);
+
+/*
+ * 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}
+}, clsMethods[] = {
+ DCM("create", 1, TclOO_Class_Create),
+ DCM("new", 1, TclOO_Class_New),
+ DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
+ {NULL}
+};
+
+static char initScript[] =
+ "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;"; */
+
+extern struct TclOOStubAPI tclOOStubAPI;
+
+/*
+ * Convenience macro for getting the foundation from an interpreter.
+ */
+
+#define GetFoundation(interp) \
+ ((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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.
+ */
+
+ InitFoundation(interp);
+
+ /*
+ * 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_VERSION, &tclOOStubAPI);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 void
+InitFoundation(
+ Tcl_Interp *interp)
+{
+ static Tcl_ThreadDataKey tsdKey;
+ ThreadLocalData *tsdPtr =
+ Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
+ Foundation *fPtr = (Foundation *) ckalloc(sizeof(Foundation));
+ Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+ Tcl_DString buffer;
+ 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", NULL, NULL);
+ fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", NULL,
+ NULL);
+ fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL,
+ NULL);
+ fPtr->epoch = 0;
+ fPtr->tsdPtr = tsdPtr;
+ fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
+ fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
+ fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
+ Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
+ Tcl_IncrRefCount(fPtr->constructorName);
+ Tcl_IncrRefCount(fPtr->destructorName);
+ Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
+ TclOOUnknownDefinition, NULL, NULL);
+ namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
+ 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++) {
+ Tcl_DStringAppend(&buffer, "::oo::define::", 14);
+ Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ defineCmds[i].objProc, (void *) defineCmds[i].flag, NULL);
+ Tcl_DStringFree(&buffer);
+ }
+ for (i=0 ; objdefCmds[i].name ; i++) {
+ Tcl_DStringAppend(&buffer, "::oo::objdefine::", 17);
+ Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ objdefCmds[i].objProc, (void *) 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->superclasses.num = 0;
+ ckfree((char *) fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+
+ /*
+ * 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]);
+ }
+
+ /*
+ * 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.
+ */
+
+ namePtr = Tcl_NewStringObj("new", -1);
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
+
+ argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+ bodyPtr = Tcl_NewStringObj(
+ "if {[catch {define [self] $definitionScript} msg opt]} {\n"
+ "set ei [split [dict get $opt -errorinfo] \\n]\n"
+ "dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n"
+ "dict set opt -errorline 0xdeadbeef\n"
+ "}\n"
+ "return -options $opt $msg", -1);
+ fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
+ fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
+
+ /*
+ * Create non-object commands and plug ourselves into the Tcl [info]
+ * ensemble.
+ */
+
+ Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
+ NULL);
+ 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);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+
+ Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
+ Tcl_DecrRefCount(fPtr->constructorName);
+ Tcl_DecrRefCount(fPtr->destructorName);
+ ckfree((char *) 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);
+ Tcl_DString buffer;
+ Object *oPtr;
+ int creationEpoch;
+
+ oPtr = (Object *) 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:
+ TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+
+ /*
+ * 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) {
+ if (nameStr[0] != ':' || nameStr[1] != ':') {
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer,
+ Tcl_GetCurrentNamespace(interp)->fullName, -1);
+ Tcl_DStringAppend(&buffer, "::", 2);
+ Tcl_DStringAppend(&buffer, nameStr, -1);
+ oPtr->command = Tcl_CreateObjCommand(interp,
+ Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
+ Tcl_DStringFree(&buffer);
+ } else {
+ oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
+ PublicObjectCmd, oPtr, NULL);
+ }
+ } else {
+ oPtr->command = Tcl_CreateObjCommand(interp,
+ oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
+ }
+
+ /*
+ * Access the namespace command table directly when creating "my" to avoid
+ * a bottleneck in string manipulation.
+ */
+
+ {
+ register Command *cmdPtr = (Command *) ckalloc(sizeof(Command));
+
+ memset(cmdPtr, 0, sizeof(Command));
+ cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
+ cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
+ &creationEpoch /*ignored*/ );
+ cmdPtr->refCount = 1;
+ cmdPtr->objProc = PrivateObjectCmd;
+ cmdPtr->objClientData = oPtr;
+ cmdPtr->proc = TclInvokeObjectCommand;
+ cmdPtr->clientData = cmdPtr;
+ Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
+ }
+
+ Tcl_TraceCommand(interp, TclGetString(TclOOObjectName(interp, oPtr)),
+ TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, oPtr);
+
+ return oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+ Class *clsPtr;
+
+ /*
+ * 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) {
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+ 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.
+ */
+
+ AddRef(oPtr);
+ oPtr->flags |= OBJECT_DELETED;
+ if (!Tcl_InterpDeleted(interp)) {
+ CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);
+
+ if (contextPtr != NULL) {
+ int result;
+ Tcl_InterpState state;
+
+ contextPtr->callPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
+ if (result != TCL_OK) {
+ Tcl_BackgroundError(interp);
+ }
+ 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).
+ */
+
+ clsPtr = oPtr->classPtr;
+ if (clsPtr != NULL) {
+ AddRef(clsPtr);
+ ReleaseClassContents(interp, oPtr);
+ }
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ if (clsPtr) {
+ DelRef(clsPtr);
+ }
+ 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. */
+{
+ int i, n;
+ Class *clsPtr = oPtr->classPtr, **list;
+ Object **insts;
+
+ /*
+ * Must empty list before processing the members of the list so that
+ * things happen in the correct order even if something tries to play
+ * fast-and-loose.
+ */
+
+ list = clsPtr->mixinSubs.list;
+ n = clsPtr->mixinSubs.num;
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
+ clsPtr->mixinSubs.size = 0;
+ for (i=0 ; i<n ; i++) {
+ AddRef(list[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
+ Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+ }
+ DelRef(list[i]);
+ }
+ if (list != NULL) {
+ ckfree((char *) list);
+ }
+
+ list = clsPtr->subclasses.list;
+ n = clsPtr->subclasses.num;
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
+ clsPtr->subclasses.size = 0;
+ for (i=0 ; i<n ; i++) {
+ AddRef(list[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
+ Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+ }
+ DelRef(list[i]);
+ }
+ if (list != NULL) {
+ ckfree((char *) list);
+ }
+
+ insts = clsPtr->instances.list;
+ n = clsPtr->instances.num;
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ clsPtr->instances.size = 0;
+ for (i=0 ; i<n ; i++) {
+ AddRef(insts[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) {
+ Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+ }
+ DelRef(insts[i]);
+ }
+ if (insts != NULL) {
+ ckfree((char *) insts);
+ }
+
+ if (clsPtr->constructorChainPtr) {
+ TclOODeleteChain(clsPtr->constructorChainPtr);
+ }
+ if (clsPtr->destructorChainPtr) {
+ TclOODeleteChain(clsPtr->destructorChainPtr);
+ }
+ if (clsPtr->classChainCache) {
+ FOREACH_HASH_DECLS;
+ CallChain *callPtr;
+
+ FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
+ TclOODeleteChain(callPtr);
+ }
+ Tcl_DeleteHashTable(clsPtr->classChainCache);
+ ckfree((char *) clsPtr->classChainCache);
+ }
+
+ if (clsPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ ckfree((char *) clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+
+
+ if (clsPtr->metadataPtr != NULL) {
+ FOREACH_HASH_DECLS;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree((char *) 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;
+ int i, preserved = !(oPtr->flags & OBJECT_DELETED);
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ */
+
+ if (preserved) {
+ AddRef(oPtr);
+ if (clsPtr != NULL) {
+ AddRef(clsPtr);
+ ReleaseClassContents(NULL, oPtr);
+ }
+ }
+ oPtr->flags |= OBJECT_DELETED;
+
+ /*
+ * Splice the object out of its context. After this, we must *not* call
+ * methods on the object.
+ */
+
+ if (!(oPtr->flags & ROOT_OBJECT)) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ if (i) {
+ ckfree((char *) oPtr->mixins.list);
+ }
+
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree((char *) oPtr->filters.list);
+ }
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(oPtr->methodsPtr);
+ ckfree((char *) oPtr->methodsPtr);
+ }
+
+ if (oPtr->chainCache) {
+ TclOODeleteChainCache(oPtr->chainCache);
+ }
+
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+
+ if (oPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(oPtr->metadataPtr);
+ ckfree((char *) oPtr->metadataPtr);
+ oPtr->metadataPtr = NULL;
+ }
+
+ if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
+ Class *superPtr, *mixinPtr;
+
+ if (clsPtr->metadataPtr != NULL) {
+ FOREACH_HASH_DECLS;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree((char *) clsPtr->metadataPtr);
+ clsPtr->metadataPtr = NULL;
+ }
+
+ clsPtr->flags |= OBJECT_DELETED;
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree((char *) clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ if (!(mixinPtr->flags & OBJECT_DELETED)) {
+ TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ }
+ }
+ if (i) {
+ ckfree((char *) clsPtr->mixins.list);
+ clsPtr->mixins.num = 0;
+ }
+ FOREACH(superPtr, clsPtr->superclasses) {
+ if (!(superPtr->flags & OBJECT_DELETED)) {
+ TclOORemoveFromSubclasses(clsPtr, superPtr);
+ }
+ }
+ if (i) {
+ ckfree((char *) clsPtr->superclasses.list);
+ clsPtr->superclasses.num = 0;
+ }
+ if (clsPtr->subclasses.list) {
+ ckfree((char *) clsPtr->subclasses.list);
+ clsPtr->subclasses.num = 0;
+ }
+ if (clsPtr->instances.list) {
+ ckfree((char *) clsPtr->instances.list);
+ clsPtr->instances.num = 0;
+ }
+ if (clsPtr->mixinSubs.list) {
+ ckfree((char *) 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);
+ DelRef(clsPtr);
+ }
+
+ /*
+ * Delete the object structure itself.
+ */
+
+ DelRef(oPtr);
+ if (preserved) {
+ if (clsPtr) {
+ DelRef(clsPtr);
+ }
+ 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:
+ 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 (clsPtr->instances.num >= clsPtr->instances.size) {
+ clsPtr->instances.size += ALLOC_CHUNK;
+ if (clsPtr->instances.size == ALLOC_CHUNK) {
+ clsPtr->instances.list = (Object **)
+ ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+ } else {
+ clsPtr->instances.list = (Object **)
+ ckrealloc((char *) 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:
+ 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 (superPtr->subclasses.num >= superPtr->subclasses.size) {
+ superPtr->subclasses.size += ALLOC_CHUNK;
+ if (superPtr->subclasses.size == ALLOC_CHUNK) {
+ superPtr->subclasses.list = (Class **)
+ ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ } else {
+ superPtr->subclasses.list = (Class **)
+ ckrealloc((char *) 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:
+ 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 (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
+ superPtr->mixinSubs.size += ALLOC_CHUNK;
+ if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
+ superPtr->mixinSubs.list = (Class **)
+ ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ } else {
+ superPtr->mixinSubs.list = (Class **)
+ ckrealloc((char *) 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 = (Class *) ckalloc(sizeof(Class));
+ Tcl_Namespace *path[2];
+
+ /*
+ * 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.
+ */
+
+ path[0] = fPtr->helpersNs;
+ path[1] = fPtr->ooNs;
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+
+ /*
+ * 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 = (Class **) 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, 0)) {
+ Tcl_AppendResult(interp, "can't create object \"", nameStr,
+ "\": command already exists with that name", 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);
+
+ if (contextPtr != NULL) {
+ int result;
+ Tcl_InterpState state;
+
+ AddRef(oPtr);
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+ result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+ TclOODeleteContext(contextPtr);
+ DelRef(oPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ return NULL;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ }
+ }
+
+ return (Tcl_Object) oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+ Tcl_Obj *keyPtr, *filterObj;
+ int i;
+
+ /*
+ * Sanity checks.
+ */
+
+ if (targetName == NULL && oPtr->classPtr != NULL) {
+ Tcl_AppendResult(interp, "must supply a name when copying a class",
+ NULL);
+ return NULL;
+ }
+ if (oPtr->classPtr == GetFoundation(interp)->classCls) {
+ Tcl_AppendResult(interp, "may not clone the class of classes", 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 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 | 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 = (Class **)
+ ckrealloc((char *) cls2Ptr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ } else {
+ cls2Ptr->superclasses.list = (Class **)
+ 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);
+ }
+
+ /*
+ * 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((char *) 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);
+ }
+ }
+ }
+ }
+
+ 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 = (Tcl_HashTable*) 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 = (Tcl_HashTable *) 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, TclOOObjectCmdCore --
+ *
+ * Main entry point for object invokations. The Public* and Private*
+ * wrapper functions are just thin wrappers round the main
+ * TclOOObjectCmdCore function that does call chain creation, management
+ * and invokation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PublicObjectCmd(
+ 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 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);
+ }
+}
+
+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 (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Give plugged in code a chance to remap the method name.
+ */
+
+ methodNamePtr = objv[1];
+ if (oPtr->mapMethodNameProc != NULL) {
+ register Class **startClsPtr = &startCls;
+
+ methodNamePtr = Tcl_DuplicateObj(methodNamePtr);
+ result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
+ (Tcl_Class *) startClsPtr, methodNamePtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (while mapping method name)");
+ }
+ Tcl_DecrRefCount(methodNamePtr);
+ return result;
+ }
+ }
+ Tcl_IncrRefCount(methodNamePtr);
+
+ /*
+ * Get the call chain.
+ */
+
+ contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
+ flags | (oPtr->flags & FILTER_HANDLING));
+ if (contextPtr == NULL) {
+ Tcl_AppendResult(interp, "impossible to invoke method \"",
+ TclGetString(methodNamePtr),
+ "\": no defined method or unknown method", NULL);
+ Tcl_DecrRefCount(methodNamePtr);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(methodNamePtr);
+
+ /*
+ * Check to see if we need to apply magical tricks to start part way
+ * through the call chain.
+ */
+
+ if (startCls != NULL) {
+ while (contextPtr->index < contextPtr->callPtr->numChain) {
+ register struct MInvoke *miPtr =
+ &contextPtr->callPtr->chain[contextPtr->index];
+
+ if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr!=startCls) {
+ contextPtr->index++;
+ } else {
+ break;
+ }
+ }
+ if (contextPtr->index >= contextPtr->callPtr->numChain) {
+ result = TCL_ERROR;
+ Tcl_SetResult(interp, "no valid method implementation",
+ TCL_STATIC);
+ AddRef(oPtr); /* Just to balance. */
+ goto disposeChain;
+ }
+ }
+
+ /*
+ * Invoke the call chain, locking the object structure against deletion
+ * for the duration.
+ */
+
+ AddRef(oPtr);
+ result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+
+ /*
+ * Dispose of the call chain and drop the lock on the object's structure.
+ */
+
+ disposeChain:
+ TclOODeleteContext(contextPtr);
+ DelRef(oPtr);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ObjectContextInvokeNext --
+ *
+ * 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.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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; return the empty string (the most
+ * useful thing we can do, since it turns out that it's not always
+ * trivial to detect in source code whether there is a parent
+ * implementation, what with multiple-inheritance...)
+ */
+
+ return TCL_OK;
+ }
+
+ /*
+ * 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 = TclOOInvokeContext(interp, 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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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_AppendResult(interp, TclGetString(objPtr),
+ " does not refer to an object", 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 --
+ *
+ * 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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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)->flags & OBJECT_DELETED) ? 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:
+ */
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
new file mode 100644
index 0000000..0fdbe47
--- /dev/null
+++ b/generic/tclOO.decls
@@ -0,0 +1,190 @@
+# -*- tcl -*-
+# $Id: tclOO.decls,v 1.1 2008/05/31 11:42:17 dkf Exp $
+
+# public API
+library tclOO
+interface tclOO
+epoch 0
+scspec TCLOOAPI
+
+declare 0 current {
+ Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
+ Tcl_Object sourceObject, const char *targetName,
+ const char *targetNamespaceName)
+}
+declare 1 current {
+ Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz)
+}
+declare 2 current {
+ Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object)
+}
+declare 3 current {
+ Tcl_Command Tcl_GetObjectCommand(Tcl_Object object)
+}
+declare 4 current {
+ Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+}
+declare 5 current {
+ Tcl_Namespace *Tcl_GetObjectNamespace(Tcl_Object object)
+}
+declare 6 current {
+ Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method)
+}
+declare 7 current {
+ Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method)
+}
+declare 8 current {
+ int Tcl_MethodIsPublic(Tcl_Method method)
+}
+declare 9 current {
+ int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr)
+}
+declare 10 current {
+ Tcl_Obj *Tcl_MethodName(Tcl_Method method)
+}
+declare 11 current {
+ Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ ClientData clientData)
+}
+declare 12 current {
+ Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ ClientData clientData)
+}
+declare 13 current {
+ Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
+ const char *nameStr, const char *nsNameStr, int objc,
+ Tcl_Obj *const *objv, int skip)
+}
+declare 14 current {
+ int Tcl_ObjectDeleted(Tcl_Object object)
+}
+declare 15 current {
+ int Tcl_ObjectContextIsFiltering(Tcl_ObjectContext context)
+}
+declare 16 current {
+ Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context)
+}
+declare 17 current {
+ Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
+}
+declare 18 current {
+ int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
+}
+declare 19 current {
+ ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr)
+}
+declare 20 current {
+ void Tcl_ClassSetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr, ClientData metadata)
+}
+declare 21 current {
+ ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr)
+}
+declare 22 current {
+ void Tcl_ObjectSetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr, ClientData metadata)
+}
+declare 23 current {
+ int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv,
+ int skip)
+}
+declare 24 current {
+ Tcl_ObjectMapMethodNameProc Tcl_ObjectGetMethodNameMapper(
+ Tcl_Object object)
+}
+declare 25 current {
+ void Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
+ Tcl_ObjectMapMethodNameProc mapMethodNameProc)
+}
+declare 26 current {
+ void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz,
+ Tcl_Method method)
+}
+declare 27 current {
+ void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz,
+ Tcl_Method method)
+}
+
+# private API, exposed to support advanced OO systems that plug in on top
+interface tclOOInt
+declare 0 current {
+ Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp)
+}
+declare 1 current {
+ Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr,
+ int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ const Tcl_MethodType *typePtr, ClientData clientData,
+ Proc **procPtrPtr)
+}
+declare 2 current {
+ Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr,
+ int flags, Tcl_Obj *nameObj, const char *namePtr,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr,
+ ClientData clientData, Proc **procPtrPtr)
+}
+declare 3 current {
+ Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr,
+ int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ ProcedureMethod **pmPtrPtr)
+}
+declare 4 current {
+ Method *TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
+ int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
+ ProcedureMethod **pmPtrPtr)
+}
+declare 5 current {
+ int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv, int publicOnly, Class *startCls)
+}
+declare 6 current {
+ int TclOOIsReachable(Class *targetPtr, Class *startPtr)
+}
+declare 7 current {
+ Method *TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr,
+ int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
+}
+declare 8 current {
+ Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr,
+ int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
+}
+declare 9 current {
+ Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
+ Tcl_Object oPtr, TclOO_PreCallProc preCallPtr,
+ TclOO_PostCallProc postCallPtr, ProcErrorProc errProc,
+ ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj,
+ Tcl_Obj *bodyObj, int flags, void **internalTokenPtr)
+}
+declare 10 current {
+ Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr,
+ TclOO_PreCallProc preCallPtr, TclOO_PostCallProc postCallPtr,
+ ProcErrorProc errProc, ClientData clientData, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags,
+ void **internalTokenPtr)
+}
+declare 11 current {
+ int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Class startCls, int publicPrivate, int objc,
+ Tcl_Obj *const *objv)
+}
+declare 12 current {
+ void TclOOObjectSetFilters(Object *oPtr, int numFilters,
+ Tcl_Obj *const *filters)
+}
+declare 13 current {
+ void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr,
+ int numFilters, Tcl_Obj *const *filters)
+}
+declare 14 current {
+ void TclOOObjectSetMixins(Object *oPtr, int numMixins,
+ Class *const *mixins)
+}
+declare 15 current {
+ void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
+ int numMixins, Class *const *mixins)
+}
diff --git a/generic/tclOO.h b/generic/tclOO.h
new file mode 100644
index 0000000..f3fd73c
--- /dev/null
+++ b/generic/tclOO.h
@@ -0,0 +1,128 @@
+/*
+ * tclOO.h --
+ *
+ * This file contains the public API definitions and some of the function
+ * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006-2008 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.
+ *
+ * RCS: @(#) $Id: tclOO.h,v 1.4 2008/05/31 11:42:17 dkf Exp $
+ */
+
+#ifndef TCLOO_H_INCLUDED
+#define TCLOO_H_INCLUDED
+#include "tcl.h"
+
+#if defined(BUILD_tcloo)
+# define TCLOOAPI DLLEXPORT
+# undef USE_TCLOO_STUBS
+#else
+# define TCLOOAPI DLLIMPORT
+#endif
+
+/*
+ * Must match version at top of ../configure.in
+ */
+
+#define TCLOO_VERSION "0.4"
+#define TCLOO_PATCHLEVEL TCLOO_VERSION
+
+/*
+ * These are opaque types.
+ */
+
+typedef struct Tcl_Class_ *Tcl_Class;
+typedef struct Tcl_Method_ *Tcl_Method;
+typedef struct Tcl_Object_ *Tcl_Object;
+typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
+
+/*
+ * Public datatypes for callbacks and structures used in the TIP#257 (OO)
+ * implementation. These are used to implement custom types of method calls
+ * and to allow the attachment of arbitrary data to objects and classes.
+ */
+
+typedef int (*Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+typedef void (*Tcl_MethodDeleteProc)(ClientData clientData);
+typedef int (*Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData,
+ ClientData *newClientData);
+typedef void (*Tcl_ObjectMetadataDeleteProc)(ClientData clientData);
+typedef int (*Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj);
+
+/*
+ * The type of a method implementation. This describes how to call the method
+ * implementation, how to delete it (when the object or class is deleted) and
+ * how to create a clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_CURRENT in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc callProc;/* How to invoke this method. */
+ Tcl_MethodDeleteProc deleteProc;
+ /* How to delete this method's type-specific
+ * data, or NULL if the type-specific data
+ * does not need deleting. */
+ Tcl_CloneProc cloneProc; /* How to copy this method's type-specific
+ * data, or NULL if the type-specific data can
+ * be copied directly. */
+} Tcl_MethodType;
+
+/*
+ * The correct value for the version field of the Tcl_MethodType structure.
+ * This allows new versions of the structure to be introduced without breaking
+ * binary compatability.
+ */
+
+#define TCL_OO_METHOD_VERSION_CURRENT 1
+
+/*
+ * The type of some object (or class) metadata. This describes how to delete
+ * the metadata (when the object or class is deleted) and how to create a
+ * clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METADATA_VERSION_CURRENT in
+ * declarations. */
+ const char *name;
+ Tcl_ObjectMetadataDeleteProc deleteProc;
+ /* How to delete the metadata. This must not
+ * be NULL. */
+ Tcl_CloneProc cloneProc; /* How to copy the metadata, or NULL if the
+ * type-specific data can be copied
+ * directly. */
+} Tcl_ObjectMetadataType;
+
+/*
+ * The correct value for the version field of the Tcl_ObjectMetadataType
+ * structure. This allows new versions of the structure to be introduced
+ * without breaking binary compatability.
+ */
+
+#define TCL_OO_METADATA_VERSION_CURRENT 1
+
+/*
+ * Include all the public API, generated from tclOO.decls.
+ */
+
+#include "tclOODecls.h"
+
+#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
new file mode 100644
index 0000000..1cd07df
--- /dev/null
+++ b/generic/tclOOBasic.c
@@ -0,0 +1,925 @@
+/*
+ * tclOOBasic.c --
+ *
+ * This file contains implementations of the "simple" commands and
+ * methods from the object-system core.
+ *
+ * Copyright (c) 2005-2008 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.
+ *
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.1 2008/05/31 11:42:17 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_Create --
+ *
+ * Implementation for oo::class->create method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Create(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Object newObject;
+ const char *objName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, NULL, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+1);
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_CreateNs --
+ *
+ * Implementation for oo::class->createWithNamespace method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_CreateNs(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Object newObject;
+ const char *objName, *nsName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName namespaceName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+ nsName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "namespace name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, nsName, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+2);
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_New --
+ *
+ * Implementation for oo::class->new method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_New(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Object newObject;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Destroy --
+ *
+ * Implementation for oo::object->destroy method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Destroy(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ if (objc != Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_DeleteCommandFromToken(interp,
+ Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Eval --
+ *
+ * Implementation for oo::object->eval method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Eval(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ CallFrame *framePtr, **framePtrPtr;
+ Tcl_Obj *objnameObj;
+ int result;
+
+ if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object's namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ /* This is needed to satisfy GCC 3.3's strict aliasing rules */
+ framePtrPtr = &framePtr;
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ Tcl_GetObjectNamespace(object), 0);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+
+ if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
+ objnameObj = TclOOObjectName(interp, (Object *) object);
+ } else {
+ objnameObj = Tcl_NewStringObj("my", 2);
+ }
+ Tcl_IncrRefCount(objnameObj);
+
+ if (objc == Tcl_ObjectContextSkippedArgs(context)+1) {
+ result = Tcl_EvalObjEx(interp,
+ objv[Tcl_ObjectContextSkippedArgs(context)], 0);
+ } else {
+ Tcl_Obj *objPtr;
+
+ /*
+ * More than one argument: concatenate them together with spaces
+ * between, then evaluate the result. Tcl_EvalObjEx will delete the
+ * object when it decrements its refcount after eval'ing it.
+ */
+
+ objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context),
+ objv+Tcl_ObjectContextSkippedArgs(context));
+ result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
+ }
+
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in \"%s eval\" script line %d)",
+ TclGetString(objnameObj), interp->errorLine));
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ Tcl_DecrRefCount(objnameObj);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Unknown --
+ *
+ * Default unknown method handler method (defined in oo::object). This
+ * just creates a suitable error message.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Unknown(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Object *oPtr = contextPtr->oPtr;
+ const char **methodNames;
+ int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+
+ if (objc < skip+1) {
+ Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the list of methods that we want to know about.
+ */
+
+ numMethodNames = TclOOGetSortedMethodList(oPtr,
+ contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
+
+ /*
+ * Special message when there are no visible methods at all.
+ */
+
+ if (numMethodNames == 0) {
+ Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
+ if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
+ Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+ } else {
+ Tcl_AppendResult(interp, "\" has no methods", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
+ "\": must be ", NULL);
+ for (i=0 ; i<numMethodNames-1 ; i++) {
+ if (i) {
+ Tcl_AppendResult(interp, ", ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ }
+ if (i) {
+ Tcl_AppendResult(interp, " or ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ ckfree((char *) methodNames);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_LinkVar --
+ *
+ * Implementation of oo::object->variable method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_LinkVar(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ Namespace *savedNsPtr;
+ int i;
+
+ if (objc-Tcl_ObjectContextSkippedArgs(context) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName ?varName ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Do nothing if we are not called from the body of a method. In this
+ * respect, we are like the [global] command.
+ */
+
+ if (iPtr->varFramePtr == NULL ||
+ !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ return TCL_OK;
+ }
+
+ for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
+ Var *varPtr, *aryPtr;
+ const char *varName = TclGetString(objv[i]);
+
+ /*
+ * The variable name must not contain a '::' since that's illegal in
+ * local names.
+ */
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "variable name \"", varName,
+ "\" illegal: must not contain namespace separator", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Switch to the object's namespace for the duration of this call.
+ * Like this, the variable is looked up in the namespace of the
+ * object, and not in the namespace of the caller. Otherwise this
+ * would only work if the caller was a method of the object itself,
+ * which might not be true if the method was exported. This is a bit
+ * of a hack, but the simplest way to do this (pushing a stack frame
+ * would be horribly expensive by comparison). We never have to worry
+ * about the case where we're dealing with the global namespace; we've
+ * already checked that we are inside a method.
+ */
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(object);
+ varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
+ "define", 1, 0, &aryPtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+
+ if (varPtr == NULL || aryPtr != NULL) {
+ /*
+ * Variable cannot be an element in an array. If aryPtr is not
+ * NULL, it is an element, so throw up an error and return.
+ */
+
+ TclVarErrMsg(interp, varName, NULL, "define",
+ "name refers to an element in an array");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Arrange for the lifetime of the variable to be correctly managed.
+ * This is copied out of Tcl_VariableObjCmd...
+ */
+
+ if (!TclIsVarNamespaceVar(varPtr)) {
+ TclSetVarNamespaceVar(varPtr);
+ }
+
+ if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_VarName --
+ *
+ * Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_VarName(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *aryVar;
+ Tcl_Obj *varNamePtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Switch to the object's namespace for the duration of this call. Like
+ * this, the variable is looked up in the namespace of the object, and not
+ * in the namespace of the caller. Otherwise this would only work if the
+ * caller was a method of the object itself, which might not be true if
+ * the method was exported. This is a bit of a hack, but the simplest way
+ * to do this (pushing a stack frame would be horribly expensive by
+ * comparison, and is only done when we'd otherwise interfere with the
+ * global namespace).
+ */
+
+ if (iPtr->varFramePtr == NULL) {
+ Tcl_CallFrame *dummyFrame;
+
+ TclPushStackFrame(interp, &dummyFrame,
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
+ varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+ TclPopStackFrame(interp);
+ } else {
+ Namespace *savedNsPtr;
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ }
+
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ varNamePtr = Tcl_NewObj();
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ Tcl_SetObjResult(interp, varNamePtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONextObjCmd --
+ *
+ * Implementation of the [next] command. Note that this command is only
+ * ever to be used inside the body of a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOONextObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ Tcl_ObjectContext context;
+ int result;
+
+ /*
+ * Start with sanity checks on the calling context to make sure that we
+ * are invoked from a suitable method context. If so, we can safely
+ * retrieve the handle to the object call context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", NULL);
+ return TCL_ERROR;
+ }
+ context = framePtr->clientData;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context. Note
+ * that this is like [uplevel 1] and not [eval].
+ */
+
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ result = Tcl_ObjectContextInvokeNext(interp, context, objc, objv, 1);
+ iPtr->varFramePtr = framePtr;
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOSelfObjCmd --
+ *
+ * Implementation of the [self] command, which provides introspection of
+ * the call context.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *subcmds[] = {
+ "caller", "class", "filter", "method", "namespace", "next", "object",
+ "target", NULL
+ };
+ enum SelfCmds {
+ SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
+ SELF_OBJECT, SELF_TARGET
+ };
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ int index;
+
+#define CurrentlyInvoked(contextPtr) \
+ ((contextPtr)->callPtr->chain[(contextPtr)->index])
+
+ /*
+ * Start with sanity checks on the calling context and the method context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", NULL);
+ return TCL_ERROR;
+ }
+
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Now we do "conventional" argument parsing for a while. Note that no
+ * subcommand takes arguments.
+ */
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
+ return TCL_ERROR;
+ } else if (objc == 1) {
+ index = SELF_OBJECT;
+ } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum SelfCmds) index) {
+ case SELF_OBJECT:
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
+ return TCL_OK;
+ case SELF_NS:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ contextPtr->oPtr->namespacePtr->fullName,-1));
+ return TCL_OK;
+ case SELF_CLASS: {
+ Method *mPtr = CurrentlyInvoked(contextPtr).mPtr;
+ Object *declarerPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, declarerPtr));
+ return TCL_OK;
+ }
+ case SELF_METHOD:
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_AppendResult(interp, "<constructor>", NULL);
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_AppendResult(interp, "<destructor>", NULL);
+ } else {
+ Tcl_SetObjResult(interp,
+ CurrentlyInvoked(contextPtr).mPtr->namePtr);
+ }
+ return TCL_OK;
+ case SELF_FILTER:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ return TCL_ERROR;
+ } else {
+ register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ Tcl_Obj *result[3];
+ Object *oPtr;
+ const char *type;
+
+ if (miPtr->filterDeclarer != NULL) {
+ oPtr = miPtr->filterDeclarer->thisPtr;
+ type = "class";
+ } else {
+ oPtr = contextPtr->oPtr;
+ type = "object";
+ }
+
+ result[0] = TclOOObjectName(interp, oPtr);
+ result[1] = Tcl_NewStringObj(type, -1);
+ result[2] = miPtr->mPtr->namePtr;
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ return TCL_OK;
+ }
+ case SELF_CALLER:
+ if ((framePtr->callerVarPtr != NULL) &&
+ (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ CallContext *callerPtr = framePtr->callerVarPtr->clientData;
+ Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
+ Object *declarerPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, declarerPtr));
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, callerPtr->oPtr));
+ if (callerPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<constructor>", -1));
+ } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<destructor>", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ }
+ return TCL_OK;
+ } else {
+ Tcl_AppendResult(interp, "caller is not an object", NULL);
+ return TCL_ERROR;
+ }
+ case SELF_NEXT:
+ if (contextPtr->index < contextPtr->callPtr->numChain-1) {
+ Method *mPtr =
+ contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
+ Object *declarerPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, declarerPtr));
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<constructor>", -1));
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<destructor>", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ }
+ }
+ return TCL_OK;
+ case SELF_TARGET:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ return TCL_ERROR;
+ } else {
+ Method *mPtr;
+ Object *declarerPtr;
+ int i;
+
+ for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
+ if (!contextPtr->callPtr->chain[i].isFilter) {
+ break;
+ }
+ }
+ if (i == contextPtr->callPtr->numChain) {
+ Tcl_Panic("filtering call chain without terminal non-filter");
+ }
+ mPtr = contextPtr->callPtr->chain[i].mPtr;
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, declarerPtr));
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ return TCL_OK;
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CopyObjectCmd --
+ *
+ * Implementation of the [oo::copy] command, which clones an object (but
+ * not its namespace). Note that no constructors are called during this
+ * process.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOCopyObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Object oPtr, o2Ptr;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+ return TCL_ERROR;
+ }
+
+ oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create a cloned object of the correct class. Note that constructors are
+ * not called. Also note that we must resolve the object name ourselves
+ * because we do not want to create the object in the current namespace,
+ * but rather in the context of the namespace of the caller of the overall
+ * [oo::define] command.
+ */
+
+ if (objc == 2) {
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
+ } else {
+ char *name;
+ Tcl_DString buffer;
+
+ name = TclGetString(objv[2]);
+ Tcl_DStringInit(&buffer);
+ if (name[0]!=':' || name[1]!=':') {
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->varFramePtr != NULL) {
+ Tcl_DStringAppend(&buffer,
+ iPtr->varFramePtr->nsPtr->fullName, -1);
+ }
+ Tcl_DStringAppend(&buffer, "::", 2);
+ Tcl_DStringAppend(&buffer, name, -1);
+ name = Tcl_DStringValue(&buffer);
+ }
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
+ Tcl_DStringFree(&buffer);
+ }
+
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the name of the cloned object.
+ */
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
new file mode 100644
index 0000000..551a3fd
--- /dev/null
+++ b/generic/tclOOCall.c
@@ -0,0 +1,1211 @@
+/*
+ * tclOOCall.c --
+ *
+ * This file contains the method call chain management code for the
+ * object-system core.
+ *
+ * Copyright (c) 2005-2008 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.
+ *
+ * RCS: @(#) $Id: tclOOCall.c,v 1.4 2008/05/31 11:42:17 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Structure containing a CallContext and any other values needed only during
+ * the construction of the CallContext.
+ */
+
+struct ChainBuilder {
+ CallChain *callChainPtr; /* The call chain being built. */
+ int filterLength; /* Number of entries in the call chain that
+ * are due to processing filters and not the
+ * main call chain. */
+ Object *oPtr; /* The object that we are building the chain
+ * for. */
+};
+
+/*
+ * Extra flags used for call chain management.
+ */
+
+#define DEFINITE_PROTECTED 0x100000
+#define DEFINITE_PUBLIC 0x200000
+#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
+#define SPECIAL (CONSTRUCTOR | DESTRUCTOR)
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static void AddClassFiltersToCallContext(Object *const oPtr,
+ Class *clsPtr, struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters);
+static void AddClassMethodNames(Class *clsPtr, const int flags,
+ Tcl_HashTable *const namesPtr);
+static inline void AddMethodToCallChain(Method *const mPtr,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters,
+ Class *const filterDecl);
+static inline void AddSimpleChainToCallContext(Object *const oPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters, int flags,
+ Class *const filterDecl);
+static void AddSimpleClassChainToCallContext(Class *classPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters, int flags,
+ Class *const filterDecl);
+static int CmpStr(const void *ptr1, const void *ptr2);
+static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
+static void FreeMethodNameRep(Tcl_Obj *objPtr);
+static inline int IsStillValid(CallChain *callPtr, Object *oPtr,
+ int flags, int reuseMask);
+static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
+
+/*
+ * Object type used to manage type caches attached to method names.
+ */
+
+static Tcl_ObjType methodNameType = {
+ "TclOO method name",
+ FreeMethodNameRep,
+ DupMethodNameRep,
+ NULL,
+ NULL
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteContext --
+ *
+ * Destroys a method call-chain context, which should not be in use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteContext(
+ CallContext *contextPtr)
+{
+ TclOODeleteChain(contextPtr->callPtr);
+ TclStackFree(contextPtr->oPtr->fPtr->interp, contextPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteChainCache --
+ *
+ * Destroy the cache of method call-chains.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteChainCache(
+ Tcl_HashTable *tablePtr)
+{
+ FOREACH_HASH_DECLS;
+ CallChain *callPtr;
+
+ FOREACH_HASH_VALUE(callPtr, tablePtr) {
+ if (callPtr) {
+ TclOODeleteChain(callPtr);
+ }
+ }
+ Tcl_DeleteHashTable(tablePtr);
+ ckfree((char *) tablePtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteChain --
+ *
+ * Destroys a method call-chain.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteChain(
+ CallChain *callPtr)
+{
+ if (--callPtr->refCount >= 1) {
+ return;
+ }
+ if (callPtr->chain != callPtr->staticChain) {
+ ckfree((char *) callPtr->chain);
+ }
+ ckfree((char *) callPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOStashContext --
+ *
+ * Saves a reference to a method call context in a Tcl_Obj's internal
+ * representation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+StashCallChain(
+ Tcl_Obj *objPtr,
+ CallChain *callPtr)
+{
+ callPtr->refCount++;
+ if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->typePtr = &methodNameType;
+ objPtr->internalRep.otherValuePtr = callPtr;
+}
+
+void
+TclOOStashContext(
+ Tcl_Obj *objPtr,
+ CallContext *contextPtr)
+{
+ StashCallChain(objPtr, contextPtr->callPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DupMethodNameRep, FreeMethodNameRep --
+ *
+ * Functions to implement the required parts of the Tcl_Obj guts needed
+ * for caching of method contexts in Tcl_Objs.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DupMethodNameRep(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *dstPtr)
+{
+ register CallChain *callPtr = srcPtr->internalRep.otherValuePtr;
+
+ dstPtr->typePtr = &methodNameType;
+ dstPtr->internalRep.otherValuePtr = callPtr;
+ callPtr->refCount++;
+}
+
+static void
+FreeMethodNameRep(
+ Tcl_Obj *objPtr)
+{
+ register CallChain *callPtr = objPtr->internalRep.otherValuePtr;
+
+ TclOODeleteChain(callPtr);
+ objPtr->internalRep.otherValuePtr = NULL;
+ objPtr->typePtr = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInvokeContext --
+ *
+ * Invokes a single step along a method call-chain context. Note that the
+ * invokation of a step along the chain can cause further steps along the
+ * chain to be invoked. Note that this function is written to be as light
+ * in stack usage as possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInvokeContext(
+ Tcl_Interp *const interp, /* Interpreter for error reporting, and many
+ * other sorts of context handling (e.g.,
+ * commands, variables) depending on method
+ * implementation. */
+ CallContext *const contextPtr,
+ /* The method call context. */
+ const int objc, /* The number of arguments. */
+ Tcl_Obj *const *const objv) /* The arguments as actually seen. */
+{
+ Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ const int isFirst = (contextPtr->index == 0);
+ const int isFilter =
+ contextPtr->callPtr->chain[contextPtr->index].isFilter;
+ int result, wasFilter;
+
+ /*
+ * If this is the first step along the chain, we preserve the method
+ * entries in the chain so that they do not get deleted out from under our
+ * feet.
+ */
+
+ if (isFirst) {
+ int i;
+
+ for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ AddRef(contextPtr->callPtr->chain[i].mPtr);
+ }
+
+ /*
+ * Ensure that the method name itself is part of the arguments when
+ * we're doing unknown processing.
+ */
+
+ if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) {
+ contextPtr->skip--;
+ }
+ }
+
+ /*
+ * Save whether we were in a filter and set up whether we are now.
+ */
+
+ wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;
+ if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ } else {
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ }
+
+ /*
+ * Run the method implementation.
+ */
+
+ result = mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+
+ /*
+ * Restore the old filter-ness, release any locks on method
+ * implementations, and return the result code.
+ */
+
+ if (wasFilter) {
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ } else {
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ }
+ if (isFirst) {
+ int i;
+
+ for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
+ }
+ }
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetSortedMethodList, TclOOGetSortedClassMethodList --
+ *
+ * Discovers the list of method names supported by an object or class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOGetSortedMethodList(
+ Object *oPtr, /* The object to get the method names for. */
+ int flags, /* Whether we just want the public method
+ * names. */
+ const char ***stringsPtr) /* Where to write a pointer to the array of
+ * strings to. */
+{
+ Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
+ * mapping. */
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *mixinPtr;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+ int isWantedIn;
+ void *isWanted;
+
+ Tcl_InitObjHashTable(&names);
+
+ /*
+ * Name the bits used in the names table values.
+ */
+#define IN_LIST 1
+#define NO_IMPLEMENTATION 2
+
+ /*
+ * Process method names due to the object.
+ */
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
+ int isNew;
+
+ if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
+ continue;
+ }
+ hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
+ if (isNew) {
+ isWantedIn = ((!(flags & PUBLIC_METHOD)
+ || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
+ isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
+ Tcl_SetHashValue(hPtr, (void *) isWantedIn);
+ }
+ }
+ }
+
+ /*
+ * Process method names due to private methods on the object's class.
+ */
+
+ if (flags & PRIVATE_METHOD) {
+ FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
+ if (mPtr->flags & PRIVATE_METHOD) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
+ if (isNew) {
+ isWantedIn = IN_LIST;
+ if (mPtr->typePtr == NULL) {
+ isWantedIn |= NO_IMPLEMENTATION;
+ }
+ Tcl_SetHashValue(hPtr, (void *) isWantedIn);
+ } else if (mPtr->typePtr != NULL) {
+ isWantedIn = (int) Tcl_GetHashValue(hPtr);
+ if (isWantedIn & NO_IMPLEMENTATION) {
+ isWantedIn &= ~NO_IMPLEMENTATION;
+ Tcl_SetHashValue(hPtr, (void *) isWantedIn);
+ }
+ }
+ }
+ }
+ }
+
+ /*
+ * Process (normal) method names from the class hierarchy and the mixin
+ * hierarchy.
+ */
+
+ AddClassMethodNames(oPtr->selfCls, flags, &names);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddClassMethodNames(mixinPtr, flags, &names);
+ }
+
+ /*
+ * See how many (visible) method names there are. If none, we do not (and
+ * should not) try to sort the list of them.
+ */
+
+ i = 0;
+ if (names.numEntries != 0) {
+ const char **strings;
+
+ /*
+ * We need to build the list of methods to sort. We will be using
+ * qsort() for this, because it is very unlikely that the list will be
+ * heavily sorted when it is long enough to matter.
+ */
+
+ strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+ FOREACH_HASH(namePtr, isWanted, &names) {
+ if (!(flags & PUBLIC_METHOD) || (((int)isWanted) & IN_LIST)) {
+ if (((int)isWanted) & NO_IMPLEMENTATION) {
+ continue;
+ }
+ strings[i++] = TclGetString(namePtr);
+ }
+ }
+
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names.
+ */
+
+ qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
+ *stringsPtr = strings;
+ }
+
+ Tcl_DeleteHashTable(&names);
+ return i;
+}
+
+int
+TclOOGetSortedClassMethodList(
+ Class *clsPtr, /* The class to get the method names for. */
+ int flags, /* Whether we just want the public method
+ * names. */
+ const char ***stringsPtr) /* Where to write a pointer to the array of
+ * strings to. */
+{
+ Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
+ * mapping. */
+ FOREACH_HASH_DECLS;
+ int i;
+ Tcl_Obj *namePtr;
+ void *isWanted;
+
+ Tcl_InitObjHashTable(&names);
+
+ /*
+ * Process method names from the class hierarchy and the mixin hierarchy.
+ */
+
+ AddClassMethodNames(clsPtr, flags, &names);
+
+ /*
+ * See how many (visible) method names there are. If none, we do not (and
+ * should not) try to sort the list of them.
+ */
+
+ i = 0;
+ if (names.numEntries != 0) {
+ const char **strings;
+
+ /*
+ * We need to build the list of methods to sort. We will be using
+ * qsort() for this, because it is very unlikely that the list will be
+ * heavily sorted when it is long enough to matter.
+ */
+
+ strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+ FOREACH_HASH(namePtr, isWanted, &names) {
+ if (!(flags & PUBLIC_METHOD) || (((int)isWanted) & IN_LIST)) {
+ if (((int)isWanted) & NO_IMPLEMENTATION) {
+ continue;
+ }
+ strings[i++] = TclGetString(namePtr);
+ }
+ }
+
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names.
+ */
+
+ qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
+ *stringsPtr = strings;
+ }
+
+ Tcl_DeleteHashTable(&names);
+ return i;
+}
+
+/* Comparator for GetSortedMethodList */
+static int
+CmpStr(
+ const void *ptr1,
+ const void *ptr2)
+{
+ const char **strPtr1 = (const char **) ptr1;
+ const char **strPtr2 = (const char **) ptr2;
+
+ return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassMethodNames --
+ *
+ * Adds the method names defined by a class (or its superclasses) to the
+ * collection being built. The collection is built in a hash table to
+ * ensure that duplicates are excluded. Helper for GetSortedMethodList().
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassMethodNames(
+ Class *clsPtr, /* Class to get method names from. */
+ const int flags, /* Whether we are interested in just the
+ * public method names. */
+ Tcl_HashTable *const namesPtr)
+ /* Reference to the hash table to put the
+ * information in. The hash table maps the
+ * Tcl_Obj * method name to an integral value
+ * describing whether the method is wanted.
+ * This ensures that public/private override
+ * semantics are handled correctly.*/
+{
+ /*
+ * Scope all declarations so that the compiler can stand a good chance of
+ * making the recursive step highly efficient. We also hand-implement the
+ * tail-recursive case using a while loop; C compilers typically cannot do
+ * tail-recursion optimization usefully.
+ */
+
+ if (clsPtr->mixins.num != 0) {
+ Class *mixinPtr;
+ int i;
+
+ /* TODO: Beware of infinite loops! */
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ AddClassMethodNames(mixinPtr, flags, namesPtr);
+ }
+ }
+
+ while (1) {
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+ if (isNew) {
+ int isWanted = (!(flags & PUBLIC_METHOD)
+ || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
+
+ Tcl_SetHashValue(hPtr, (void *) isWanted);
+ } else if ((((int)Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
+ && mPtr->typePtr != NULL) {
+ int isWanted = (int) Tcl_GetHashValue(hPtr);
+
+ isWanted &= ~NO_IMPLEMENTATION;
+ Tcl_SetHashValue(hPtr, (void *) isWanted);
+ }
+ }
+
+ if (clsPtr->superclasses.num != 1) {
+ break;
+ }
+ clsPtr = clsPtr->superclasses.list[0];
+ }
+ if (clsPtr->superclasses.num != 0) {
+ Class *superPtr;
+ int i;
+
+ FOREACH(superPtr, clsPtr->superclasses) {
+ AddClassMethodNames(superPtr, flags, namesPtr);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleChainToCallContext --
+ *
+ * The core of the call-chain construction engine, this handles calling a
+ * particular method on a particular object. Note that filters and
+ * unknown handling are already handled by the logic that uses this
+ * function.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddSimpleChainToCallContext(
+ Object *const oPtr, /* Object to add call chain entries for. */
+ Tcl_Obj *const methodNameObj,
+ /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what call chain entries
+ * have been processed. */
+ int flags, /* What sort of call chain are we building. */
+ Class *const filterDecl) /* The class that declared the filter. If
+ * NULL, either the filter was declared by the
+ * object or this isn't a filter. */
+{
+ int i;
+
+ if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
+ (char *) methodNameObj);
+
+ if (hPtr != NULL) {
+ Method *mPtr = Tcl_GetHashValue(hPtr);
+
+ if (flags & PUBLIC_METHOD) {
+ if (!(mPtr->flags & PUBLIC_METHOD)) {
+ return;
+ } else {
+ flags |= DEFINITE_PUBLIC;
+ }
+ } else {
+ flags |= DEFINITE_PROTECTED;
+ }
+ }
+ }
+ if (!(flags & SPECIAL)) {
+ Tcl_HashEntry *hPtr;
+ Class *mixinPtr;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+ }
+ if (oPtr->methodsPtr) {
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
+ if (hPtr != NULL) {
+ AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr,
+ doneFilters, filterDecl);
+ }
+ }
+ }
+ AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddMethodToCallChain --
+ *
+ * Utility method that manages the adding of a particular method
+ * implementation to a call-chain.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddMethodToCallChain(
+ Method *const mPtr, /* Actual method implementation to add to call
+ * chain (or NULL, a no-op). */
+ struct ChainBuilder *const cbPtr,
+ /* The call chain to add the method
+ * implementation to. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what filters have been
+ * processed. If NULL, not processing filters.
+ * Note that this function does not update
+ * this hashtable. */
+ Class *const filterDecl) /* The class that declared the filter. If
+ * NULL, either the filter was declared by the
+ * object or this isn't a filter. */
+{
+ register CallChain *callPtr = cbPtr->callChainPtr;
+ int i;
+
+ /*
+ * Return if this is just an entry used to record whether this is a public
+ * method. If so, there's nothing real to call and so nothing to add to
+ * the call chain.
+ */
+
+ if (mPtr == NULL || mPtr->typePtr == NULL) {
+ return;
+ }
+
+ /*
+ * Enforce real private method handling here. We will skip adding this
+ * method IF
+ * 1) we are not allowing private methods, AND
+ * 2) this is a private method, AND
+ * 3) this is a class method, AND
+ * 4) this method was not declared by the class of the current object.
+ *
+ * This does mean that only classes really handle private methods. This
+ * should be sufficient for [incr Tcl] support though.
+ */
+
+ if (!(callPtr->flags & PRIVATE_METHOD)
+ && (mPtr->flags & PRIVATE_METHOD)
+ && (mPtr->declaringClassPtr != NULL)
+ && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
+ return;
+ }
+
+ /*
+ * First test whether the method is already in the call chain. Skip over
+ * any leading filters.
+ */
+
+ for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
+ if (callPtr->chain[i].mPtr == mPtr &&
+ callPtr->chain[i].isFilter == (doneFilters != NULL)) {
+ /*
+ * Call chain semantics states that methods come as *late* in the
+ * call chain as possible. This is done by copying down the
+ * following methods. Note that this does not change the number of
+ * method invokations in the call chain; it just rearranges them.
+ */
+
+ Class *declCls = callPtr->chain[i].filterDeclarer;
+
+ for (; i+1<callPtr->numChain ; i++) {
+ callPtr->chain[i] = callPtr->chain[i+1];
+ }
+ callPtr->chain[i].mPtr = mPtr;
+ callPtr->chain[i].isFilter = (doneFilters != NULL);
+ callPtr->chain[i].filterDeclarer = declCls;
+ return;
+ }
+ }
+
+ /*
+ * Need to really add the method. This is made a bit more complex by the
+ * fact that we are using some "static" space initially, and only start
+ * realloc-ing if the chain gets long.
+ */
+
+ if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
+ callPtr->chain = (struct MInvoke *)
+ ckalloc(sizeof(struct MInvoke)*(callPtr->numChain+1));
+ memcpy(callPtr->chain, callPtr->staticChain,
+ sizeof(struct MInvoke) * callPtr->numChain);
+ } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
+ callPtr->chain = (struct MInvoke *) ckrealloc((char *) callPtr->chain,
+ sizeof(struct MInvoke) * (callPtr->numChain + 1));
+ }
+ callPtr->chain[i].mPtr = mPtr;
+ callPtr->chain[i].isFilter = (doneFilters != NULL);
+ callPtr->chain[i].filterDeclarer = filterDecl;
+ callPtr->numChain++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitCallChain --
+ * Encoding of the policy of how to set up a call chain. Doesn't populate
+ * the chain with the method implementation data.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+InitCallChain(
+ CallChain *callPtr,
+ Object *oPtr,
+ int flags)
+{
+ if (oPtr->flags & USE_CLASS_CACHE) {
+ oPtr = oPtr->selfCls->thisPtr;
+ }
+ callPtr->epoch = oPtr->fPtr->epoch;
+ callPtr->objectCreationEpoch = oPtr->creationEpoch;
+ callPtr->objectEpoch = oPtr->epoch;
+ callPtr->flags = flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
+ callPtr->refCount = 1;
+ callPtr->numChain = 0;
+ callPtr->chain = callPtr->staticChain;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * IsStillValid --
+ * Calculates whether the given call chain can be used for executing a
+ * method for the given object. The condition on a chain from a cached
+ * location being reusable is:
+ * - Refers to the same object (same creation epoch), and
+ * - Still across the same class structure (same global epoch), and
+ * - Still across the same object strucutre (same local epoch), and
+ * - No public/private/filter magic leakage (same flags, modulo the fact
+ * that a public chain will satisfy a non-public call).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+IsStillValid(
+ CallChain *callPtr,
+ Object *oPtr,
+ int flags,
+ int mask)
+{
+ if ((oPtr->flags & USE_CLASS_CACHE)) {
+ register Object *coPtr = oPtr->selfCls->thisPtr;
+
+ return ((callPtr->objectCreationEpoch == coPtr->creationEpoch)
+ && (callPtr->epoch == coPtr->fPtr->epoch)
+ && (callPtr->objectEpoch == coPtr->epoch)
+ && ((callPtr->flags & mask) == (flags & mask)));
+ }
+ return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
+ && (callPtr->epoch == oPtr->fPtr->epoch)
+ && (callPtr->objectEpoch == oPtr->epoch)
+ && ((callPtr->flags & mask) == (flags & mask)));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetCallContext --
+ *
+ * Responsible for constructing the call context, an ordered list of all
+ * method implementations to be called as part of a method invokation.
+ * This method is central to the whole operation of the OO system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+CallContext *
+TclOOGetCallContext(
+ Object *oPtr, /* The object to get the context for. */
+ Tcl_Obj *methodNameObj, /* The name of the method to get the context
+ * for. NULL when getting a constructor or
+ * destructor chain. */
+ int flags) /* What sort of context are we looking for.
+ * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
+ * PRIVATE_METHOD, DESTRUCTOR and
+ * FILTER_HANDLING are useful. */
+{
+ CallContext *contextPtr;
+ CallChain *callPtr;
+ struct ChainBuilder cb;
+ int i, count, doFilters;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashTable doneFilters;
+
+ if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
+ hPtr = NULL;
+ doFilters = 0;
+
+ /*
+ * Check if we have a cached valid constructor or destructor.
+ */
+
+ if (flags & CONSTRUCTOR) {
+ callPtr = oPtr->selfCls->constructorChainPtr;
+ if ((callPtr != NULL)
+ && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
+ && (callPtr->epoch == oPtr->fPtr->epoch)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ } else if (flags & DESTRUCTOR) {
+ callPtr = oPtr->selfCls->destructorChainPtr;
+ if ((oPtr->mixins.num == 0) && (callPtr != NULL)
+ && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
+ && (callPtr->epoch == oPtr->fPtr->epoch)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ }
+ } else {
+ /*
+ * Check if we can get the chain out of the Tcl_Obj method name or out
+ * of the cache. This is made a bit more complex by the fact that
+ * there are multiple different layers of cache (in the Tcl_Obj, in
+ * the object, and in the class).
+ */
+
+ const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+
+ if (methodNameObj->typePtr == &methodNameType) {
+ callPtr = methodNameObj->internalRep.otherValuePtr;
+ if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ methodNameObj->typePtr->freeIntRepProc(methodNameObj);
+ }
+
+ if (oPtr->flags & USE_CLASS_CACHE) {
+ if (oPtr->selfCls->classChainCache != NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
+ (char *) methodNameObj);
+ } else {
+ hPtr = NULL;
+ }
+ } else {
+ if (oPtr->chainCache != NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->chainCache,
+ (char *) methodNameObj);
+ } else {
+ hPtr = NULL;
+ }
+ }
+
+ if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
+ callPtr = Tcl_GetHashValue(hPtr);
+ if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
+ callPtr->refCount++;
+ goto returnContext;
+ }
+ Tcl_SetHashValue(hPtr, NULL);
+ TclOODeleteChain(callPtr);
+ }
+
+ doFilters = 1;
+ }
+
+ callPtr = (CallChain *) ckalloc(sizeof(CallChain));
+ InitCallChain(callPtr, oPtr, flags);
+
+ cb.callChainPtr = callPtr;
+ cb.filterLength = 0;
+ cb.oPtr = oPtr;
+
+ /*
+ * Add all defined filters (if any, and if we're going to be processing
+ * them; they're not processed for constructors, destructors or when we're
+ * in the middle of processing a filter).
+ */
+
+ if (doFilters) {
+ Tcl_Obj *filterObj;
+ Class *mixinPtr;
+
+ doFilters = 1;
+ Tcl_InitObjHashTable(&doneFilters);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters);
+ }
+ FOREACH(filterObj, oPtr->filters) {
+ AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
+ NULL);
+ }
+ AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters);
+ Tcl_DeleteHashTable(&doneFilters);
+ }
+ count = cb.filterLength = callPtr->numChain;
+
+ /*
+ * Add the actual method implementations.
+ */
+
+ AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+
+ /*
+ * Check to see if the method has no implementation. If so, we probably
+ * need to add in a call to the unknown method. Otherwise, set up the
+ * cacheing of the method implementation (if relevant).
+ */
+
+ if (count == callPtr->numChain) {
+ /*
+ * Method does not actually exist. If we're dealing with constructors
+ * or destructors, this isn't a problem.
+ */
+
+ if (flags & SPECIAL) {
+ TclOODeleteChain(callPtr);
+ return NULL;
+ }
+ AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
+ &cb, NULL, 0, NULL);
+ callPtr->flags |= OO_UNKNOWN_METHOD;
+ callPtr->epoch = -1;
+ if (count == callPtr->numChain) {
+ TclOODeleteChain(callPtr);
+ return NULL;
+ }
+ } else if (doFilters) {
+ if (hPtr == NULL) {
+ if (oPtr->flags & USE_CLASS_CACHE) {
+ if (oPtr->selfCls->classChainCache == NULL) {
+ oPtr->selfCls->classChainCache = (Tcl_HashTable *)
+ ckalloc(sizeof(Tcl_HashTable));
+
+ Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
+ (char *) methodNameObj, &i);
+ } else {
+ if (oPtr->chainCache == NULL) {
+ oPtr->chainCache = (Tcl_HashTable *)
+ ckalloc(sizeof(Tcl_HashTable));
+
+ Tcl_InitObjHashTable(oPtr->chainCache);
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
+ (char *) methodNameObj, &i);
+ }
+ }
+ callPtr->refCount++;
+ Tcl_SetHashValue(hPtr, callPtr);
+ StashCallChain(methodNameObj, callPtr);
+ } else if (flags & CONSTRUCTOR) {
+ if (oPtr->selfCls->constructorChainPtr) {
+ TclOODeleteChain(oPtr->selfCls->constructorChainPtr);
+ }
+ oPtr->selfCls->constructorChainPtr = callPtr;
+ callPtr->refCount++;
+ } else if ((flags & DESTRUCTOR) && oPtr->mixins.num == 0) {
+ if (oPtr->selfCls->destructorChainPtr) {
+ TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
+ }
+ oPtr->selfCls->destructorChainPtr = callPtr;
+ callPtr->refCount++;
+ }
+
+ returnContext:
+ contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
+ contextPtr->oPtr = oPtr;
+ contextPtr->callPtr = callPtr;
+ contextPtr->skip = 2;
+ contextPtr->index = 0;
+ return contextPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassFiltersToCallContext --
+ *
+ * Logic to make extracting all the filters from the class context much
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassFiltersToCallContext(
+ Object *const oPtr, /* Object that the filters operate on. */
+ Class *clsPtr, /* Class to get the filters from. */
+ struct ChainBuilder *const cbPtr,
+ /* Context to fill with call chain entries. */
+ Tcl_HashTable *const doneFilters)
+ /* Where to record what filters have been
+ * processed. Keys are objects, values are
+ * ignored. */
+{
+ int i;
+ Class *superPtr, *mixinPtr;
+ Tcl_Obj *filterObj;
+
+ tailRecurse:
+ if (clsPtr == NULL) {
+ return;
+ }
+
+ /*
+ * Add all the filters defined by classes mixed into the main class
+ * hierarchy.
+ */
+
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters);
+ }
+
+ /*
+ * Add all the class filters from the current class. Note that the filters
+ * are added starting at the object root, as this allows the object to
+ * override how filters work to extend their behaviour.
+ */
+
+ FOREACH(filterObj, clsPtr->filters) {
+ int isNew;
+
+ (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
+ if (isNew) {
+ AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters,
+ 0, clsPtr);
+ }
+ }
+
+ /*
+ * Now process the recursive case. Notice the tail-call optimization.
+ */
+
+ switch (clsPtr->superclasses.num) {
+ case 1:
+ clsPtr = clsPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, clsPtr->superclasses) {
+ AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassChainToCallContext --
+ *
+ * Construct a call-chain from a class hierarchy.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleClassChainToCallContext(
+ Class *classPtr, /* Class to add the call chain entries for. */
+ Tcl_Obj *const methodNameObj,
+ /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what call chain entries
+ * have been processed. */
+ int flags, /* What sort of call chain are we building. */
+ Class *const filterDecl) /* The class that declared the filter. If
+ * NULL, either the filter was declared by the
+ * object or this isn't a filter. */
+{
+ int i;
+ Class *superPtr;
+
+ /*
+ * We hard-code the tail-recursive form. It's by far the most common case
+ * *and* it is much more gentle on the stack.
+ */
+
+ tailRecurse:
+ if (flags & CONSTRUCTOR) {
+ AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
+ filterDecl);
+
+ } else if (flags & DESTRUCTOR) {
+ AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
+ filterDecl);
+ } else {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+ (char *) methodNameObj);
+
+ if (hPtr != NULL) {
+ register Method *mPtr = Tcl_GetHashValue(hPtr);
+
+ if (!(flags & KNOWN_STATE)) {
+ if (flags & PUBLIC_METHOD) {
+ if (mPtr->flags & PUBLIC_METHOD) {
+ flags |= DEFINITE_PUBLIC;
+ } else {
+ return;
+ }
+ } else {
+ flags |= DEFINITE_PROTECTED;
+ }
+ }
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl);
+ }
+ }
+
+ FOREACH(superPtr, classPtr->mixins) {
+ AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
+ doneFilters, flags, filterDecl);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
new file mode 100644
index 0000000..d67333b
--- /dev/null
+++ b/generic/tclOODecls.h
@@ -0,0 +1,282 @@
+/*
+ * $Id: tclOODecls.h,v 1.1 2008/05/31 11:42:18 dkf Exp $
+ *
+ * This file is (mostly) automatically generated from tclOO.decls.
+ */
+
+
+#if defined(USE_TCLOO_STUBS)
+extern const char *TclOOInitializeStubs(
+ Tcl_Interp *, const char *version, int epoch, int revision);
+#define Tcl_OOInitStubs(interp) TclOOInitializeStubs( \
+ interp, TCLOO_VERSION, TCLOO_STUBS_EPOCH, TCLOO_STUBS_REVISION)
+#else
+#define Tcl_OOInitStubs(interp) Tcl_PkgRequire(interp, "TclOO", TCLOO_VERSION)
+#endif
+
+
+/* !BEGIN!: Do not edit below this line. */
+
+#define TCLOO_STUBS_EPOCH 0
+#define TCLOO_STUBS_REVISION 44
+
+#if !defined(USE_TCLOO_STUBS)
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+TCLOOAPI Tcl_Object Tcl_CopyObjectInstance (Tcl_Interp * interp,
+ Tcl_Object sourceObject,
+ const char * targetName,
+ const char * targetNamespaceName);
+/* 1 */
+TCLOOAPI Tcl_Object Tcl_GetClassAsObject (Tcl_Class clazz);
+/* 2 */
+TCLOOAPI Tcl_Class Tcl_GetObjectAsClass (Tcl_Object object);
+/* 3 */
+TCLOOAPI Tcl_Command Tcl_GetObjectCommand (Tcl_Object object);
+/* 4 */
+TCLOOAPI Tcl_Object Tcl_GetObjectFromObj (Tcl_Interp * interp,
+ Tcl_Obj * objPtr);
+/* 5 */
+TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace (Tcl_Object object);
+/* 6 */
+TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass (Tcl_Method method);
+/* 7 */
+TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject (Tcl_Method method);
+/* 8 */
+TCLOOAPI int Tcl_MethodIsPublic (Tcl_Method method);
+/* 9 */
+TCLOOAPI int Tcl_MethodIsType (Tcl_Method method,
+ const Tcl_MethodType * typePtr,
+ ClientData * clientDataPtr);
+/* 10 */
+TCLOOAPI Tcl_Obj * Tcl_MethodName (Tcl_Method method);
+/* 11 */
+TCLOOAPI Tcl_Method Tcl_NewInstanceMethod (Tcl_Interp * interp,
+ Tcl_Object object, Tcl_Obj * nameObj,
+ int isPublic, const Tcl_MethodType * typePtr,
+ ClientData clientData);
+/* 12 */
+TCLOOAPI Tcl_Method Tcl_NewMethod (Tcl_Interp * interp, Tcl_Class cls,
+ Tcl_Obj * nameObj, int isPublic,
+ const Tcl_MethodType * typePtr,
+ ClientData clientData);
+/* 13 */
+TCLOOAPI Tcl_Object Tcl_NewObjectInstance (Tcl_Interp * interp,
+ Tcl_Class cls, const char * nameStr,
+ const char * nsNameStr, int objc,
+ Tcl_Obj *const * objv, int skip);
+/* 14 */
+TCLOOAPI int Tcl_ObjectDeleted (Tcl_Object object);
+/* 15 */
+TCLOOAPI int Tcl_ObjectContextIsFiltering (
+ Tcl_ObjectContext context);
+/* 16 */
+TCLOOAPI Tcl_Method Tcl_ObjectContextMethod (Tcl_ObjectContext context);
+/* 17 */
+TCLOOAPI Tcl_Object Tcl_ObjectContextObject (Tcl_ObjectContext context);
+/* 18 */
+TCLOOAPI int Tcl_ObjectContextSkippedArgs (
+ Tcl_ObjectContext context);
+/* 19 */
+TCLOOAPI ClientData Tcl_ClassGetMetadata (Tcl_Class clazz,
+ const Tcl_ObjectMetadataType * typePtr);
+/* 20 */
+TCLOOAPI void Tcl_ClassSetMetadata (Tcl_Class clazz,
+ const Tcl_ObjectMetadataType * typePtr,
+ ClientData metadata);
+/* 21 */
+TCLOOAPI ClientData Tcl_ObjectGetMetadata (Tcl_Object object,
+ const Tcl_ObjectMetadataType * typePtr);
+/* 22 */
+TCLOOAPI void Tcl_ObjectSetMetadata (Tcl_Object object,
+ const Tcl_ObjectMetadataType * typePtr,
+ ClientData metadata);
+/* 23 */
+TCLOOAPI int Tcl_ObjectContextInvokeNext (Tcl_Interp * interp,
+ Tcl_ObjectContext context, int objc,
+ Tcl_Obj *const * objv, int skip);
+/* 24 */
+TCLOOAPI Tcl_ObjectMapMethodNameProc Tcl_ObjectGetMethodNameMapper (
+ Tcl_Object object);
+/* 25 */
+TCLOOAPI void Tcl_ObjectSetMethodNameMapper (Tcl_Object object,
+ Tcl_ObjectMapMethodNameProc mapMethodNameProc);
+/* 26 */
+TCLOOAPI void Tcl_ClassSetConstructor (Tcl_Interp * interp,
+ Tcl_Class clazz, Tcl_Method method);
+/* 27 */
+TCLOOAPI void Tcl_ClassSetDestructor (Tcl_Interp * interp,
+ Tcl_Class clazz, Tcl_Method method);
+
+#endif /* !defined(USE_TCLOO_STUBS) */
+
+typedef struct TclOOStubs {
+ int magic;
+ int epoch;
+ int revision;
+ struct TclOOStubHooks *hooks;
+
+ Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp * interp, Tcl_Object sourceObject, const char * targetName, const char * targetNamespaceName); /* 0 */
+ Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */
+ Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */
+ Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */
+ Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr); /* 4 */
+ Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
+ Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
+ Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
+ int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
+ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType * typePtr, ClientData * clientDataPtr); /* 9 */
+ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
+ Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp * interp, Tcl_Object object, Tcl_Obj * nameObj, int isPublic, const Tcl_MethodType * typePtr, ClientData clientData); /* 11 */
+ Tcl_Method (*tcl_NewMethod) (Tcl_Interp * interp, Tcl_Class cls, Tcl_Obj * nameObj, int isPublic, const Tcl_MethodType * typePtr, ClientData clientData); /* 12 */
+ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp * interp, Tcl_Class cls, const char * nameStr, const char * nsNameStr, int objc, Tcl_Obj *const * objv, int skip); /* 13 */
+ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
+ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
+ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */
+ Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */
+ int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
+ ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType * typePtr); /* 19 */
+ void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType * typePtr, ClientData metadata); /* 20 */
+ ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType * typePtr); /* 21 */
+ void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType * typePtr, ClientData metadata); /* 22 */
+ int (*tcl_ObjectContextInvokeNext) (Tcl_Interp * interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const * objv, int skip); /* 23 */
+ Tcl_ObjectMapMethodNameProc (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */
+ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc mapMethodNameProc); /* 25 */
+ void (*tcl_ClassSetConstructor) (Tcl_Interp * interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
+ void (*tcl_ClassSetDestructor) (Tcl_Interp * interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
+} TclOOStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern const TclOOStubs *tclOOStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCLOO_STUBS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifndef Tcl_CopyObjectInstance
+#define Tcl_CopyObjectInstance \
+ (tclOOStubsPtr->tcl_CopyObjectInstance) /* 0 */
+#endif
+#ifndef Tcl_GetClassAsObject
+#define Tcl_GetClassAsObject \
+ (tclOOStubsPtr->tcl_GetClassAsObject) /* 1 */
+#endif
+#ifndef Tcl_GetObjectAsClass
+#define Tcl_GetObjectAsClass \
+ (tclOOStubsPtr->tcl_GetObjectAsClass) /* 2 */
+#endif
+#ifndef Tcl_GetObjectCommand
+#define Tcl_GetObjectCommand \
+ (tclOOStubsPtr->tcl_GetObjectCommand) /* 3 */
+#endif
+#ifndef Tcl_GetObjectFromObj
+#define Tcl_GetObjectFromObj \
+ (tclOOStubsPtr->tcl_GetObjectFromObj) /* 4 */
+#endif
+#ifndef Tcl_GetObjectNamespace
+#define Tcl_GetObjectNamespace \
+ (tclOOStubsPtr->tcl_GetObjectNamespace) /* 5 */
+#endif
+#ifndef Tcl_MethodDeclarerClass
+#define Tcl_MethodDeclarerClass \
+ (tclOOStubsPtr->tcl_MethodDeclarerClass) /* 6 */
+#endif
+#ifndef Tcl_MethodDeclarerObject
+#define Tcl_MethodDeclarerObject \
+ (tclOOStubsPtr->tcl_MethodDeclarerObject) /* 7 */
+#endif
+#ifndef Tcl_MethodIsPublic
+#define Tcl_MethodIsPublic \
+ (tclOOStubsPtr->tcl_MethodIsPublic) /* 8 */
+#endif
+#ifndef Tcl_MethodIsType
+#define Tcl_MethodIsType \
+ (tclOOStubsPtr->tcl_MethodIsType) /* 9 */
+#endif
+#ifndef Tcl_MethodName
+#define Tcl_MethodName \
+ (tclOOStubsPtr->tcl_MethodName) /* 10 */
+#endif
+#ifndef Tcl_NewInstanceMethod
+#define Tcl_NewInstanceMethod \
+ (tclOOStubsPtr->tcl_NewInstanceMethod) /* 11 */
+#endif
+#ifndef Tcl_NewMethod
+#define Tcl_NewMethod \
+ (tclOOStubsPtr->tcl_NewMethod) /* 12 */
+#endif
+#ifndef Tcl_NewObjectInstance
+#define Tcl_NewObjectInstance \
+ (tclOOStubsPtr->tcl_NewObjectInstance) /* 13 */
+#endif
+#ifndef Tcl_ObjectDeleted
+#define Tcl_ObjectDeleted \
+ (tclOOStubsPtr->tcl_ObjectDeleted) /* 14 */
+#endif
+#ifndef Tcl_ObjectContextIsFiltering
+#define Tcl_ObjectContextIsFiltering \
+ (tclOOStubsPtr->tcl_ObjectContextIsFiltering) /* 15 */
+#endif
+#ifndef Tcl_ObjectContextMethod
+#define Tcl_ObjectContextMethod \
+ (tclOOStubsPtr->tcl_ObjectContextMethod) /* 16 */
+#endif
+#ifndef Tcl_ObjectContextObject
+#define Tcl_ObjectContextObject \
+ (tclOOStubsPtr->tcl_ObjectContextObject) /* 17 */
+#endif
+#ifndef Tcl_ObjectContextSkippedArgs
+#define Tcl_ObjectContextSkippedArgs \
+ (tclOOStubsPtr->tcl_ObjectContextSkippedArgs) /* 18 */
+#endif
+#ifndef Tcl_ClassGetMetadata
+#define Tcl_ClassGetMetadata \
+ (tclOOStubsPtr->tcl_ClassGetMetadata) /* 19 */
+#endif
+#ifndef Tcl_ClassSetMetadata
+#define Tcl_ClassSetMetadata \
+ (tclOOStubsPtr->tcl_ClassSetMetadata) /* 20 */
+#endif
+#ifndef Tcl_ObjectGetMetadata
+#define Tcl_ObjectGetMetadata \
+ (tclOOStubsPtr->tcl_ObjectGetMetadata) /* 21 */
+#endif
+#ifndef Tcl_ObjectSetMetadata
+#define Tcl_ObjectSetMetadata \
+ (tclOOStubsPtr->tcl_ObjectSetMetadata) /* 22 */
+#endif
+#ifndef Tcl_ObjectContextInvokeNext
+#define Tcl_ObjectContextInvokeNext \
+ (tclOOStubsPtr->tcl_ObjectContextInvokeNext) /* 23 */
+#endif
+#ifndef Tcl_ObjectGetMethodNameMapper
+#define Tcl_ObjectGetMethodNameMapper \
+ (tclOOStubsPtr->tcl_ObjectGetMethodNameMapper) /* 24 */
+#endif
+#ifndef Tcl_ObjectSetMethodNameMapper
+#define Tcl_ObjectSetMethodNameMapper \
+ (tclOOStubsPtr->tcl_ObjectSetMethodNameMapper) /* 25 */
+#endif
+#ifndef Tcl_ClassSetConstructor
+#define Tcl_ClassSetConstructor \
+ (tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */
+#endif
+#ifndef Tcl_ClassSetDestructor
+#define Tcl_ClassSetDestructor \
+ (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
+#endif
+
+#endif /* defined(USE_TCLOO_STUBS) */
+
+/* !END!: Do not edit above this line. */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
new file mode 100644
index 0000000..77f9970
--- /dev/null
+++ b/generic/tclOODefineCmds.c
@@ -0,0 +1,1831 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ * This file contains the implementation of the ::oo::define command,
+ * part of the object-system core (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006-2008 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.
+ *
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.4 2008/05/31 11:42:18 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Forward declarations.
+ */
+
+static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
+static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
+ Tcl_Namespace *const namespacePtr);
+static inline int InitDefineContext(Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr, Object *oPtr,
+ int objc, Tcl_Obj *const objv[]);
+static inline void RecomputeClassCacheFlag(Object *oPtr);
+static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
+ int useClass, Tcl_Obj *const fromPtr,
+ Tcl_Obj *const toPtr);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * BumpGlobalEpoch --
+ * Utility that ensures that call chains that are invalid will get thrown
+ * away at an appropriate time. Note that exactly which epoch gets
+ * advanced will depend on exactly what the class is tangled up in; in
+ * the worst case, the simplest option is to advance the global epoch,
+ * causing *everything* to be thrown away on next usage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+BumpGlobalEpoch(
+ Tcl_Interp *interp,
+ Class *classPtr)
+{
+ if (classPtr != NULL
+ && classPtr->subclasses.num == 0
+ && classPtr->instances.num == 0
+ && classPtr->mixinSubs.num == 0) {
+ /*
+ * If a class has no subclasses or instances, and is not mixed into
+ * anything, a change to its structure does not require us to
+ * invalidate any call chains. Note that we still bump our object's
+ * epoch if it has any mixins; the relation between a class and its
+ * representative object is special. But it won't hurt.
+ */
+
+ if (classPtr->thisPtr->mixins.num > 0) {
+ classPtr->thisPtr->epoch++;
+ }
+ return;
+ }
+
+ /*
+ * Either there's no class (?!) or we're reconfiguring something that is
+ * in use. Force regeneration of call chains.
+ */
+
+ TclOOGetFoundation(interp)->epoch++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RecomputeClassCacheFlag --
+ * Determine whether the object is prototypical of its class, and hence
+ * able to use the class's method chain cache.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RecomputeClassCacheFlag(
+ Object *oPtr)
+{
+ if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0)
+ && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) {
+ oPtr->flags |= USE_CLASS_CACHE;
+ } else {
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectSetFilters --
+ * Install a list of filter method names into an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOObjectSetFilters(
+ Object *oPtr,
+ int numFilters,
+ Tcl_Obj *const *filters)
+{
+ int i;
+
+ if (oPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ }
+
+ if (numFilters == 0) {
+ /*
+ * No list of filters was supplied, so we're deleting filters.
+ */
+
+ ckfree((char *) oPtr->filters.list);
+ oPtr->filters.list = NULL;
+ oPtr->filters.num = 0;
+ RecomputeClassCacheFlag(oPtr);
+ } else {
+ /*
+ * We've got a list of filters, so we're creating filters.
+ */
+
+ Tcl_Obj **filtersList;
+ int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
+
+ if (oPtr->filters.num == 0) {
+ filtersList = (Tcl_Obj **) ckalloc(size);
+ } else {
+ filtersList = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->filters.list, size);
+ }
+ for (i=0 ; i<numFilters ; i++) {
+ filtersList[i] = filters[i];
+ Tcl_IncrRefCount(filters[i]);
+ }
+ oPtr->filters.list = filtersList;
+ oPtr->filters.num = numFilters;
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ oPtr->epoch++; /* Only this object can be affected. */
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassSetFilters --
+ * Install a list of filter method names into a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOClassSetFilters(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ int numFilters,
+ Tcl_Obj *const *filters)
+{
+ int i;
+
+ if (classPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, classPtr->filters) {
+ Tcl_DecrRefCount(filterObj);
+ }
+ }
+
+ if (numFilters == 0) {
+ /*
+ * No list of filters was supplied, so we're deleting filters.
+ */
+
+ ckfree((char *) classPtr->filters.list);
+ classPtr->filters.list = NULL;
+ classPtr->filters.num = 0;
+ } else {
+ /*
+ * We've got a list of filters, so we're creating filters.
+ */
+
+ Tcl_Obj **filtersList;
+ int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
+
+ if (classPtr->filters.num == 0) {
+ filtersList = (Tcl_Obj **) ckalloc(size);
+ } else {
+ filtersList = (Tcl_Obj **)
+ ckrealloc((char *) classPtr->filters.list, size);
+ }
+ for (i=0 ; i<numFilters ; i++) {
+ filtersList[i] = filters[i];
+ Tcl_IncrRefCount(filters[i]);
+ }
+ classPtr->filters.list = filtersList;
+ classPtr->filters.num = numFilters;
+ }
+
+ /*
+ * There may be many objects affected, so bump the global epoch.
+ */
+
+ BumpGlobalEpoch(interp, classPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectSetMixins --
+ * Install a list of mixin classes into an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOObjectSetMixins(
+ Object *oPtr,
+ int numMixins,
+ Class *const *mixins)
+{
+ Class *mixinPtr;
+ int i;
+
+ if (numMixins == 0) {
+ if (oPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ ckfree((char *) oPtr->mixins.list);
+ oPtr->mixins.num = 0;
+ }
+ RecomputeClassCacheFlag(oPtr);
+ } else {
+ if (oPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr != oPtr->selfCls) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ }
+ oPtr->mixins.list = (Class **)
+ ckrealloc((char *) oPtr->mixins.list,
+ sizeof(Class *) * numMixins);
+ } else {
+ oPtr->mixins.list = (Class **)
+ ckalloc(sizeof(Class *) * numMixins);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ oPtr->mixins.num = numMixins;
+ memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr != oPtr->selfCls) {
+ TclOOAddToInstances(oPtr, mixinPtr);
+ }
+ }
+ }
+ oPtr->epoch++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassSetMixins --
+ * Install a list of mixin classes into a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOClassSetMixins(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ int numMixins,
+ Class *const *mixins)
+{
+ Class *mixinPtr;
+ int i;
+
+ if (numMixins == 0) {
+ if (classPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, classPtr->mixins) {
+ TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ }
+ ckfree((char *) classPtr->mixins.list);
+ classPtr->mixins.num = 0;
+ }
+ } else {
+ if (classPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, classPtr->mixins) {
+ TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ }
+ classPtr->mixins.list = (Class **)
+ ckrealloc((char *) classPtr->mixins.list,
+ sizeof(Class *) * numMixins);
+ } else {
+ classPtr->mixins.list = (Class **)
+ ckalloc(sizeof(Class *) * numMixins);
+ }
+ classPtr->mixins.num = numMixins;
+ memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
+ FOREACH(mixinPtr, classPtr->mixins) {
+ TclOOAddToMixinSubs(classPtr, mixinPtr);
+ }
+ }
+ BumpGlobalEpoch(interp, classPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RenameDeleteMethod --
+ * Core of the code to rename and delete methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+RenameDeleteMethod(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ int useClass,
+ Tcl_Obj *const fromPtr,
+ Tcl_Obj *const toPtr)
+{
+ Tcl_HashEntry *hPtr, *newHPtr = NULL;
+ Method *mPtr;
+ int isNew;
+
+ if (!useClass) {
+ if (!oPtr->methodsPtr) {
+ noSuchMethod:
+ Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
+ " does not exist", NULL);
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
+ if (hPtr == NULL) {
+ goto noSuchMethod;
+ }
+ if (toPtr) {
+ newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr,
+ &isNew);
+ if (hPtr == newHPtr) {
+ renameToSelf:
+ Tcl_AppendResult(interp, "cannot rename method to itself",
+ NULL);
+ return TCL_ERROR;
+ } else if (!isNew) {
+ renameToExisting:
+ Tcl_AppendResult(interp, "method called ",
+ TclGetString(toPtr), " already exists", NULL);
+ return TCL_ERROR;
+ }
+ }
+ } else {
+ hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+ (char *) fromPtr);
+ if (hPtr == NULL) {
+ goto noSuchMethod;
+ }
+ if (toPtr) {
+ newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods,
+ (char *) toPtr, &isNew);
+ if (hPtr == newHPtr) {
+ goto renameToSelf;
+ } else if (!isNew) {
+ goto renameToExisting;
+ }
+ }
+ }
+
+ /*
+ * Complete the splicing by changing the method's name.
+ */
+
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (toPtr) {
+ Tcl_IncrRefCount(toPtr);
+ Tcl_DecrRefCount(mPtr->namePtr);
+ mPtr->namePtr = toPtr;
+ Tcl_SetHashValue(newHPtr, mPtr);
+ } else {
+ if (!useClass) {
+ RecomputeClassCacheFlag(oPtr);
+ }
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashEntry(hPtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOUnknownDefinition --
+ * Handles what happens when an unknown command is encountered during the
+ * processing of a definition script. Works by finding a command in the
+ * operating definition namespace that the requested command is a unique
+ * prefix of.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOUnknownDefinition(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ int soughtLen;
+ const char *soughtStr, *matchedStr = NULL;
+
+ if (objc < 2) {
+ Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+ return TCL_ERROR;
+ }
+ if (TclOOGetDefineCmdContext(interp) == NULL) {
+ return TCL_ERROR;
+ }
+
+ soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
+ if (soughtLen == 0) {
+ goto noMatch;
+ }
+ hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ while (hPtr != NULL) {
+ const char *nameStr = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
+
+ if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
+ if (matchedStr != NULL) {
+ goto noMatch;
+ }
+ matchedStr = nameStr;
+ }
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+
+ if (matchedStr != NULL) {
+ /*
+ * Got one match, and only one match!
+ */
+
+ Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+ int result;
+
+ newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
+ Tcl_IncrRefCount(newObjv[0]);
+ if (objc > 2) {
+ memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+ }
+ result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
+ Tcl_DecrRefCount(newObjv[0]);
+ TclStackFree(interp, newObjv);
+ return result;
+ }
+
+ noMatch:
+ Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FindCommand --
+ * Specialized version of Tcl_FindCommand that handles command prefixes
+ * and disallows namespace magic.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Command
+FindCommand(
+ Tcl_Interp *interp,
+ Tcl_Obj *stringObj,
+ Tcl_Namespace *const namespacePtr)
+{
+ int length;
+ const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
+ register Namespace *const nsPtr = (Namespace *) namespacePtr;
+ FOREACH_HASH_DECLS;
+ Tcl_Command cmd, cmd2;
+
+ /*
+ * If someone is playing games, we stop playing right now.
+ */
+
+ if (string[0] == '\0' || strstr(string, "::") != NULL) {
+ return NULL;
+ }
+
+ /*
+ * Do the exact lookup first.
+ */
+
+ cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY);
+ if (cmd != NULL) {
+ return cmd;
+ }
+
+ /*
+ * Bother, need to perform an approximate match. Iterate across the hash
+ * table of commands in the namespace.
+ */
+
+ FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) {
+ if (strncmp(string, nameStr, length) == 0) {
+ if (cmd != NULL) {
+ return NULL;
+ }
+ cmd = cmd2;
+ }
+ }
+
+ /*
+ * Either we found one thing or we found nothing. Either way, return it.
+ */
+
+ return cmd;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitDefineContext --
+ * Does the magic incantations necessary to push the special stack frame
+ * used when processing object definitions. It is up to the caller to
+ * dispose of the frame (with TclPopStackFrame) when finished.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+InitDefineContext(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr,
+ Object *oPtr,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CallFrame *framePtr, **framePtrPtr = &framePtr;
+ int result;
+
+ /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
+
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ namespacePtr, FRAME_IS_OO_DEFINE);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->clientData = oPtr;
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetDefineCmdContext --
+ * Extracts the magic token from the current stack frame, or returns NULL
+ * (and leaves an error message) otherwise.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+TclOOGetDefineCmdContext(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if ((iPtr->framePtr == NULL)
+ || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+ Tcl_AppendResult(interp, "this command may only be called from within"
+ " the context of an ::oo::define or ::oo::objdefine command",
+ NULL);
+ return NULL;
+ }
+ return (Tcl_Object) iPtr->framePtr->clientData;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineObjCmd --
+ * Implementation of the "oo::define" command. Works by effectively doing
+ * the same as 'namespace eval', but with extra magic applied so that the
+ * object to be modified is known to the commands in the target
+ * namespace. Also does ensemble-like tricks with dispatch so that error
+ * messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ int result;
+ Object *oPtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, TclGetString(objv[1]),
+ " does not refer to a class", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the oo::define namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
+ return TCL_ERROR;
+ }
+
+ AddRef(oPtr);
+ if (objc == 3) {
+ result = TclEvalObjEx(interp, objv[2], 0,
+ ((Interp *)interp)->cmdFramePtr, 2);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+ int limit = 60;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), interp->errorLine));
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 3;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 3) {
+ iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 2;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[2], fPtr->defineNs);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+ Tcl_DecrRefCount(objPtr);
+ }
+ DelRef(oPtr);
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjDefObjCmd --
+ * Implementation of the "oo::objdefine" command. Works by effectively
+ * doing the same as 'namespace eval', but with extra magic applied so
+ * that the object to be modified is known to the commands in the target
+ * namespace. Also does ensemble-like tricks with dispatch so that error
+ * messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOObjDefObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ int result;
+ Object *oPtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the oo::objdefine namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ return TCL_ERROR;
+ }
+
+ AddRef(oPtr);
+ if (objc == 3) {
+ result = TclEvalObjEx(interp, objv[2], 0,
+ ((Interp *)interp)->cmdFramePtr, 2);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+ int limit = 60;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), interp->errorLine));
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 3;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 3) {
+ iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 2;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[2], fPtr->objdefNs);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+ Tcl_DecrRefCount(objPtr);
+ }
+ DelRef(oPtr);
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSelfObjCmd --
+ * Implementation of the "self" subcommand of the "oo::define" command.
+ * Works by effectively doing the same as 'namespace eval', but with
+ * extra magic applied so that the object to be modified is known to the
+ * commands in the target namespace. Also does ensemble-like tricks with
+ * dispatch so that error messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ int result;
+ Object *oPtr;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the oo::objdefine namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ return TCL_ERROR;
+ }
+
+ AddRef(oPtr);
+ if (objc == 2) {
+ result = TclEvalObjEx(interp, objv[1], 0,
+ ((Interp *)interp)->cmdFramePtr, 2);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(
+ TclOOObjectName(interp, oPtr), &length);
+ int limit = 60;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), interp->errorLine));
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 2;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 2) {
+ iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 1;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[1], fPtr->objdefNs);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[1]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE);
+ Tcl_DecrRefCount(objPtr);
+ }
+ DelRef(oPtr);
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineClassObjCmd --
+ * Implementation of the "class" subcommand of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr, *o2Ptr;
+ Foundation *fPtr = TclOOGetFoundation(interp);
+
+ /*
+ * Parse the context to get the object to operate on.
+ */
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr == fPtr->objectCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the class of the root object", NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == fPtr->classCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the class of the class of classes", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the argument to get the class to set the object's class to.
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "the class of an object must be a class",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Apply semantic checks. In particular, classes and non-classes are not
+ * interchangable (too complicated to do the conversion!) so we must
+ * produce an error if any attempt is made to swap from one to the other.
+ */
+
+ if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,
+ o2Ptr->classPtr)) {
+ Tcl_AppendResult(interp, "may not change a ",
+ (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
+ (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set the object's class.
+ */
+
+ if (oPtr->selfCls != o2Ptr->classPtr) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ oPtr->selfCls = o2Ptr->classPtr;
+ TclOOAddToInstances(oPtr, oPtr->selfCls);
+ if (oPtr->classPtr != NULL) {
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ } else {
+ oPtr->epoch++;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineConstructorObjCmd --
+ * Implementation of the "constructor" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineConstructorObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Tcl_Method method;
+ int bodyLength;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Extract and validate the context, which is the class that we wish to
+ * modify.
+ */
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ Tcl_GetStringFromObj(objv[2], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
+ PUBLIC_METHOD, NULL, objv[1], objv[2], NULL);
+ if (method == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Delete the constructor method record and set the field in the
+ * class record to NULL.
+ */
+
+ method = NULL;
+ }
+
+ /*
+ * Place the method structure in the class record. Note that we might not
+ * immediately delete the constructor as this might be being done during
+ * execution of the constructor itself.
+ */
+
+ Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineDeleteMethodObjCmd --
+ * Implementation of the "deletemethod" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDeleteMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceDeleteMethod = (clientData != NULL);
+ Object *oPtr;
+ int i;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceDeleteMethod && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Delete the method structure from the appropriate hash table.
+ */
+
+ if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
+ objv[i], NULL) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (isInstanceDeleteMethod) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineDestructorObjCmd --
+ * Implementation of the "destructor" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDestructorObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Tcl_Method method;
+ int bodyLength;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "body");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ Tcl_GetStringFromObj(objv[1], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
+ PUBLIC_METHOD, NULL, NULL, objv[1], NULL);
+ if (method == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Delete the destructor method record and set the field in the class
+ * record to NULL.
+ */
+
+ method = NULL;
+ }
+
+ /*
+ * Place the method structure in the class record. Note that we might not
+ * immediately delete the destructor as this might be being done during
+ * execution of the destructor itself. Also note that setting a
+ * destructor during a destructor is fairly dumb anyway.
+ */
+
+ Tcl_ClassSetDestructor(interp, (Tcl_Class) clsPtr, method);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineExportObjCmd --
+ * Implementation of the "export" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineExportObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceExport = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew, changed = 0;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (!isInstanceExport && !clsPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Exporting is done by adding the PUBLIC_METHOD flag to the method
+ * record. If there is no such method in this object or class (i.e.
+ * the method comes from something inherited from or that we're an
+ * instance of) then we put in a blank record with that flag; such
+ * records are skipped over by the call chain engine *except* for
+ * their flags member.
+ */
+
+ if (isInstanceExport) {
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = (Tcl_HashTable *)
+ ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitObjHashTable(oPtr->methodsPtr);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
+ &isNew);
+ } else {
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+ &isNew);
+ }
+
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+ mPtr->flags |= PUBLIC_METHOD;
+ changed = 1;
+ }
+ }
+
+ /*
+ * Bump the right epoch if we actually changed anything.
+ */
+
+ if (changed) {
+ if (isInstanceExport) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineFilterObjCmd --
+ * Implementation of the "filter" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineFilterObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceFilter = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceFilter && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ if (!isInstanceFilter) {
+ TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1);
+ } else {
+ TclOOObjectSetFilters(oPtr, objc-1, objv+1);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineForwardObjCmd --
+ * Implementation of the "forward" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineForwardObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceForward = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ int isPublic;
+ Tcl_Obj *prefixObj;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceForward && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ ? PUBLIC_METHOD : 0;
+
+ /*
+ * Create the method structure.
+ */
+
+ prefixObj = Tcl_NewListObj(objc-2, objv+2);
+ if (isInstanceForward) {
+ mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
+ prefixObj);
+ } else {
+ mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
+ objv[1], prefixObj);
+ }
+ if (mPtr == NULL) {
+ Tcl_DecrRefCount(prefixObj);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineMethodObjCmd --
+ * Implementation of the "method" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceMethod = (clientData != NULL);
+ Object *oPtr;
+ int isPublic;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceMethod && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ ? PUBLIC_METHOD : 0;
+
+ /*
+ * Create the method by using the right back-end API.
+ */
+
+ if (isInstanceMethod) {
+ if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
+ objv[2], objv[3], NULL) == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
+ objv[2], objv[3], NULL) == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineMixinObjCmd --
+ * Implementation of the "mixin" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineMixinObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ const int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceMixin = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class **mixins;
+ int i;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceMixin && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+ mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
+
+ for (i=1 ; i<objc ; i++) {
+ Object *o2Ptr;
+
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
+ if (o2Ptr == NULL) {
+ goto freeAndError;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "may only mix in classes; \"",
+ TclGetString(objv[i]), "\" is not a class", NULL);
+ goto freeAndError;
+ }
+ if (!isInstanceMixin &&
+ TclOOIsReachable(oPtr->classPtr,o2Ptr->classPtr)){
+ Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ goto freeAndError;
+ }
+ mixins[i-1] = o2Ptr->classPtr;
+ }
+
+ if (isInstanceMixin) {
+ TclOOObjectSetMixins(oPtr, objc-1, mixins);
+ } else {
+ TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
+ }
+
+ TclStackFree(interp, mixins);
+ return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineRenameMethodObjCmd --
+ * Implementation of the "renamemethod" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineRenameMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceRenameMethod = (clientData != NULL);
+ Object *oPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceRenameMethod && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Delete the method entry from the appropriate hash table, and transfer
+ * the thing it points to to its new entry. To do this, we first need to
+ * get the entries from the appropriate hash tables (this can generate a
+ * range of errors...)
+ */
+
+ if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
+ objv[1], objv[2]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (isInstanceRenameMethod) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSuperclassObjCmd --
+ * Implementation of the "superclass" subcommand of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSuperclassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr, *o2Ptr;
+ Foundation *fPtr = TclOOGetFoundation(interp);
+ Class **superclasses, *superPtr;
+ int i, j;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the class to operate on.
+ */
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only classes may have superclasses defined",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == fPtr->objectCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the superclass of the root object", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate some working space.
+ */
+
+ superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+ /*
+ * Parse the arguments to get the class to use as superclasses.
+ */
+
+ for (i=0 ; i<objc-1 ; i++) {
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);
+ if (o2Ptr == NULL) {
+ goto failedAfterAlloc;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only a class can be a superclass",NULL);
+ goto failedAfterAlloc;
+ }
+ for (j=0 ; j<i ; j++) {
+ if (superclasses[j] == o2Ptr->classPtr) {
+ Tcl_AppendResult(interp,
+ "class should only be a direct superclass once",NULL);
+ goto failedAfterAlloc;
+ }
+ }
+ if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {
+ Tcl_AppendResult(interp,
+ "attempt to form circular dependency graph", NULL);
+ failedAfterAlloc:
+ ckfree((char *) superclasses);
+ return TCL_ERROR;
+ }
+ superclasses[i] = o2Ptr->classPtr;
+ }
+
+ /*
+ * Install the list of superclasses into the class. Note that this also
+ * involves splicing the class out of the superclasses' subclass list that
+ * it used to be a member of and splicing it into the new superclasses'
+ * subclass list.
+ */
+
+ if (oPtr->classPtr->superclasses.num != 0) {
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ }
+ ckfree((char *) oPtr->classPtr->superclasses.list);
+ }
+ oPtr->classPtr->superclasses.list = superclasses;
+ oPtr->classPtr->superclasses.num = objc-1;
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+ }
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineUnexportObjCmd --
+ * Implementation of the "unexport" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineUnexportObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceUnexport = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew, changed = 0;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (!isInstanceUnexport && !clsPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Unexporting is done by removing the PUBLIC_METHOD flag from the
+ * method record. If there is no such method in this object or class
+ * (i.e. the method comes from something inherited from or that we're
+ * an instance of) then we put in a blank record without that flag;
+ * such records are skipped over by the call chain engine *except* for
+ * their flags member.
+ */
+
+ if (isInstanceUnexport) {
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = (Tcl_HashTable *)
+ ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitObjHashTable(oPtr->methodsPtr);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
+ &isNew);
+ } else {
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+ &isNew);
+ }
+
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ if (isNew || mPtr->flags & PUBLIC_METHOD) {
+ mPtr->flags &= ~PUBLIC_METHOD;
+ changed = 1;
+ }
+ }
+
+ /*
+ * Bump the right epoch if we actually changed anything.
+ */
+
+ if (changed) {
+ if (isInstanceUnexport) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+void
+Tcl_ClassSetConstructor(
+ Tcl_Interp *interp,
+ Tcl_Class clazz,
+ Tcl_Method method)
+{
+ Class *clsPtr = (Class *) clazz;
+
+ if (method != (Tcl_Method) clsPtr->constructorPtr) {
+ TclOODelMethodRef(clsPtr->constructorPtr);
+ clsPtr->constructorPtr = (Method *) method;
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+}
+
+void
+Tcl_ClassSetDestructor(
+ Tcl_Interp *interp,
+ Tcl_Class clazz,
+ Tcl_Method method)
+{
+ Class *clsPtr = (Class *) clazz;
+
+ if (method != (Tcl_Method) clsPtr->destructorPtr) {
+ TclOODelMethodRef(clsPtr->destructorPtr);
+ clsPtr->destructorPtr = (Method *) method;
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
new file mode 100644
index 0000000..bded40c
--- /dev/null
+++ b/generic/tclOOInfo.c
@@ -0,0 +1,1271 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ * This file contains the implementation of the ::oo-related [info]
+ * subcommands.
+ *
+ * Copyright (c) 2006-2008 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.
+ *
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.4 2008/05/31 11:42:18 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+static Tcl_ObjCmdProc InfoObjectClassCmd;
+static Tcl_ObjCmdProc InfoObjectDefnCmd;
+static Tcl_ObjCmdProc InfoObjectFiltersCmd;
+static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIsACmd;
+static Tcl_ObjCmdProc InfoObjectMethodsCmd;
+static Tcl_ObjCmdProc InfoObjectMixinsCmd;
+static Tcl_ObjCmdProc InfoObjectVarsCmd;
+static Tcl_ObjCmdProc InfoClassConstrCmd;
+static Tcl_ObjCmdProc InfoClassDefnCmd;
+static Tcl_ObjCmdProc InfoClassDestrCmd;
+static Tcl_ObjCmdProc InfoClassFiltersCmd;
+static Tcl_ObjCmdProc InfoClassForwardCmd;
+static Tcl_ObjCmdProc InfoClassInstancesCmd;
+static Tcl_ObjCmdProc InfoClassMethodsCmd;
+static Tcl_ObjCmdProc InfoClassMixinsCmd;
+static Tcl_ObjCmdProc InfoClassSubsCmd;
+static Tcl_ObjCmdProc InfoClassSupersCmd;
+
+struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
+
+/*
+ * List of commands that are used to implement the [info object] subcommands.
+ */
+
+static const struct NameProcMap infoObjectCmds[] = {
+ {"::oo::InfoObject::class", InfoObjectClassCmd},
+ {"::oo::InfoObject::definition", InfoObjectDefnCmd},
+ {"::oo::InfoObject::filters", InfoObjectFiltersCmd},
+ {"::oo::InfoObject::forward", InfoObjectForwardCmd},
+ {"::oo::InfoObject::isa", InfoObjectIsACmd},
+ {"::oo::InfoObject::methods", InfoObjectMethodsCmd},
+ {"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
+ {"::oo::InfoObject::vars", InfoObjectVarsCmd},
+ {NULL, NULL}
+};
+
+/*
+ * List of commands that are used to implement the [info class] subcommands.
+ */
+
+static const struct NameProcMap infoClassCmds[] = {
+ {"::oo::InfoClass::constructor", InfoClassConstrCmd},
+ {"::oo::InfoClass::definition", InfoClassDefnCmd},
+ {"::oo::InfoClass::destructor", InfoClassDestrCmd},
+ {"::oo::InfoClass::filters", InfoClassFiltersCmd},
+ {"::oo::InfoClass::forward", InfoClassForwardCmd},
+ {"::oo::InfoClass::instances", InfoClassInstancesCmd},
+ {"::oo::InfoClass::methods", InfoClassMethodsCmd},
+ {"::oo::InfoClass::mixins", InfoClassMixinsCmd},
+ {"::oo::InfoClass::subclasses", InfoClassSubsCmd},
+ {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
+ {NULL, NULL}
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInitInfo --
+ *
+ * Adjusts the Tcl core [info] command to contain subcommands ("object"
+ * and "class") for introspection of objects and classes.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOInitInfo(
+ Tcl_Interp *interp)
+{
+ Tcl_Namespace *nsPtr;
+ Tcl_Command infoCmd;
+ int i;
+
+ /*
+ * Build the ensemble used to implement [info object].
+ */
+
+ nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
+ Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
+ Tcl_Export(interp, nsPtr, "[a-z]*", 1);
+ for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
+ Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
+ infoObjectCmds[i].proc, NULL, NULL);
+ }
+
+ /*
+ * Build the ensemble used to implement [info class].
+ */
+
+ nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
+ Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
+ Tcl_Export(interp, nsPtr, "[a-z]*", 1);
+ for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
+ Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
+ infoClassCmds[i].proc, NULL, NULL);
+ }
+
+ /*
+ * Install into the master [info] ensemble.
+ */
+
+ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
+ if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) {
+ Tcl_Obj *mapDict, *objectObj, *classObj;
+
+ Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
+ if (mapDict != NULL) {
+ objectObj = Tcl_NewStringObj("object", -1);
+ classObj = Tcl_NewStringObj("class", -1);
+
+ Tcl_IncrRefCount(objectObj);
+ Tcl_IncrRefCount(classObj);
+ Tcl_DictObjPut(NULL, mapDict, objectObj,
+ Tcl_NewStringObj("::oo::InfoObject", -1));
+ Tcl_DictObjPut(NULL, mapDict, classObj,
+ Tcl_NewStringObj("::oo::InfoClass", -1));
+ Tcl_DecrRefCount(objectObj);
+ Tcl_DecrRefCount(classObj);
+ Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectClassCmd --
+ *
+ * Implements [info object class $objName ?$className?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectClassCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ Tcl_SetObjResult(interp,
+ TclOOObjectName(interp, oPtr->selfCls->thisPtr));
+ return TCL_OK;
+ } else {
+ Object *o2Ptr;
+ Class *mixinPtr;
+ int i;
+
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ return TCL_OK;
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+ return TCL_OK;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectDefnCmd --
+ *
+ * Implements [info object definition $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectDefnCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_HashEntry *hPtr;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *argsObj;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 3, objv, "objName methodName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (!oPtr->methodsPtr) {
+ goto unknownMethod;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ argsObj = Tcl_NewObj();
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ argObj = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+
+ /*
+ * This is copied from the [info body] implementation. See the comments
+ * there for why this copy has to be done here.
+ */
+
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectFiltersCmd --
+ *
+ * Implements [info object filters $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectFiltersCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int i;
+ Tcl_Obj *filterObj;
+ Object *oPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectForwardCmd --
+ *
+ * Implements [info object forward $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectForwardCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *prefixObj;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (!oPtr->methodsPtr) {
+ goto unknownMethod;
+ }
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+ if (hPtr == NULL) {
+ unknownMethod:
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ if (prefixObj == NULL) {
+ Tcl_AppendResult(interp,
+ "prefix argument list not available for this kind of method",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, prefixObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectIsACmd --
+ *
+ * Implements [info object isa $category $objName ...]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIsACmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *categories[] = {
+ "class", "metaclass", "mixin", "object", "typeof", NULL
+ };
+ enum IsACats {
+ IsClass, IsMetaclass, IsMixin, IsObject, IsType
+ };
+ Object *oPtr, *o2Ptr;
+ int idx, i;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (idx == IsObject) {
+ int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
+
+ if (!ok) {
+ Tcl_ResetResult(interp);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
+ return TCL_OK;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum IsACats) idx) {
+ case IsClass:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
+ return TCL_OK;
+ case IsMetaclass:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName");
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ } else {
+ Class *classCls = TclOOGetFoundation(interp)->classCls;
+
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0));
+ }
+ return TCL_OK;
+ case IsMixin:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+ return TCL_ERROR;
+ } else {
+ Class *mixinPtr;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr == o2Ptr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ return TCL_OK;
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ return TCL_OK;
+ case IsType:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+ return TCL_ERROR;
+ }
+ if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ }
+ return TCL_OK;
+ case IsObject:
+ Tcl_Panic("unexpected fallthrough");
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMethodsCmd --
+ *
+ * Implements [info object methods $objName ?$option ...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMethodsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ int flag = PUBLIC_METHOD, recurse = 0;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+ static const char *options[] = {
+ "-all", "-localprivate", "-private", NULL
+ };
+ enum Options {
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc != 2) {
+ int i, idx;
+
+ for (i=2 ; i<objc ; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum Options) idx) {
+ case OPT_ALL:
+ recurse = 1;
+ break;
+ case OPT_LOCALPRIVATE:
+ flag = PRIVATE_METHOD;
+ break;
+ case OPT_PRIVATE:
+ flag = 0;
+ break;
+ }
+ }
+ }
+
+ if (recurse) {
+ const char **names;
+ int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+ Tcl_Obj *resultObj = Tcl_NewObj();
+
+ for (i=0 ; i<numNames ; i++) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(names[i], -1));
+ }
+ ckfree((char *) names);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+ }
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ namePtr);
+ }
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectMixinsCmd --
+ *
+ * Implements [info object mixins $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMixinsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *mixinPtr;
+ Object *oPtr;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 3, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectVarsCmd --
+ *
+ * Implements [info object vars $objName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVarsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ const char *pattern = NULL;
+ FOREACH_HASH_DECLS;
+ VarInHash *vihPtr;
+ Tcl_Obj *nameObj, *resultObj;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+ resultObj = Tcl_NewObj();
+
+ /*
+ * Extract the information we need from the object's namespace's table of
+ * variables. Note that this involves horrific knowledge of the guts of
+ * tclVar.c, so we can't leverage our hash-iteration macros properly.
+ */
+
+ FOREACH_HASH_VALUE(vihPtr,
+ &((Namespace *) oPtr->namespacePtr)->varTable.table) {
+ nameObj = vihPtr->entry.key.objPtr;
+
+ if (TclIsVarUndefined(&vihPtr->var)
+ || !TclIsVarNamespaceVar(&vihPtr->var)) {
+ continue;
+ }
+ if (pattern != NULL
+ && !Tcl_StringMatch(TclGetString(nameObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
+ }
+
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassConstrCmd --
+ *
+ * Implements [info class constructor $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassConstrCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *argsObj;
+ Object *oPtr;
+ Class *clsPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ if (clsPtr->constructorPtr == NULL) {
+ return TCL_OK;
+ }
+ procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ argsObj = Tcl_NewObj();
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ argObj = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassDefnCmd --
+ *
+ * Implements [info class definition $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDefnCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *argsObj;
+ Object *oPtr;
+ Class *clsPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ argsObj = Tcl_NewObj();
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ argObj = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassDestrCmd --
+ *
+ * Implements [info class destructor $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDestrCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Proc *procPtr;
+ Object *oPtr;
+ Class *clsPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ if (clsPtr->destructorPtr == NULL) {
+ return TCL_OK;
+ }
+ procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassFiltersCmd --
+ *
+ * Implements [info class filters $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassFiltersCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int i;
+ Tcl_Obj *filterObj;
+ Object *oPtr;
+ Class *clsPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassForwardCmd --
+ *
+ * Implements [info class forward $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassForwardCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *prefixObj;
+ Object *oPtr;
+ Class *clsPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ if (prefixObj == NULL) {
+ Tcl_AppendResult(interp,
+ "prefix argument list not available for this kind of method",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, prefixObj);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassInstancesCmd --
+ *
+ * Implements [info class instances $clsName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassInstancesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr;
+ int i;
+ const char *pattern = NULL;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+
+ FOREACH(oPtr, clsPtr->instances) {
+ Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr);
+
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMethodsCmd --
+ *
+ * Implements [info class methods $clsName ?-private?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMethodsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int flag = PUBLIC_METHOD, recurse = 0;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+ Object *oPtr;
+ Class *clsPtr;
+ static const char *options[] = {
+ "-all", "-localprivate", "-private", NULL
+ };
+ enum Options {
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (objc != 2) {
+ int i, idx;
+
+ for (i=2 ; i<objc ; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum Options) idx) {
+ case OPT_ALL:
+ recurse = 1;
+ break;
+ case OPT_LOCALPRIVATE:
+ flag = PRIVATE_METHOD;
+ break;
+ case OPT_PRIVATE:
+ flag = 0;
+ break;
+ }
+ }
+ }
+
+ if (recurse) {
+ const char **names;
+ int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
+ Tcl_Obj *resultObj = Tcl_NewObj();
+
+ for (i=0 ; i<numNames ; i++) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(names[i], -1));
+ }
+ ckfree((char *) names);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+ }
+
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassMixinsCmd --
+ *
+ * Implements [info class mixins $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMixinsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr, *mixinPtr;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassSubsCmd --
+ *
+ * Implements [info class subclasses $clsName ?$pattern?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassSubsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr, *subclassPtr;
+ int i;
+ const char *pattern = NULL;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
+
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ FOREACH(subclassPtr, clsPtr->mixinSubs) {
+ Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
+
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassSupersCmd --
+ *
+ * Implements [info class superclasses $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassSupersCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr, *superPtr;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ FOREACH(superPtr, clsPtr->superclasses) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, superPtr->thisPtr));
+ }
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
new file mode 100644
index 0000000..7c0b6a7
--- /dev/null
+++ b/generic/tclOOInt.h
@@ -0,0 +1,579 @@
+/*
+ * tclOOInt.h --
+ *
+ * This file contains the structure definitions and some of the function
+ * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006 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.
+ *
+ * RCS: @(#) $Id: tclOOInt.h,v 1.1 2008/05/31 11:42:18 dkf Exp $
+ */
+
+#include <tclInt.h>
+#include "tclOO.h"
+
+/*
+ * Forward declarations.
+ */
+
+struct CallChain;
+struct Class;
+struct Foundation;
+struct Object;
+
+/*
+ * The data that needs to be stored per method. This record is used to collect
+ * information about all sorts of methods, including forwards, constructors
+ * and destructors.
+ */
+
+typedef struct Method {
+ const Tcl_MethodType *typePtr;
+ /* The type of method. If NULL, this is a
+ * special flag record which is just used for
+ * the setting of the flags field. */
+ int refCount;
+ ClientData clientData; /* Type-specific data. */
+ Tcl_Obj *namePtr; /* Name of the method. */
+ struct Object *declaringObjectPtr;
+ /* The object that declares this method, or
+ * NULL if it was declared by a class. */
+ struct Class *declaringClassPtr;
+ /* The class that declares this method, or
+ * NULL if it was declared directly on an
+ * object. */
+ int flags; /* Assorted flags. Includes whether this
+ * method is public/exported or not. */
+} Method;
+
+/*
+ * Pre- and post-call callbacks, to allow procedure-like methods to be fine
+ * tuned in their behaviour.
+ */
+
+typedef int (*TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished);
+typedef int (*TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
+typedef void (*TclOO_PmCDDeleteProc)(ClientData clientData);
+typedef ClientData (*TclOO_PmCDCloneProc)(ClientData clientData);
+
+/*
+ * Procedure-like methods have the following extra information.
+ */
+
+typedef struct ProcedureMethod {
+ int version; /* Version of this structure. Currently must
+ * be 0. */
+ Proc *procPtr; /* Core of the implementation of the method;
+ * includes the argument definition and the
+ * body bytecodes. */
+ int flags; /* Flags to control features. */
+ int refCount;
+ ClientData clientData;
+ TclOO_PmCDDeleteProc deleteClientdataProc;
+ TclOO_PmCDCloneProc cloneClientdataProc;
+ ProcErrorProc errProc; /* Replacement error handler. */
+ TclOO_PreCallProc preCallProc;
+ /* Callback to allow for additional setup
+ * before the method executes. */
+ TclOO_PostCallProc postCallProc;
+ /* Callback to allow for additional cleanup
+ * after the method executes. */
+ GetFrameInfoValueProc gfivProc;
+ /* Callback to allow for fine tuning of how
+ * the method reports itself. */
+} ProcedureMethod;
+
+#define TCLOO_PROCEDURE_METHOD_VERSION 0
+
+/*
+ * Flags for use in a ProcedureMethod.
+ *
+ * When the USE_DECLARER_NS flag is set, the method will use the namespace of
+ * the object or class that declared it (or the clone of it, if it was from
+ * such that the implementation of the method came to the particular use)
+ * instead of the namespace of the object on which the method was invoked.
+ * This flag must be distinct from all others that are associated with
+ * methods.
+ */
+
+#define USE_DECLARER_NS 0x80
+
+/*
+ * Forwarded methods have the following extra information. It is a
+ * single-field structure because this allows for future expansion without
+ * changing vast amounts of code.
+ */
+
+typedef struct ForwardMethod {
+ Tcl_Obj *prefixObj;
+} ForwardMethod;
+
+/*
+ * Helper definitions that declare a "list" array. The two varieties are
+ * either optimized for simplicity (in the case that the whole array is
+ * typically assigned at once) or efficiency (in the case that the array is
+ * expected to be expanded over time). These lists are designed to be iterated
+ * over with the help of the FOREACH macro (see later in this file).
+ *
+ * The "num" field always counts the number of listType_t elements used in the
+ * "list" field. When a "size" field exists, it describes how many elements
+ * are present in the list; when absent, exactly "num" elements are present.
+ */
+
+#define LIST_STATIC(listType_t) \
+ struct { int num; listType_t *list; }
+#define LIST_DYNAMIC(listType_t) \
+ struct { int num, size; listType_t *list; }
+
+/*
+ * Now, the definition of what an object actually is.
+ */
+
+typedef struct Object {
+ struct Foundation *fPtr; /* The basis for the object system. Putting
+ * this here allows the avoidance of quite a
+ * lot of hash lookups on the critical path
+ * for object invokation and creation. */
+ Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
+ Tcl_Command command; /* Reference to this object's public
+ * command. */
+ Tcl_Command myCommand; /* Reference to this object's internal
+ * command. */
+ struct Class *selfCls; /* This object's class. */
+ Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to
+ * Method* mapping. */
+ LIST_STATIC(struct Class *) mixins;
+ /* Classes mixed into this object. */
+ LIST_STATIC(Tcl_Obj *) filters;
+ /* List of filter names. */
+ struct Class *classPtr; /* All classes have this non-NULL; it points
+ * to the class structure. Everything else has
+ * this NULL. */
+ int refCount; /* Number of strong references to this object.
+ * Note that there may be many more weak
+ * references; this mechanism is there to
+ * avoid Tcl_Preserve. */
+ int flags;
+ int creationEpoch; /* Unique value to make comparisons of objects
+ * easier. */
+ int epoch; /* Per-object epoch, incremented when the way
+ * an object should resolve call chains is
+ * changed. */
+ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
+ * the ClientData values that are the values
+ * of each piece of attached metadata. This
+ * field starts out as NULL and is only
+ * allocated if metadata is attached. */
+ Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
+ Tcl_HashTable *chainCache; /* Place to keep unused contexts. This table
+ * is indexed by method name as Tcl_Obj. */
+ Tcl_ObjectMapMethodNameProc mapMethodNameProc;
+ /* Function to allow remapping of method
+ * names. For itcl-ng. */
+} Object;
+
+#define OBJECT_DELETED 1 /* Flag to say that an object has been
+ * destroyed. */
+#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
+ * the class hierarchy and should be treated
+ * specially during teardown. */
+#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
+ * filter; when set, filters are *not*
+ * processed on the object, preventing nasty
+ * recursive filtering problems. */
+#define USE_CLASS_CACHE 0x4000 /* Flag set to say that the object is a pure
+ * instance of the class, and has had nothing
+ * added that changes the dispatch chain (i.e.
+ * no methods, mixins, or filters. */
+
+/*
+ * And the definition of a class. Note that every class also has an associated
+ * object, through which it is manipulated.
+ */
+
+typedef struct Class {
+ Object *thisPtr; /* Reference to the object associated with
+ * this class. */
+ int refCount; /* Number of strong references to this class.
+ * Weak references are not counted; the
+ * purpose of this is to avoid Tcl_Preserve as
+ * that is quite slow. */
+ int flags; /* Assorted flags. */
+ LIST_STATIC(struct Class *) superclasses;
+ /* List of superclasses, used for generation
+ * of method call chains. */
+ LIST_DYNAMIC(struct Class *) subclasses;
+ /* List of subclasses, used to ensure deletion
+ * of dependent entities happens properly when
+ * the class itself is deleted. */
+ LIST_DYNAMIC(Object *) instances;
+ /* List of instances, used to ensure deletion
+ * of dependent entities happens properly when
+ * the class itself is deleted. */
+ LIST_STATIC(Tcl_Obj *) filters;
+ /* List of filter names, used for generation
+ * of method call chains. */
+ LIST_STATIC(struct Class *) mixins;
+ /* List of mixin classes, used for generation
+ * of method call chains. */
+ LIST_DYNAMIC(struct Class *) mixinSubs;
+ /* List of classes that this class is mixed
+ * into, used to ensure deletion of dependent
+ * entities happens properly when the class
+ * itself is deleted. */
+ Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from
+ * the (Tcl_Obj*) method name to the (Method*)
+ * method record. */
+ Method *constructorPtr; /* Method record of the class constructor (if
+ * any). */
+ Method *destructorPtr; /* Method record of the class destructor (if
+ * any). */
+ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
+ * the ClientData values that are the values
+ * of each piece of attached metadata. This
+ * field starts out as NULL and is only
+ * allocated if metadata is attached. */
+ struct CallChain *constructorChainPtr;
+ struct CallChain *destructorChainPtr;
+ Tcl_HashTable *classChainCache;
+ /* Places where call chains are stored. For
+ * constructors, the class chain is always
+ * used. For destructors and ordinary methods,
+ * the class chain is only used when the
+ * object doesn't override with its own mixins
+ * (and filters and method implementations for
+ * when getting method chains). */
+} Class;
+
+/*
+ * The foundation of the object system within an interpreter contains
+ * references to the key classes and namespaces, together with a few other
+ * useful bits and pieces. Probably ought to eventually go in the Interp
+ * structure itself.
+ */
+
+typedef struct ThreadLocalData {
+ int nsCount; /* Master epoch counter is used for keeping
+ * the values used in Tcl_Obj internal
+ * representations sane. Must be thread-local
+ * because Tcl_Objs can cross interpreter
+ * boundaries within a thread (objects don't
+ * generally cross threads). */
+} ThreadLocalData;
+
+typedef struct Foundation {
+ Tcl_Interp *interp;
+ Class *objectCls; /* The root of the object system. */
+ Class *classCls; /* The class of all classes. */
+ Tcl_Namespace *ooNs; /* Master ::oo namespace. */
+ Tcl_Namespace *defineNs; /* Namespace containing special commands for
+ * manipulating objects and classes. The
+ * "oo::define" command acts as a special kind
+ * of ensemble for this namespace. */
+ Tcl_Namespace *objdefNs; /* Namespace containing special commands for
+ * manipulating objects and classes. The
+ * "oo::objdefine" command acts as a special
+ * kind of ensemble for this namespace. */
+ Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
+ * only valid when executing inside a
+ * procedural method. */
+ int epoch; /* Used to invalidate method chains when the
+ * class structure changes. */
+ ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique
+ * namespace to each object. */
+ Tcl_Obj *unknownMethodNameObj;
+ /* Shared object containing the name of the
+ * unknown method handler method. */
+ Tcl_Obj *constructorName; /* Shared object containing the "name" of a
+ * constructor. */
+ Tcl_Obj *destructorName; /* Shared object containing the "name" of a
+ * destructor. */
+} Foundation;
+
+/*
+ * A call context structure is built when a method is called. They contain the
+ * chain of method implementations that are to be invoked by a particular
+ * call, and the process of calling walks the chain, with the [next] command
+ * proceeding to the next entry in the chain.
+ */
+
+#define CALL_CHAIN_STATIC_SIZE 4
+
+struct MInvoke {
+ Method *mPtr; /* Reference to the method implementation
+ * record. */
+ int isFilter; /* Whether this is a filter invokation. */
+ Class *filterDeclarer; /* What class decided to add the filter; if
+ * NULL, it was added by the object. */
+};
+
+typedef struct CallChain {
+ int objectCreationEpoch; /* The object's creation epoch. Note that the
+ * object reference is not stored in the call
+ * chain; it is in the call context. */
+ int objectEpoch; /* Local (object structure) epoch counter
+ * snapshot. */
+ int epoch; /* Global (class structure) epoch counter
+ * snapshot. */
+ int flags; /* Assorted flags, see below. */
+ int refCount; /* Reference count. */
+ int numChain; /* Size of the call chain. */
+ struct MInvoke *chain; /* Array of call chain entries. May point to
+ * staticChain if the number of entries is
+ * small. */
+ struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
+} CallChain;
+
+typedef struct CallContext {
+ Object *oPtr; /* The object associated with this call. */
+ int index; /* Index into the call chain of the currently
+ * executing method implementation. */
+ int skip; /* Current number of arguments to skip; can
+ * vary depending on whether it is a direct
+ * method call or a continuation via the
+ * [next] command. */
+ CallChain *callPtr; /* The actual call chain. */
+} CallContext;
+
+/*
+ * Bits for the 'flags' field of the call context.
+ */
+
+#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */
+#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances
+ * only) method. */
+#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */
+#define CONSTRUCTOR 0x08 /* This is a constructor. */
+#define DESTRUCTOR 0x10 /* This is a destructor. */
+
+/*
+ * Assorted flags for call frames. Note that bits 1 and 2 are already taken by
+ * Tcl itself.
+ */
+
+#if 0
+#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
+ * clientData field contains a CallContext
+ * reference. */
+#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of
+ * the [oo::define] command; the clientData
+ * field contains an Object reference that has
+ * been confirmed to refer to a class. */
+#endif
+
+/*
+ * Structure containing definition information about basic class methods.
+ */
+
+typedef struct {
+ const char *name; /* Name of the method in question. */
+ int isPublic; /* Whether the method is public by default. */
+ Tcl_MethodType definition; /* How to call the method. */
+} DeclaredClassMethod;
+
+/*
+ *----------------------------------------------------------------
+ * Commands relating to OO support.
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineFilterObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineMixinObjCmd(ClientData clientData,
+ Tcl_Interp *interp, const int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOONextObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+
+/*
+ * Method implementations (in tclOOBasic.c).
+ */
+
+MODULE_SCOPE int TclOO_Class_Create(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Class_New(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+
+/*
+ * Private definitions, some of which perhaps ought to be exposed properly or
+ * maybe just put in the internal stubs table.
+ */
+
+MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
+MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
+MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
+MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
+MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
+MODULE_SCOPE void TclOODelMethodRef(Method *method);
+MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
+ Tcl_Obj *methodNameObj, int flags);
+MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
+MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
+MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr,
+ int flags, const char ***stringsPtr);
+MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags,
+ const char ***stringsPtr);
+MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
+MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp);
+MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp,
+ CallContext *contextPtr, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
+ const DeclaredClassMethod *dcm);
+MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
+MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
+ Class *mixinPtr);
+MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
+ Class *superPtr);
+MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
+ CallContext *contextPtr);
+
+/*
+ * Include all the private API, generated from tclOO.decls.
+ */
+
+#include "tclOOIntDecls.h"
+
+/*
+ * A convenience macro for iterating through the lists used in the internal
+ * memory management of objects. This is a bit gnarly because we want to do
+ * the assignment of the picked-out value only when the body test succeeds,
+ * but we cannot rely on the assigned value being useful, forcing us to do
+ * some nasty stuff with the comma operator. The compiler's optimizer should
+ * be able to sort it all out!
+ *
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH(var,ary) \
+ for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
+
+/*
+ * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
+ * sets up the declarations needed for the main macro, FOREACH_HASH, which
+ * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
+ * only iterates over values.
+ */
+
+#define FOREACH_HASH_DECLS \
+ Tcl_HashEntry *hPtr;Tcl_HashSearch search
+#define FOREACH_HASH(key,val,tablePtr) \
+ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+ ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
+ (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
+#define FOREACH_HASH_VALUE(val,tablePtr) \
+ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+ ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
+
+/*
+ * Convenience macro for duplicating a list. Needs no external declaration,
+ * but all arguments are used multiple times and so must have no side effects.
+ */
+
+#define DUPLICATE(target,source,type) \
+ do { \
+ register unsigned len = sizeof(type) * ((target).num=(source).num);\
+ if (len != 0) { \
+ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
+ } else { \
+ (target).list = NULL; \
+ } \
+ } while(0)
+
+/*
+ * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
+ */
+
+#define AddRef(ptr) ((ptr)->refCount++)
+#define DelRef(ptr) do { \
+ if (--(ptr)->refCount < 1) { \
+ ckfree((char *) (ptr)); \
+ } \
+ } while(0)
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h
new file mode 100644
index 0000000..e39b457
--- /dev/null
+++ b/generic/tclOOIntDecls.h
@@ -0,0 +1,209 @@
+/*
+ * $Id: tclOOIntDecls.h,v 1.1 2008/05/31 11:42:18 dkf Exp $
+ *
+ * This file is (mostly) automatically generated from tclOO.decls.
+ */
+
+/* !BEGIN!: Do not edit below this line. */
+
+#define TCLOOINT_STUBS_EPOCH 0
+#define TCLOOINT_STUBS_REVISION 44
+
+#if !defined(USE_TCLOO_STUBS)
+
+/*
+ * Exported function declarations:
+ */
+
+/* 0 */
+TCLOOAPI Tcl_Object TclOOGetDefineCmdContext (Tcl_Interp * interp);
+/* 1 */
+TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod (Tcl_Interp * interp,
+ Object * oPtr, int flags, Tcl_Obj * nameObj,
+ Tcl_Obj * argsObj, Tcl_Obj * bodyObj,
+ const Tcl_MethodType * typePtr,
+ ClientData clientData, Proc ** procPtrPtr);
+/* 2 */
+TCLOOAPI Tcl_Method TclOOMakeProcMethod (Tcl_Interp * interp,
+ Class * clsPtr, int flags, Tcl_Obj * nameObj,
+ const char * namePtr, Tcl_Obj * argsObj,
+ Tcl_Obj * bodyObj,
+ const Tcl_MethodType * typePtr,
+ ClientData clientData, Proc ** procPtrPtr);
+/* 3 */
+TCLOOAPI Method * TclOONewProcInstanceMethod (Tcl_Interp * interp,
+ Object * oPtr, int flags, Tcl_Obj * nameObj,
+ Tcl_Obj * argsObj, Tcl_Obj * bodyObj,
+ ProcedureMethod ** pmPtrPtr);
+/* 4 */
+TCLOOAPI Method * TclOONewProcMethod (Tcl_Interp * interp,
+ Class * clsPtr, int flags, Tcl_Obj * nameObj,
+ Tcl_Obj * argsObj, Tcl_Obj * bodyObj,
+ ProcedureMethod ** pmPtrPtr);
+/* 5 */
+TCLOOAPI int TclOOObjectCmdCore (Object * oPtr,
+ Tcl_Interp * interp, int objc,
+ Tcl_Obj *const * objv, int publicOnly,
+ Class * startCls);
+/* 6 */
+TCLOOAPI int TclOOIsReachable (Class * targetPtr,
+ Class * startPtr);
+/* 7 */
+TCLOOAPI Method * TclOONewForwardMethod (Tcl_Interp * interp,
+ Class * clsPtr, int isPublic,
+ Tcl_Obj * nameObj, Tcl_Obj * prefixObj);
+/* 8 */
+TCLOOAPI Method * TclOONewForwardInstanceMethod (Tcl_Interp * interp,
+ Object * oPtr, int isPublic,
+ Tcl_Obj * nameObj, Tcl_Obj * prefixObj);
+/* 9 */
+TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx (Tcl_Interp * interp,
+ Tcl_Object oPtr,
+ TclOO_PreCallProc preCallPtr,
+ TclOO_PostCallProc postCallPtr,
+ ProcErrorProc errProc, ClientData clientData,
+ Tcl_Obj * nameObj, Tcl_Obj * argsObj,
+ Tcl_Obj * bodyObj, int flags,
+ void ** internalTokenPtr);
+/* 10 */
+TCLOOAPI Tcl_Method TclOONewProcMethodEx (Tcl_Interp * interp,
+ Tcl_Class clsPtr,
+ TclOO_PreCallProc preCallPtr,
+ TclOO_PostCallProc postCallPtr,
+ ProcErrorProc errProc, ClientData clientData,
+ Tcl_Obj * nameObj, Tcl_Obj * argsObj,
+ Tcl_Obj * bodyObj, int flags,
+ void ** internalTokenPtr);
+/* 11 */
+TCLOOAPI int TclOOInvokeObject (Tcl_Interp * interp,
+ Tcl_Object object, Tcl_Class startCls,
+ int publicPrivate, int objc,
+ Tcl_Obj *const * objv);
+/* 12 */
+TCLOOAPI void TclOOObjectSetFilters (Object * oPtr, int numFilters,
+ Tcl_Obj *const * filters);
+/* 13 */
+TCLOOAPI void TclOOClassSetFilters (Tcl_Interp * interp,
+ Class * classPtr, int numFilters,
+ Tcl_Obj *const * filters);
+/* 14 */
+TCLOOAPI void TclOOObjectSetMixins (Object * oPtr, int numMixins,
+ Class *const * mixins);
+/* 15 */
+TCLOOAPI void TclOOClassSetMixins (Tcl_Interp * interp,
+ Class * classPtr, int numMixins,
+ Class *const * mixins);
+
+#endif /* !defined(USE_TCLOO_STUBS) */
+
+typedef struct TclOOIntStubs {
+ int magic;
+ int epoch;
+ int revision;
+ struct TclOOIntStubHooks *hooks;
+
+ Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp * interp); /* 0 */
+ Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp * interp, Object * oPtr, int flags, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, const Tcl_MethodType * typePtr, ClientData clientData, Proc ** procPtrPtr); /* 1 */
+ Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp * interp, Class * clsPtr, int flags, Tcl_Obj * nameObj, const char * namePtr, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, const Tcl_MethodType * typePtr, ClientData clientData, Proc ** procPtrPtr); /* 2 */
+ Method * (*tclOONewProcInstanceMethod) (Tcl_Interp * interp, Object * oPtr, int flags, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, ProcedureMethod ** pmPtrPtr); /* 3 */
+ Method * (*tclOONewProcMethod) (Tcl_Interp * interp, Class * clsPtr, int flags, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, ProcedureMethod ** pmPtrPtr); /* 4 */
+ int (*tclOOObjectCmdCore) (Object * oPtr, Tcl_Interp * interp, int objc, Tcl_Obj *const * objv, int publicOnly, Class * startCls); /* 5 */
+ int (*tclOOIsReachable) (Class * targetPtr, Class * startPtr); /* 6 */
+ Method * (*tclOONewForwardMethod) (Tcl_Interp * interp, Class * clsPtr, int isPublic, Tcl_Obj * nameObj, Tcl_Obj * prefixObj); /* 7 */
+ Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp * interp, Object * oPtr, int isPublic, Tcl_Obj * nameObj, Tcl_Obj * prefixObj); /* 8 */
+ Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp * interp, Tcl_Object oPtr, TclOO_PreCallProc preCallPtr, TclOO_PostCallProc postCallPtr, ProcErrorProc errProc, ClientData clientData, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, int flags, void ** internalTokenPtr); /* 9 */
+ Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp * interp, Tcl_Class clsPtr, TclOO_PreCallProc preCallPtr, TclOO_PostCallProc postCallPtr, ProcErrorProc errProc, ClientData clientData, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, int flags, void ** internalTokenPtr); /* 10 */
+ int (*tclOOInvokeObject) (Tcl_Interp * interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const * objv); /* 11 */
+ void (*tclOOObjectSetFilters) (Object * oPtr, int numFilters, Tcl_Obj *const * filters); /* 12 */
+ void (*tclOOClassSetFilters) (Tcl_Interp * interp, Class * classPtr, int numFilters, Tcl_Obj *const * filters); /* 13 */
+ void (*tclOOObjectSetMixins) (Object * oPtr, int numMixins, Class *const * mixins); /* 14 */
+ void (*tclOOClassSetMixins) (Tcl_Interp * interp, Class * classPtr, int numMixins, Class *const * mixins); /* 15 */
+} TclOOIntStubs;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern const TclOOIntStubs *tclOOIntStubsPtr;
+#ifdef __cplusplus
+}
+#endif
+
+#if defined(USE_TCLOO_STUBS)
+
+/*
+ * Inline function declarations:
+ */
+
+#ifndef TclOOGetDefineCmdContext
+#define TclOOGetDefineCmdContext \
+ (tclOOIntStubsPtr->tclOOGetDefineCmdContext) /* 0 */
+#endif
+#ifndef TclOOMakeProcInstanceMethod
+#define TclOOMakeProcInstanceMethod \
+ (tclOOIntStubsPtr->tclOOMakeProcInstanceMethod) /* 1 */
+#endif
+#ifndef TclOOMakeProcMethod
+#define TclOOMakeProcMethod \
+ (tclOOIntStubsPtr->tclOOMakeProcMethod) /* 2 */
+#endif
+#ifndef TclOONewProcInstanceMethod
+#define TclOONewProcInstanceMethod \
+ (tclOOIntStubsPtr->tclOONewProcInstanceMethod) /* 3 */
+#endif
+#ifndef TclOONewProcMethod
+#define TclOONewProcMethod \
+ (tclOOIntStubsPtr->tclOONewProcMethod) /* 4 */
+#endif
+#ifndef TclOOObjectCmdCore
+#define TclOOObjectCmdCore \
+ (tclOOIntStubsPtr->tclOOObjectCmdCore) /* 5 */
+#endif
+#ifndef TclOOIsReachable
+#define TclOOIsReachable \
+ (tclOOIntStubsPtr->tclOOIsReachable) /* 6 */
+#endif
+#ifndef TclOONewForwardMethod
+#define TclOONewForwardMethod \
+ (tclOOIntStubsPtr->tclOONewForwardMethod) /* 7 */
+#endif
+#ifndef TclOONewForwardInstanceMethod
+#define TclOONewForwardInstanceMethod \
+ (tclOOIntStubsPtr->tclOONewForwardInstanceMethod) /* 8 */
+#endif
+#ifndef TclOONewProcInstanceMethodEx
+#define TclOONewProcInstanceMethodEx \
+ (tclOOIntStubsPtr->tclOONewProcInstanceMethodEx) /* 9 */
+#endif
+#ifndef TclOONewProcMethodEx
+#define TclOONewProcMethodEx \
+ (tclOOIntStubsPtr->tclOONewProcMethodEx) /* 10 */
+#endif
+#ifndef TclOOInvokeObject
+#define TclOOInvokeObject \
+ (tclOOIntStubsPtr->tclOOInvokeObject) /* 11 */
+#endif
+#ifndef TclOOObjectSetFilters
+#define TclOOObjectSetFilters \
+ (tclOOIntStubsPtr->tclOOObjectSetFilters) /* 12 */
+#endif
+#ifndef TclOOClassSetFilters
+#define TclOOClassSetFilters \
+ (tclOOIntStubsPtr->tclOOClassSetFilters) /* 13 */
+#endif
+#ifndef TclOOObjectSetMixins
+#define TclOOObjectSetMixins \
+ (tclOOIntStubsPtr->tclOOObjectSetMixins) /* 14 */
+#endif
+#ifndef TclOOClassSetMixins
+#define TclOOClassSetMixins \
+ (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */
+#endif
+
+#endif /* defined(USE_TCLOO_STUBS) */
+
+/* !END!: Do not edit above this line. */
+
+struct TclOOStubAPI {
+ TclOOStubs *stubsPtr;
+ TclOOIntStubs *intStubsPtr;
+};
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
new file mode 100644
index 0000000..f190533
--- /dev/null
+++ b/generic/tclOOMethod.c
@@ -0,0 +1,1425 @@
+/*
+ * tclOOMethod.c --
+ *
+ * This file contains code to create and manage methods.
+ *
+ * Copyright (c) 2005-2008 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.
+ *
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.1 2008/05/31 11:42:19 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Structure used to help delay computing names of objects or classes for
+ * [info frame] until needed, making invokation faster in the normal case.
+ */
+
+struct PNI {
+ Tcl_Interp *interp; /* Interpreter in which to compute the name of
+ * a method. */
+ Tcl_Method method; /* Method to compute the name of. */
+};
+
+/*
+ * Structure used to contain all the information needed about a call frame
+ * used in a procedure-like method.
+ */
+
+typedef struct {
+ CallFrame *framePtr; /* Reference to the call frame itself (it's
+ * actually allocated on the Tcl stack). */
+ ProcErrorProc errProc; /* The error handler for the body. */
+ Tcl_Obj *nameObj; /* The "name" of the command. */
+ Command cmd; /* The command structure. Mostly bogus. */
+ ExtraFrameInfo efi; /* Extra information used for [info frame]. */
+ struct PNI pni; /* Specialist information used in the efi
+ * field for this type of call. */
+} PMFrameData;
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv, int toRewrite,
+ int rewriteLength, Tcl_Obj *const *rewriteObjs,
+ int *lengthPtr);
+static int InvokeProcedureMethod(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int PushMethodCallFrame(Tcl_Interp *interp,
+ CallContext *contextPtr, ProcedureMethod *pmPtr,
+ int objc, Tcl_Obj *const *objv,
+ PMFrameData *fdPtr);
+static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
+static void DeleteProcedureMethod(ClientData clientData);
+static int CloneProcedureMethod(Tcl_Interp *interp,
+ ClientData clientData, ClientData *newClientData);
+static void MethodErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj);
+static void ConstructorErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj);
+static void DestructorErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj);
+static Tcl_Obj * RenderDeclarerName(ClientData clientData);
+static int InvokeForwardMethod(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static void DeleteForwardMethod(ClientData clientData);
+static int CloneForwardMethod(Tcl_Interp *interp,
+ ClientData clientData, ClientData *newClientData);
+
+/*
+ * The types of methods defined by the core OO system.
+ */
+
+static const Tcl_MethodType procMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "procedural method",
+ InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
+};
+static const Tcl_MethodType fwdMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "forward",
+ InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewInstanceMethod --
+ *
+ * Attach a method to an object instance.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewInstanceMethod(
+ Tcl_Interp *interp, /* Unused? */
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ ClientData clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ register Object *oPtr = (Object *) object;
+ register Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (nameObj == NULL) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = NULL;
+ goto populate;
+ }
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitObjHashTable(oPtr->methodsPtr);
+ oPtr->flags &= ~USE_CLASS_CACHE;
+ }
+ hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = nameObj;
+ Tcl_IncrRefCount(nameObj);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ }
+
+ populate:
+ mPtr->typePtr = typePtr;
+ mPtr->clientData = clientData;
+ mPtr->refCount = 1;
+ mPtr->flags = 0;
+ mPtr->declaringObjectPtr = oPtr;
+ mPtr->declaringClassPtr = NULL;
+ if (flags) {
+ mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ }
+ oPtr->epoch++;
+ return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewMethod --
+ *
+ * Attach a method to a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ ClientData clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ register Class *clsPtr = (Class *) cls;
+ register Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (nameObj == NULL) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = NULL;
+ goto populate;
+ }
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = nameObj;
+ Tcl_IncrRefCount(nameObj);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ }
+
+ populate:
+ clsPtr->thisPtr->fPtr->epoch++;
+ mPtr->typePtr = typePtr;
+ mPtr->clientData = clientData;
+ mPtr->refCount = 1;
+ mPtr->flags = 0;
+ mPtr->declaringObjectPtr = NULL;
+ mPtr->declaringClassPtr = clsPtr;
+ if (flags) {
+ mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ }
+
+ return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODelMethodRef --
+ *
+ * How to delete a method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODelMethodRef(
+ Method *mPtr)
+{
+ if ((mPtr != NULL) && (--mPtr->refCount < 0)) {
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ if (mPtr->namePtr != NULL) {
+ Tcl_DecrRefCount(mPtr->namePtr);
+ }
+
+ ckfree((char *) mPtr);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewBasicMethod --
+ *
+ * Helper that makes it cleaner to create very simple methods during
+ * basic system initialization. Not suitable for general use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOONewBasicMethod(
+ Tcl_Interp *interp,
+ Class *clsPtr, /* Class to attach the method to. */
+ const DeclaredClassMethod *dcm)
+ /* Name of the method, whether it is public,
+ * and the function to implement it. */
+{
+ Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
+
+ Tcl_IncrRefCount(namePtr);
+ Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
+ Tcl_DecrRefCount(namePtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcInstanceMethod --
+ *
+ * Create a new procedure-like method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcInstanceMethod(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Object *oPtr, /* The object to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which must not be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which must not be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
+ * structure to allow for deeper tuning of the
+ * structure's contents. NULL if caller is not
+ * interested. */
+{
+ int argsLen;
+ register ProcedureMethod *pmPtr;
+ Tcl_Method method;
+
+ if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ return NULL;
+ }
+ pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+ memset(pmPtr, 0, sizeof(ProcedureMethod));
+ pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->refCount = 1;
+ method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
+ argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
+ if (method == NULL) {
+ ckfree((char *) pmPtr);
+ } else if (pmPtrPtr != NULL) {
+ *pmPtrPtr = pmPtr;
+ }
+ return (Method *) method;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcMethod --
+ *
+ * Create a new procedure-like method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Class *clsPtr, /* The class to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which may be NULL; if so, it is equivalent
+ * to an empty list. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
+ * structure to allow for deeper tuning of the
+ * structure's contents. NULL if caller is not
+ * interested. */
+{
+ int argsLen; /* -1 => delete argsObj before exit */
+ register ProcedureMethod *pmPtr;
+ const char *procName;
+ Tcl_Method method;
+
+ if (argsObj == NULL) {
+ argsLen = -1;
+ argsObj = Tcl_NewObj();
+ Tcl_IncrRefCount(argsObj);
+ procName = "<destructor>";
+ } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ return NULL;
+ } else {
+ procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
+ }
+
+ pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+ memset(pmPtr, 0, sizeof(ProcedureMethod));
+ pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->refCount = 1;
+
+ method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj,
+ procName, argsObj, bodyObj, &procMethodType, pmPtr,
+ &pmPtr->procPtr);
+
+ if (argsLen == -1) {
+ Tcl_DecrRefCount(argsObj);
+ }
+ if (method == NULL) {
+ ckfree((char *) pmPtr);
+ } else if (pmPtrPtr != NULL) {
+ *pmPtrPtr = pmPtr;
+ }
+
+ return (Method *) method;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOMakeProcInstanceMethod --
+ *
+ * The guts of the code to make a procedure-like method for an object.
+ * Split apart so that it is easier for other extensions to reuse (in
+ * particular, it frees them from having to pry so deeply into Tcl's
+ * guts).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+TclOOMakeProcInstanceMethod(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Object *oPtr, /* The object to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which _must not_ be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
+ * NULL. */
+ const Tcl_MethodType *typePtr,
+ /* The type of the method to create. */
+ ClientData clientData, /* The per-method type-specific data. */
+ Proc **procPtrPtr) /* A pointer to the variable in which to write
+ * the procedure record reference. Presumably
+ * inside the structure indicated by the
+ * pointer in clientData. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr;
+
+ if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
+ procPtrPtr) != TCL_OK) {
+ return NULL;
+ }
+ procPtr = *procPtrPtr;
+ procPtr->cmdPtr = NULL;
+
+ if (iPtr->cmdFramePtr) {
+ CmdFrame context = *iPtr->cmdFramePtr;
+
+ if (context.type == TCL_LOCATION_BC) {
+ /*
+ * Retrieve source information from the bytecode, if possible. If
+ * the information is retrieved successfully, context.type will be
+ * TCL_LOCATION_SOURCE and the reference held by
+ * context.data.eval.path will be counted.
+ */
+
+ TclGetSrcInfoForPc(&context);
+ } else if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * The copy into 'context' up above has created another reference
+ * to 'context.data.eval.path'; account for it.
+ */
+
+ Tcl_IncrRefCount(context.data.eval.path);
+ }
+
+ if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * We can account for source location within a proc only if the
+ * proc body was not created by substitution.
+ * (FIXME: check that this is sane and correct!)
+ */
+
+ if (context.line
+ && (context.nline >= 4) && (context.line[3] >= 0)) {
+ int isNew;
+ CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hPtr;
+
+ cfPtr->level = -1;
+ cfPtr->type = context.type;
+ cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line[0] = context.line[3];
+ cfPtr->nline = 1;
+ cfPtr->framePtr = NULL;
+ cfPtr->nextPtr = NULL;
+
+ cfPtr->data.eval.path = context.data.eval.path;
+ Tcl_IncrRefCount(cfPtr->data.eval.path);
+
+ cfPtr->cmd.str.cmd = NULL;
+ cfPtr->cmd.str.len = 0;
+
+ hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
+ (char *) procPtr, &isNew);
+ Tcl_SetHashValue(hPtr, cfPtr);
+ }
+
+ /*
+ * 'context' is going out of scope; account for the reference that
+ * it's holding to the path name.
+ */
+
+ Tcl_DecrRefCount(context.data.eval.path);
+ context.data.eval.path = NULL;
+ }
+ }
+
+ return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
+ typePtr, clientData);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOMakeProcMethod --
+ *
+ * The guts of the code to make a procedure-like method for a class.
+ * Split apart so that it is easier for other extensions to reuse (in
+ * particular, it frees them from having to pry so deeply into Tcl's
+ * guts).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+TclOOMakeProcMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Class *clsPtr, /* The class to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ const char *namePtr, /* The name of the method as a string, which
+ * _must not_ be NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which _must not_ be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
+ * NULL. */
+ const Tcl_MethodType *typePtr,
+ /* The type of the method to create. */
+ ClientData clientData, /* The per-method type-specific data. */
+ Proc **procPtrPtr) /* A pointer to the variable in which to write
+ * the procedure record reference. Presumably
+ * inside the structure indicated by the
+ * pointer in clientData. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr;
+
+ if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
+ procPtrPtr) != TCL_OK) {
+ return NULL;
+ }
+ procPtr = *procPtrPtr;
+ procPtr->cmdPtr = NULL;
+
+ if (iPtr->cmdFramePtr) {
+ CmdFrame context = *iPtr->cmdFramePtr;
+
+ if (context.type == TCL_LOCATION_BC) {
+ /*
+ * Retrieve source information from the bytecode, if possible. If
+ * the information is retrieved successfully, context.type will be
+ * TCL_LOCATION_SOURCE and the reference held by
+ * context.data.eval.path will be counted.
+ */
+
+ TclGetSrcInfoForPc(&context);
+ } else if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * The copy into 'context' up above has created another reference
+ * to 'context.data.eval.path'; account for it.
+ */
+
+ Tcl_IncrRefCount(context.data.eval.path);
+ }
+
+ if (context.type == TCL_LOCATION_SOURCE) {
+ /*
+ * We can account for source location within a proc only if the
+ * proc body was not created by substitution.
+ * (FIXME: check that this is sane and correct!)
+ */
+
+ if (context.line
+ && (context.nline >= 4) && (context.line[3] >= 0)) {
+ int isNew;
+ CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hPtr;
+
+ cfPtr->level = -1;
+ cfPtr->type = context.type;
+ cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line[0] = context.line[3];
+ cfPtr->nline = 1;
+ cfPtr->framePtr = NULL;
+ cfPtr->nextPtr = NULL;
+
+ cfPtr->data.eval.path = context.data.eval.path;
+ Tcl_IncrRefCount(cfPtr->data.eval.path);
+
+ cfPtr->cmd.str.cmd = NULL;
+ cfPtr->cmd.str.len = 0;
+
+ hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
+ (char *) procPtr, &isNew);
+ Tcl_SetHashValue(hPtr, cfPtr);
+ }
+
+ /*
+ * 'context' is going out of scope; account for the reference that
+ * it's holding to the path name.
+ */
+
+ Tcl_DecrRefCount(context.data.eval.path);
+ context.data.eval.path = NULL;
+ }
+ }
+
+ return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
+ clientData);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeProcedureMethod, PushMethodCallFrame --
+ *
+ * How to invoke a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeProcedureMethod(
+ ClientData clientData, /* Pointer to some per-method context. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ ProcedureMethod *pmPtr = clientData;
+ int result;
+ register int skip;
+ PMFrameData *fdPtr; /* Important data that has to have a lifetime
+ * matched by this function (or rather, by the
+ * call frame's lifetime). */
+
+ /*
+ * Allocate the special frame data.
+ */
+
+ fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData));
+ pmPtr->refCount++;
+
+ /*
+ * Create a call frame for this method.
+ */
+
+ result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
+ objc, objv, fdPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Give the pre-call callback a chance to do some setup and, possibly,
+ * veto the call.
+ */
+
+ if (pmPtr->preCallProc != NULL) {
+ int isFinished;
+
+ result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
+ (Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
+ if (isFinished || result != TCL_OK) {
+ Tcl_PopCallFrame(interp);
+ TclStackFree(interp, fdPtr->framePtr);
+ goto done;
+ }
+ }
+
+ /*
+ * Now invoke the body of the method. Note that we need to take special
+ * action when doing unknown processing to ensure that the missing method
+ * name is passed as an argument.
+ */
+
+ skip = Tcl_ObjectContextSkippedArgs(context);
+ result = TclObjInterpProcCore(interp, fdPtr->nameObj, skip,
+ fdPtr->errProc);
+
+ /*
+ * Give the post-call callback a chance to do some cleanup. Note that at
+ * this point the call frame itself is invalid; it's already been popped.
+ */
+
+ if (pmPtr->postCallProc) {
+ result = pmPtr->postCallProc(pmPtr->clientData, interp, context,
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),
+ result);
+ }
+
+ /*
+ * Scrap the special frame data now that we're done with it. Note that we
+ * are inlining DeleteProcedureMethod() here; this location is highly
+ * sensitive when it comes to performance!
+ */
+
+ done:
+ if (--pmPtr->refCount < 1) {
+ DeleteProcedureMethodRecord(pmPtr);
+ }
+ TclStackFree(interp, fdPtr);
+ return result;
+}
+
+static int
+PushMethodCallFrame(
+ Tcl_Interp *interp, /* Current interpreter. */
+ CallContext *contextPtr, /* Current method call context. */
+ ProcedureMethod *pmPtr, /* Information about this procedure-like
+ * method. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv, /* Array of arguments. */
+ PMFrameData *fdPtr) /* Place to store information about the call
+ * frame. */
+{
+ Tcl_Namespace *nsPtr = contextPtr->oPtr->namespacePtr;
+ register int result;
+ const char *namePtr;
+ CallFrame **framePtrPtr = &fdPtr->framePtr;
+ static Tcl_ObjType *byteCodeTypePtr = NULL; /* HACK! */
+
+ /*
+ * Compute basic information on the basis of the type of method it is.
+ */
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ namePtr = "<constructor>";
+ fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
+ fdPtr->errProc = ConstructorErrorHandler;
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ namePtr = "<destructor>";
+ fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName;
+ fdPtr->errProc = DestructorErrorHandler;
+ } else {
+ fdPtr->nameObj = Tcl_MethodName(
+ Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));
+ namePtr = TclGetString(fdPtr->nameObj);
+ fdPtr->errProc = MethodErrorHandler;
+ }
+ if (pmPtr->errProc != NULL) {
+ fdPtr->errProc = pmPtr->errProc;
+ }
+
+ /*
+ * Magic to enable things like [incr Tcl], which wants methods to run in
+ * their class's namespace.
+ */
+
+ if (pmPtr->flags & USE_DECLARER_NS) {
+ register Method *mPtr =
+ contextPtr->callPtr->chain[contextPtr->index].mPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr;
+ } else {
+ nsPtr = mPtr->declaringObjectPtr->namespacePtr;
+ }
+ }
+
+ /*
+ * Compile the body. This operation may fail.
+ */
+
+ fdPtr->efi.length = 2;
+ memset(&fdPtr->cmd, 0, sizeof(Command));
+ fdPtr->cmd.nsPtr = (Namespace *) nsPtr;
+ fdPtr->cmd.clientData = &fdPtr->efi;
+ pmPtr->procPtr->cmdPtr = &fdPtr->cmd;
+
+ /* Should be a reference to tclByteCodeType, but that's MODULE_SCOPE */
+ if (byteCodeTypePtr == NULL ||
+ pmPtr->procPtr->bodyPtr->typePtr != byteCodeTypePtr) {
+ result = TclProcCompileProc(interp, pmPtr->procPtr,
+ pmPtr->procPtr->bodyPtr, (Namespace *) nsPtr,
+ "body of method", namePtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (byteCodeTypePtr == NULL) {
+ byteCodeTypePtr = pmPtr->procPtr->bodyPtr->typePtr;
+ }
+ }
+
+ /*
+ * Make the stack frame and fill it out with information about this call.
+ * This operation may fail.
+ */
+
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, nsPtr,
+ FRAME_IS_PROC|FRAME_IS_METHOD);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ fdPtr->framePtr->clientData = contextPtr;
+ fdPtr->framePtr->objc = objc;
+ fdPtr->framePtr->objv = objv;
+ fdPtr->framePtr->procPtr = pmPtr->procPtr;
+
+ /*
+ * Finish filling out the extra frame info so that [info frame] works.
+ */
+
+ fdPtr->efi.fields[0].name = "method";
+ fdPtr->efi.fields[0].proc = NULL;
+ fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
+ if (pmPtr->gfivProc != NULL) {
+ fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
+ fdPtr->efi.fields[1].clientData = pmPtr;
+ } else {
+ register Tcl_Method method =
+ Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
+
+ if (Tcl_MethodDeclarerObject(method) != NULL) {
+ fdPtr->efi.fields[1].name = "object";
+ } else {
+ fdPtr->efi.fields[1].name = "class";
+ }
+ fdPtr->efi.fields[1].proc = RenderDeclarerName;
+ fdPtr->efi.fields[1].clientData = &fdPtr->pni;
+ fdPtr->pni.interp = interp;
+ fdPtr->pni.method = method;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RenderDeclarerName --
+ *
+ * Returns the name of the entity (object or class) which declared a
+ * method. Used for producing information for [info frame] in such a way
+ * that the expensive part of this (generating the object or class name
+ * itself) isn't done until it is needed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+RenderDeclarerName(
+ ClientData clientData)
+{
+ struct PNI *pni = clientData;
+ Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
+
+ if (object == NULL) {
+ object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
+ }
+ return TclOOObjectName(pni->interp, (Object *) object);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler --
+ *
+ * How to fill in the stack trace correctly upon error in various forms
+ * of procedure-like methods. LIMIT is how long the inserted strings in
+ * the error traces should get before being converted to have ellipses,
+ * and ELLIPSIFY is a macro to do the conversion (with the help of a
+ * %.*s%s format field). Note that ELLIPSIFY is only safe for use in
+ * suitable formatting contexts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+#define LIMIT 60
+#define ELLIPSIFY(str,len) \
+ ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
+
+static void
+MethodErrorHandler(
+ Tcl_Interp *interp,
+ Tcl_Obj *methodNameObj)
+{
+ int nameLen, objectNameLen;
+ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ const char *objectName, *kindName, *methodName =
+ Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
+ Object *declarerPtr;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ kindName = "class";
+ }
+
+ objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ &objectNameLen);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
+ kindName, ELLIPSIFY(objectName, objectNameLen),
+ ELLIPSIFY(methodName, nameLen), interp->errorLine));
+}
+
+static void
+ConstructorErrorHandler(
+ Tcl_Interp *interp,
+ Tcl_Obj *methodNameObj)
+{
+ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ Object *declarerPtr;
+ const char *objectName, *kindName;
+ int objectNameLen;
+
+ if (interp->errorLine == 0xDEADBEEF) {
+ /*
+ * Horrible hack to deal with certain constructors that must not add
+ * information to the error trace.
+ */
+
+ return;
+ }
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ kindName = "class";
+ }
+
+ objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ &objectNameLen);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.*s%s\" constructor line %d)", kindName,
+ ELLIPSIFY(objectName, objectNameLen), interp->errorLine));
+}
+
+static void
+DestructorErrorHandler(
+ Tcl_Interp *interp,
+ Tcl_Obj *methodNameObj)
+{
+ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ Object *declarerPtr;
+ const char *objectName, *kindName;
+ int objectNameLen;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ kindName = "class";
+ }
+
+ objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ &objectNameLen);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.*s%s\" destructor line %d)", kindName,
+ ELLIPSIFY(objectName, objectNameLen), interp->errorLine));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteProcedureMethod, CloneProcedureMethod --
+ *
+ * How to delete and clone procedure-like methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteProcedureMethodRecord(
+ ProcedureMethod *pmPtr)
+{
+ TclProcDeleteProc(pmPtr->procPtr);
+ if (pmPtr->deleteClientdataProc) {
+ pmPtr->deleteClientdataProc(pmPtr->clientData);
+ }
+ ckfree((char *) pmPtr);
+}
+
+static void
+DeleteProcedureMethod(
+ ClientData clientData)
+{
+ register ProcedureMethod *pmPtr = clientData;
+
+ if (--pmPtr->refCount < 1) {
+ DeleteProcedureMethodRecord(pmPtr);
+ }
+}
+
+static int
+CloneProcedureMethod(
+ Tcl_Interp *interp,
+ ClientData clientData,
+ ClientData *newClientData)
+{
+ ProcedureMethod *pmPtr = clientData;
+ ProcedureMethod *pm2Ptr = (ProcedureMethod *)
+ ckalloc(sizeof(ProcedureMethod));
+
+ memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
+ pm2Ptr->refCount = 1;
+ pm2Ptr->procPtr->refCount++;
+ if (pmPtr->cloneClientdataProc) {
+ pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
+ }
+ *newClientData = pm2Ptr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardMethod --
+ *
+ * Create a forwarded method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardInstanceMethod(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Object *oPtr, /* The object to attach the method to. */
+ int flags, /* Whether the method is public or not. */
+ Tcl_Obj *nameObj, /* The name of the method. */
+ Tcl_Obj *prefixObj) /* List of arguments that form the command
+ * prefix to forward to. */
+{
+ int prefixLen;
+ register ForwardMethod *fmPtr;
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ return NULL;
+ }
+ if (prefixLen < 1) {
+ Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+ NULL);
+ return NULL;
+ }
+
+ fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+ fmPtr->prefixObj = prefixObj;
+ Tcl_IncrRefCount(prefixObj);
+ return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
+ nameObj, flags, &fwdMethodType, fmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardMethod --
+ *
+ * Create a new forwarded method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardMethod(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Class *clsPtr, /* The class to attach the method to. */
+ int flags, /* Whether the method is public or not. */
+ Tcl_Obj *nameObj, /* The name of the method. */
+ Tcl_Obj *prefixObj) /* List of arguments that form the command
+ * prefix to forward to. */
+{
+ int prefixLen;
+ register ForwardMethod *fmPtr;
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ return NULL;
+ }
+ if (prefixLen < 1) {
+ Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+ NULL);
+ return NULL;
+ }
+
+ fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+ fmPtr->prefixObj = prefixObj;
+ Tcl_IncrRefCount(prefixObj);
+ return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ flags, &fwdMethodType, fmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeForwardMethod --
+ *
+ * How to invoke a forwarded method. Works by doing some ensemble-like
+ * command rearranging and then invokes some other Tcl command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeForwardMethod(
+ ClientData clientData, /* Pointer to some per-method context. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ ForwardMethod *fmPtr = clientData;
+ Tcl_Obj **argObjs, **prefixObjs;
+ int numPrefixes, result, len, skip = contextPtr->skip;
+
+ /*
+ * Build the real list of arguments to use. Note that we know that the
+ * prefixObj field of the ForwardMethod structure holds a reference to a
+ * non-empty list, so there's a whole class of failures ("not a list") we
+ * can ignore here.
+ */
+
+ Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
+ argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
+ numPrefixes, prefixObjs, &len);
+
+ result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+ TclStackFree(interp, argObjs);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteForwardMethod, CloneForwardMethod --
+ *
+ * How to delete and clone forwarded methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteForwardMethod(
+ ClientData clientData)
+{
+ ForwardMethod *fmPtr = clientData;
+
+ Tcl_DecrRefCount(fmPtr->prefixObj);
+ ckfree((char *) fmPtr);
+}
+
+static int
+CloneForwardMethod(
+ Tcl_Interp *interp,
+ ClientData clientData,
+ ClientData *newClientData)
+{
+ ForwardMethod *fmPtr = clientData;
+ ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+
+ fm2Ptr->prefixObj = fmPtr->prefixObj;
+ Tcl_IncrRefCount(fm2Ptr->prefixObj);
+ *newClientData = fm2Ptr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
+ *
+ * Utility functions used for procedure-like and forwarding method
+ * introspection.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Proc *
+TclOOGetProcFromMethod(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &procMethodType) {
+ ProcedureMethod *pmPtr = mPtr->clientData;
+
+ return pmPtr->procPtr;
+ }
+ return NULL;
+}
+
+Tcl_Obj *
+TclOOGetFwdFromMethod(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &fwdMethodType) {
+ ForwardMethod *fwPtr = mPtr->clientData;
+
+ return fwPtr->prefixObj;
+ }
+ return NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitEnsembleRewrite --
+ *
+ * Utility function that wraps up a lot of the complexity involved in
+ * doing ensemble-like command forwarding. Here is a picture of memory
+ * management plan:
+ *
+ * <-----------------objc---------------------->
+ * objv: |=============|===============================|
+ * <-toRewrite-> |
+ * \
+ * <-rewriteLength-> \
+ * rewriteObjs: |=================| \
+ * | |
+ * V V
+ * argObjs: |=================|===============================|
+ * <------------------*lengthPtr------------------->
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj **
+InitEnsembleRewrite(
+ Tcl_Interp *interp, /* Place to log the rewrite info. */
+ int objc, /* Number of real arguments. */
+ Tcl_Obj *const *objv, /* The real arguments. */
+ int toRewrite, /* Number of real arguments to replace. */
+ int rewriteLength, /* Number of arguments to insert instead. */
+ Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
+ int *lengthPtr) /* Where to write the resulting length of the
+ * array of rewritten arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ Tcl_Obj **argObjs;
+ unsigned len = rewriteLength + objc - toRewrite;
+
+ argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
+ memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
+ memcpy(argObjs + rewriteLength, objv + toRewrite,
+ sizeof(Tcl_Obj *) * (objc - toRewrite));
+
+ /*
+ * Now plumb this into the core ensemble rewrite logging system so that
+ * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
+ * how to store the rewrite rules get complex solely because of the case
+ * where an ensemble rewrites itself out of the picture; when that
+ * happens, the quality of the error message rewrite falls drastically
+ * (and unavoidably).
+ */
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
+ iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+ } else {
+ int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+ if (numIns < toRewrite) {
+ iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns;
+ iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs +=
+ rewriteLength - toRewrite;
+ }
+ }
+
+ *lengthPtr = len;
+ return argObjs;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * assorted trivial 'getter' functions
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_MethodDeclarerObject(
+ Tcl_Method method)
+{
+ return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
+}
+
+Tcl_Class
+Tcl_MethodDeclarerClass(
+ Tcl_Method method)
+{
+ return (Tcl_Class) ((Method *) method)->declaringClassPtr;
+}
+
+Tcl_Obj *
+Tcl_MethodName(
+ Tcl_Method method)
+{
+ return ((Method *) method)->namePtr;
+}
+
+int
+Tcl_MethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
+Tcl_MethodIsPublic(
+ Tcl_Method method)
+{
+ return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
+}
+
+/*
+ * Extended method construction for itcl-ng.
+ */
+
+Tcl_Method
+TclOONewProcInstanceMethodEx(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Tcl_Object oPtr, /* The object to modify. */
+ TclOO_PreCallProc preCallPtr,
+ TclOO_PostCallProc postCallPtr,
+ ProcErrorProc errProc,
+ ClientData clientData,
+ Tcl_Obj *nameObj, /* The name of the method, which must not be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which must not be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ int flags, /* Whether this is a public method. */
+ void **internalTokenPtr) /* If non-NULL, points to a variable that gets
+ * the reference to the ProcedureMethod
+ * structure. */
+{
+ ProcedureMethod *pmPtr;
+ Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp,
+ (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
+
+ if (method == NULL) {
+ return NULL;
+ }
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->preCallProc = preCallPtr;
+ pmPtr->postCallProc = postCallPtr;
+ pmPtr->errProc = errProc;
+ pmPtr->clientData = clientData;
+ if (internalTokenPtr != NULL) {
+ *internalTokenPtr = pmPtr;
+ }
+ return method;
+}
+
+Tcl_Method
+TclOONewProcMethodEx(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Tcl_Class clsPtr, /* The class to modify. */
+ TclOO_PreCallProc preCallPtr,
+ TclOO_PostCallProc postCallPtr,
+ ProcErrorProc errProc,
+ ClientData clientData,
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which may be NULL; if so, it is equivalent
+ * to an empty list. */
+ Tcl_Obj *bodyObj, /* The body of the method, which must not be
+ * NULL. */
+ int flags, /* Whether this is a public method. */
+ void **internalTokenPtr) /* If non-NULL, points to a variable that gets
+ * the reference to the ProcedureMethod
+ * structure. */
+{
+ ProcedureMethod *pmPtr;
+ Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp,
+ (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
+
+ if (method == NULL) {
+ return NULL;
+ }
+ pmPtr->flags = flags & USE_DECLARER_NS;
+ pmPtr->preCallProc = preCallPtr;
+ pmPtr->postCallProc = postCallPtr;
+ pmPtr->errProc = errProc;
+ pmPtr->clientData = clientData;
+ if (internalTokenPtr != NULL) {
+ *internalTokenPtr = pmPtr;
+ }
+ return method;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
new file mode 100644
index 0000000..b49dc12
--- /dev/null
+++ b/generic/tclOOStubInit.c
@@ -0,0 +1,79 @@
+/*
+ * $Id: tclOOStubInit.c,v 1.1 2008/05/31 11:42:19 dkf Exp $
+ *
+ * This file is (mostly) automatically generated from tclOO.decls.
+ * It is compiled and linked in with the tclOO package proper.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclOO.h"
+#include "tclOOInt.h"
+
+/* !BEGIN!: Do not edit below this line. */
+
+TclOOStubs tclOOStubs = {
+ TCL_STUB_MAGIC,
+ TCLOO_STUBS_EPOCH,
+ TCLOO_STUBS_REVISION,
+ 0,
+ Tcl_CopyObjectInstance, /* 0 */
+ Tcl_GetClassAsObject, /* 1 */
+ Tcl_GetObjectAsClass, /* 2 */
+ Tcl_GetObjectCommand, /* 3 */
+ Tcl_GetObjectFromObj, /* 4 */
+ Tcl_GetObjectNamespace, /* 5 */
+ Tcl_MethodDeclarerClass, /* 6 */
+ Tcl_MethodDeclarerObject, /* 7 */
+ Tcl_MethodIsPublic, /* 8 */
+ Tcl_MethodIsType, /* 9 */
+ Tcl_MethodName, /* 10 */
+ Tcl_NewInstanceMethod, /* 11 */
+ Tcl_NewMethod, /* 12 */
+ Tcl_NewObjectInstance, /* 13 */
+ Tcl_ObjectDeleted, /* 14 */
+ Tcl_ObjectContextIsFiltering, /* 15 */
+ Tcl_ObjectContextMethod, /* 16 */
+ Tcl_ObjectContextObject, /* 17 */
+ Tcl_ObjectContextSkippedArgs, /* 18 */
+ Tcl_ClassGetMetadata, /* 19 */
+ Tcl_ClassSetMetadata, /* 20 */
+ Tcl_ObjectGetMetadata, /* 21 */
+ Tcl_ObjectSetMetadata, /* 22 */
+ Tcl_ObjectContextInvokeNext, /* 23 */
+ Tcl_ObjectGetMethodNameMapper, /* 24 */
+ Tcl_ObjectSetMethodNameMapper, /* 25 */
+ Tcl_ClassSetConstructor, /* 26 */
+ Tcl_ClassSetDestructor, /* 27 */
+};
+
+TclOOIntStubs tclOOIntStubs = {
+ TCL_STUB_MAGIC,
+ TCLOOINT_STUBS_EPOCH,
+ TCLOOINT_STUBS_REVISION,
+ 0,
+ TclOOGetDefineCmdContext, /* 0 */
+ TclOOMakeProcInstanceMethod, /* 1 */
+ TclOOMakeProcMethod, /* 2 */
+ TclOONewProcInstanceMethod, /* 3 */
+ TclOONewProcMethod, /* 4 */
+ TclOOObjectCmdCore, /* 5 */
+ TclOOIsReachable, /* 6 */
+ TclOONewForwardMethod, /* 7 */
+ TclOONewForwardInstanceMethod, /* 8 */
+ TclOONewProcInstanceMethodEx, /* 9 */
+ TclOONewProcMethodEx, /* 10 */
+ TclOOInvokeObject, /* 11 */
+ TclOOObjectSetFilters, /* 12 */
+ TclOOClassSetFilters, /* 13 */
+ TclOOObjectSetMixins, /* 14 */
+ TclOOClassSetMixins, /* 15 */
+};
+
+/* !END!: Do not edit above this line. */
+
+struct TclOOStubAPI tclOOStubAPI = {
+ &tclOOStubs,
+ &tclOOIntStubs
+};
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
new file mode 100644
index 0000000..6988638
--- /dev/null
+++ b/generic/tclOOStubLib.c
@@ -0,0 +1,82 @@
+/*
+ * $Id: tclOOStubLib.c,v 1.1 2008/05/31 11:42:19 dkf Exp $
+ * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tcl.h"
+
+#define USE_TCLOO_STUBS 1
+#include "tclOO.h"
+#include "tclOOInt.h"
+
+const TclOOStubs *tclOOStubsPtr;
+const TclOOIntStubs *tclOOIntStubsPtr;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclOOInitializeStubs --
+ * Load the tclOO package, initialize stub table pointer. Do not call
+ * this function directly, use Tcl_OOInitStubs() macro instead.
+ *
+ * Results:
+ * The actual version of the package that satisfies the request, or NULL
+ * to indicate that an error occurred.
+ *
+ * Side effects:
+ * Sets the stub table pointer.
+ *
+ */
+
+const char *TclOOInitializeStubs(
+ Tcl_Interp *interp, const char *version, int epoch, int revision)
+{
+ int exact = 0;
+ const char *packageName = "TclOO";
+ const char *errMsg = NULL;
+ ClientData clientData = NULL;
+ const char *actualVersion =
+ Tcl_PkgRequireEx(interp, packageName,version, exact, &clientData);
+ struct TclOOStubAPI *stubsAPIPtr = clientData;
+
+ if (stubsAPIPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "Error loading ", packageName, " package; ",
+ "package not present or incomplete", NULL);
+ return NULL;
+ } else {
+ TclOOStubs *stubsPtr = stubsAPIPtr->stubsPtr;
+ TclOOIntStubs *intStubsPtr = stubsAPIPtr->intStubsPtr;
+
+ if (!actualVersion) {
+ return NULL;
+ }
+
+ if (!stubsPtr || !intStubsPtr) {
+ errMsg = "missing stub table pointer";
+ goto error;
+ }
+ if (stubsPtr->epoch != epoch || intStubsPtr->epoch != epoch) {
+ errMsg = "epoch number mismatch";
+ goto error;
+ }
+ if (stubsPtr->revision<revision || intStubsPtr->revision<revision) {
+ errMsg = "require later revision";
+ goto error;
+ }
+
+ tclOOStubsPtr = stubsPtr;
+ tclOOIntStubsPtr = intStubsPtr;
+ return actualVersion;
+
+ error:
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "Error loading ", packageName, " package",
+ " (requested version '", version, "', loaded version '",
+ actualVersion, "'): ", errMsg, NULL);
+ return NULL;
+ }
+}