diff options
Diffstat (limited to 'generic/tclOO.c')
| -rw-r--r-- | generic/tclOO.c | 3288 |
1 files changed, 3288 insertions, 0 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c new file mode 100644 index 0000000..bca3477 --- /dev/null +++ b/generic/tclOO.c @@ -0,0 +1,3288 @@ +/* + * tclOO.c -- + * + * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) + * + * Copyright (c) 2005-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: tclOO.c,v 1.2 2006/10/20 14:04:00 dkf Exp $ + */ + +#include "tclInt.h" +#include "tclOO.h" + +/* + * Commands in oo::define. + */ + +static const struct { + const char *name; + Tcl_ObjCmdProc *objProc; + int flag; +} defineCmds[] = { + {"constructor", TclOODefineConstructorObjCmd, 0}, + {"copy", TclOODefineCopyObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"self.export", TclOODefineExportObjCmd, 1}, + {"filter", TclOODefineFilterObjCmd, 0}, + {"self.filter", TclOODefineFilterObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"self.forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 0}, + {"self.method", TclOODefineMethodObjCmd, 1}, + {"mixin", TclOODefineMixinObjCmd, 0}, + {"self.mixin", TclOODefineMixinObjCmd, 1}, +#ifdef SUPPORT_OO_PARAMETERS + {"parameter", TclOODefineParameterObjCmd, 0}, +#endif + {"superclass", TclOODefineSuperclassObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, + {"self.unexport", TclOODefineUnexportObjCmd, 1}, + {"self.class", TclOODefineSelfClassObjCmd, 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); +static Method * CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, + Method *mPtr, Tcl_Obj *namePtr); +static Method * CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, + Method *mPtr, Tcl_Obj *namePtr); +static void DeclareClassMethod(Tcl_Interp *interp, Class *clsPtr, + const char *name, int isPublic, + Tcl_MethodCallProc callProc); +static void KillFoundation(ClientData clientData, + Tcl_Interp *interp); +static int ObjectCmd(Object *oPtr, Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv, int publicOnly, + Tcl_HashTable *cachePtr); +static void ObjectNamespaceDeleted(ClientData clientData); +static void ObjectDeletedTrace(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); + +static int SimpleInvoke(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int InvokeProcedureMethod(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static void DeleteProcedureMethod(ClientData clientData); +static int CloneProcedureMethod(ClientData clientData, + ClientData *newClientData); +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(ClientData clientData, + ClientData *newClientData); +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 ClassCreate(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, + Tcl_Obj *const *objv); +static int ClassNew(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, + Tcl_Obj *const *objv); +static int ObjectDestroy(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjectEval(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, + Tcl_Obj *const *objv); +static int ObjectLinkVar(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjectUnknown(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjectVarName(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); + +static int NextObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int SelfObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); + +/* + * 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 +}; +static const Tcl_MethodType coreMethodType = { + TCL_OO_METHOD_VERSION_CURRENT, "core method", + SimpleInvoke, NULL, NULL +}; + +/* + * ---------------------------------------------------------------------- + * + * 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. */ +{ + Interp *iPtr = (Interp *) interp; + Foundation *fPtr; + int i; + Tcl_DString buffer; + + /* + * Construct the foundation of the object system. This is a structure + * holding references to the magical bits that need to be known about in + * other places. + */ + + fPtr = iPtr->ooFoundation = (Foundation *) ckalloc(sizeof(Foundation)); + memset(fPtr, 0, sizeof(Foundation)); + 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->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::next", NextObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::self", SelfObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, + NULL); + 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); + } + fPtr->epoch = 0; + fPtr->nsCount = 0; + fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(fPtr->unknownMethodNameObj); + + Tcl_CallWhenDeleted(interp, KillFoundation, fPtr); + + /* + * Create the objects at the core of the object system. These need to be + * spliced manually. + */ + + fPtr->objectCls = AllocClass(interp, AllocObject(interp, "::oo::object")); + fPtr->classCls = AllocClass(interp, AllocObject(interp, "::oo::class")); + 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. + */ + + DeclareClassMethod(interp, fPtr->objectCls, "destroy", 1, ObjectDestroy); + DeclareClassMethod(interp, fPtr->objectCls, "eval", 0, ObjectEval); + DeclareClassMethod(interp, fPtr->objectCls, "unknown", 0, ObjectUnknown); + DeclareClassMethod(interp, fPtr->objectCls, "variable", 0, ObjectLinkVar); + DeclareClassMethod(interp, fPtr->objectCls, "varname", 0, ObjectVarName); + DeclareClassMethod(interp, fPtr->classCls, "create", 1, ClassCreate); + DeclareClassMethod(interp, fPtr->classCls, "new", 1, ClassNew); + + /* + * Finish setting up the class of classes. + */ + + { + Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + + /* + * Mark the 'new' method in oo::class as private; classes, unlike + * general objects, must have explicit names. + */ + + namePtr = Tcl_NewStringObj("new", -1); + Tcl_NewMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr, + 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 = TclOONewProcClassMethod(interp, + fPtr->classCls, 0, NULL, argsPtr, bodyPtr); + } + + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * 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 = clientData; + + TclDecrRefCount(fPtr->unknownMethodNameObj); + 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. */ +{ + Foundation *fPtr = ((Interp *) interp)->ooFoundation; + Tcl_Obj *cmdnameObj; + Tcl_DString buffer; + Object *oPtr; + + oPtr = (Object *) ckalloc(sizeof(Object)); + memset(oPtr, 0, sizeof(Object)); + while (1) { + char objName[10 + TCL_INTEGER_SPACE]; + + sprintf(objName, "::oo::Obj%d", ++fPtr->nsCount); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + 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); + } + TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); + oPtr->selfCls = fPtr->objectCls; + Tcl_InitObjHashTable(&oPtr->methods); + Tcl_InitObjHashTable(&oPtr->publicContextCache); + Tcl_InitObjHashTable(&oPtr->privateContextCache); + oPtr->filters.num = 0; + oPtr->filters.list = NULL; + oPtr->mixins.num = 0; + oPtr->mixins.list = NULL; + oPtr->classPtr = NULL; + oPtr->flags = 0; + oPtr->metadataPtr = NULL; + + /* + * Initialize the traces. + */ + + Tcl_DStringInit(&buffer); + if (nameStr) { + if (nameStr[0] != ':' || nameStr[1] != ':') { + Tcl_DStringAppend(&buffer, + Tcl_GetCurrentNamespace(interp)->fullName, -1); + Tcl_DStringAppend(&buffer, "::", 2); + } + Tcl_DStringAppend(&buffer, nameStr, -1); + } else { + Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1); + } + oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + PublicObjectCmd, oPtr, NULL); + if (nameStr) { + Tcl_DStringFree(&buffer); + Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1); + } + Tcl_DStringAppend(&buffer, "::my", 4); + oPtr->myCommand = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + PrivateObjectCmd, oPtr, NULL); + Tcl_DStringFree(&buffer); + + TclNewObj(cmdnameObj); + Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); + Tcl_TraceCommand(interp, TclGetString(cmdnameObj), + TCL_TRACE_DELETE, ObjectDeletedTrace, oPtr); + TclDecrRefCount(cmdnameObj); + + return oPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectDeletedTrace -- + * + * 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 +ObjectDeletedTrace( + 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? */ +{ + Interp *iPtr = (Interp *) interp; + Object *oPtr = clientData; + Class *clsPtr; + + Tcl_Preserve(oPtr); + oPtr->flags |= OBJECT_DELETED; + if (!Tcl_InterpDeleted(interp)) { + CallContext *contextPtr = TclOOGetCallContext(iPtr->ooFoundation, + oPtr, NULL, DESTRUCTOR, NULL); + + if (contextPtr != NULL) { + int result; + Tcl_InterpState state; + + contextPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = TclOOInvokeContext(interp, contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + } + (void) Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } + + clsPtr = oPtr->classPtr; + if (clsPtr != NULL) { + ReleaseClassContents(interp, oPtr); + } + + Tcl_DeleteNamespace(oPtr->namespacePtr); + if (clsPtr) { + Tcl_Release(clsPtr); + } + Tcl_Release(oPtr); + + /* + * What else to do to delete an object? + */ +} + +/* + * ---------------------------------------------------------------------- + * + * 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, **list; + Object **insts; + + clsPtr = oPtr->classPtr; + Tcl_Preserve(clsPtr); + + /* + * 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++) { + Tcl_Preserve(list[i]); + } + for (i=0 ; i<n ; i++) { + if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) { + Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); + } + Tcl_Release(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++) { + Tcl_Preserve(list[i]); + } + for (i=0 ; i<n ; i++) { + if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) { + Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); + } + Tcl_Release(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++) { + Tcl_Preserve(insts[i]); + } + for (i=0 ; i<n ; i++) { + if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) { + Tcl_DeleteCommandFromToken(interp, insts[i]->command); + } + Tcl_Release(insts[i]); + } + if (insts != NULL) { + ckfree((char *) insts); + } + + if (clsPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, clsPtr->filters) { + TclDecrRefCount(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, *mixinPtr; + CallContext *contextPtr; + Method *mPtr; + Tcl_Obj *filterObj; + int i; + + /* + * Instruct everyone to no longer use any allocated fields of the object. + */ + + if (!(oPtr->flags & OBJECT_DELETED)) { + Tcl_Preserve(oPtr); + if (oPtr->classPtr != NULL) { + 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) { + TclDecrRefCount(filterObj); + } + if (i) { + ckfree((char *)oPtr->filters.list); + } + FOREACH_HASH_VALUE(mPtr, &oPtr->methods) { + TclOODeleteMethod(mPtr); + } + Tcl_DeleteHashTable(&oPtr->methods); + FOREACH_HASH_VALUE(contextPtr, &oPtr->publicContextCache) { + if (contextPtr) { + TclOODeleteContext(contextPtr); + } + } + Tcl_DeleteHashTable(&oPtr->publicContextCache); + FOREACH_HASH_VALUE(contextPtr, &oPtr->privateContextCache) { + if (contextPtr) { + TclOODeleteContext(contextPtr); + } + } + Tcl_DeleteHashTable(&oPtr->privateContextCache); + + if (oPtr->metadataPtr != NULL) { + FOREACH_HASH_DECLS; + 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; + } + + clsPtr = oPtr->classPtr; + if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) { + Class *superPtr, *mixinPtr; + + clsPtr->flags |= OBJECT_DELETED; + FOREACH(mixinPtr, clsPtr->mixins) { + if (!(mixinPtr->flags & OBJECT_DELETED)) { + TclOORemoveFromSubclasses(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; + } + if (clsPtr->classHierarchy.list) { + ckfree((char *) clsPtr->classHierarchy.list); + clsPtr->classHierarchy.num = 0; + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODeleteMethod(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODeleteMethod(clsPtr->constructorPtr); + TclOODeleteMethod(clsPtr->destructorPtr); + Tcl_EventuallyFree(clsPtr, TCL_DYNAMIC); + } + + /* + * Delete the object structure itself. + */ + + if (!(oPtr->flags & OBJECT_DELETED)) { + Tcl_EventuallyFree(oPtr, TCL_DYNAMIC); + Tcl_Release(oPtr); + } else { + Tcl_EventuallyFree(oPtr, TCL_DYNAMIC); + } +} + +/* + * ---------------------------------------------------------------------- + * + * 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. */ +{ + Class *clsPtr; + Foundation *fPtr = ((Interp *) interp)->ooFoundation; + + clsPtr = (Class *) ckalloc(sizeof(Class)); + memset(clsPtr, 0, sizeof(Class)); + if (useThisObj == NULL) { + clsPtr->thisPtr = AllocObject(interp, NULL); + } else { + clsPtr->thisPtr = useThisObj; + } + clsPtr->thisPtr->selfCls = fPtr->classCls; + if (fPtr->classCls != NULL) { + TclOOAddToInstances(clsPtr->thisPtr, fPtr->classCls); + TclOOAddToSubclasses(clsPtr, fPtr->objectCls); + } + { + Tcl_Namespace *path[2]; + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } + clsPtr->thisPtr->classPtr = clsPtr; + clsPtr->flags = 0; + clsPtr->superclasses.num = 1; + clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *)); + clsPtr->superclasses.list[0] = fPtr->objectCls; + clsPtr->subclasses.num = 0; + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.size = 0; + clsPtr->instances.num = 0; + clsPtr->instances.list = NULL; + clsPtr->instances.size = 0; + clsPtr->filters.list = NULL; + clsPtr->filters.num = 0; + clsPtr->mixins.list = NULL; + clsPtr->mixins.num = 0; + clsPtr->mixinSubs.list = NULL; + clsPtr->mixinSubs.num = 0; + clsPtr->mixinSubs.size = 0; + clsPtr->classHierarchy.list = NULL; + clsPtr->classHierarchy.num = 0; + clsPtr->classHierarchyEpoch = fPtr->epoch-1; + Tcl_InitObjHashTable(&clsPtr->classMethods); + clsPtr->constructorPtr = NULL; + clsPtr->destructorPtr = NULL; + clsPtr->metadataPtr = NULL; + 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 *name, /* Name of object to create, 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. */ +{ + Object *oPtr = AllocObject(interp, NULL); + CallContext *contextPtr; + + oPtr->selfCls = (Class *) cls; + TclOOAddToInstances(oPtr, (Class *) cls); + + if (name != NULL) { + Tcl_Obj *cmdnameObj; + + TclNewObj(cmdnameObj); + Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); + if (TclRenameCommand(interp, TclGetString(cmdnameObj), + name) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't create object \"", name, + "\": command already exists with that name", NULL); + TclDecrRefCount(cmdnameObj); + Tcl_DeleteCommandFromToken(interp, oPtr->command); + return NULL; + } + TclDecrRefCount(cmdnameObj); + } + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable((((Interp *) interp)->ooFoundation)->classCls, + (Class *) cls)) { + /* + * 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. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = (Class *) cls; // Repatch + } + + if (objc >= 0) { + contextPtr = TclOOGetCallContext(((Interp *)interp)->ooFoundation, + oPtr, NULL, CONSTRUCTOR, NULL); + if (contextPtr != NULL) { + int result; + Tcl_InterpState state; + + Tcl_Preserve(oPtr); + state = Tcl_SaveInterpState(interp, TCL_OK); + contextPtr->flags |= CONSTRUCTOR; + contextPtr->skip = skip; + result = TclOOInvokeContext(interp, contextPtr, objc, objv); + TclOODeleteContext(contextPtr); + Tcl_Release(oPtr); + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + Tcl_DeleteCommandFromToken(interp, oPtr->command); + return NULL; + } + (void) 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) +{ + Object *oPtr = (Object *) sourceObject, *o2Ptr; + Interp *iPtr = (Interp *) interp; + 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 == iPtr->ooFoundation->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, -1, NULL, -1); + if (o2Ptr == NULL) { + return NULL; + } + + /* + * Copy the object-local methods to the new object. + */ + + FOREACH_HASH(keyPtr, mPtr, &oPtr->methods) { + (void) CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr); + } + + /* + * 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) { + continue; + } + duplicate = metadataTypePtr->cloneProc(value); + 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) { + (void) CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr); + } + if (clsPtr->constructorPtr) { + cls2Ptr->constructorPtr = CloneClassMethod(interp, cls2Ptr, + clsPtr->constructorPtr, NULL); + } + if (clsPtr->destructorPtr) { + cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr, + clsPtr->destructorPtr, 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) { + continue; + } + duplicate = metadataTypePtr->cloneProc(value); + 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 Method * +CloneObjectMethod( + Tcl_Interp *interp, + Object *oPtr, + Method *mPtr, + Tcl_Obj *namePtr) +{ + if (mPtr->typePtr == NULL) { + return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(mPtr->clientData, + &newClientData) != TCL_OK) { + return NULL; + } + return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); + } else { + return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); + } +} + +static Method * +CloneClassMethod( + Tcl_Interp *interp, + Class *clsPtr, + Method *mPtr, + Tcl_Obj *namePtr) +{ + if (mPtr->typePtr == NULL) { + return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(mPtr->clientData, + &newClientData) != TCL_OK) { + return NULL; + } + return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + newClientData); + } else { + return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + mPtr->clientData); + } +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_NewMethod -- + * + * Attach a method to an object. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_NewMethod( + 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 isPublic, /* 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; + } + hPtr = Tcl_CreateHashEntry(&oPtr->methods, (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->flags = 0; + mPtr->declaringObjectPtr = oPtr; + mPtr->declaringClassPtr = NULL; + if (isPublic) { + mPtr->flags |= PUBLIC_METHOD; + } + oPtr->epoch++; + return (Tcl_Method) mPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_NewClassMethod -- + * + * Attach a method to a class. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_NewClassMethod( + 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 isPublic, /* 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: + ((Interp *) interp)->ooFoundation->epoch++; + mPtr->typePtr = typePtr; + mPtr->clientData = clientData; + mPtr->flags = 0; + mPtr->declaringObjectPtr = NULL; + mPtr->declaringClassPtr = clsPtr; + if (isPublic) { + mPtr->flags |= PUBLIC_METHOD; + } + + return (Tcl_Method) mPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteMethodStruct -- + * + * Function used when deleting a method. Always called indirectly via + * Tcl_EventuallyFree(). + * + * ---------------------------------------------------------------------- + */ + +static void +DeleteMethodStruct( + char *buffer) +{ + Method *mPtr = (Method *) buffer; + + if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { + mPtr->typePtr->deleteProc(mPtr->clientData); + } + if (mPtr->namePtr != NULL) { + TclDecrRefCount(mPtr->namePtr); + } + + ckfree(buffer); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODeleteMethod -- + * + * How to delete a method. + * + * ---------------------------------------------------------------------- + */ + +void +TclOODeleteMethod( + Method *mPtr) +{ + if (mPtr != NULL) { + Tcl_EventuallyFree(mPtr, DeleteMethodStruct); + } +} + +/* + * ---------------------------------------------------------------------- + * + * DeclareClassMethod -- + * + * Helper that makes it cleaner to create very simple methods during + * basic system initialization. Not suitable for general use. + * + * ---------------------------------------------------------------------- + */ + +static void +DeclareClassMethod( + Tcl_Interp *interp, + Class *clsPtr, /* Class to attach the method to. */ + const char *name, /* Name of the method. */ + int isPublic, /* Whether the method is public. */ + Tcl_MethodCallProc callPtr) + /* Method implementation function. */ +{ + Tcl_Obj *namePtr; + + TclNewStringObj(namePtr, name, strlen(name)); + Tcl_IncrRefCount(namePtr); + Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, isPublic, + &coreMethodType, callPtr); + TclDecrRefCount(namePtr); +} + +/* + * ---------------------------------------------------------------------- + * + * SimpleInvoke -- + * + * How to invoke a simple method. + * + * ---------------------------------------------------------------------- + */ + +static int +SimpleInvoke( + ClientData clientData, /* Pointer to function that implements the + * method. */ + Tcl_Interp *interp, + Tcl_ObjectContext context, /* The method calling context. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Arguments as actually seen. */ +{ + Tcl_MethodCallProc callPtr = clientData; + + return (*callPtr)(NULL, interp, context, objc, objv); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewProcMethod -- + * + * Create a new procedure-like method for an object. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewProcMethod( + Tcl_Interp *interp, /* The interpreter containing the object. */ + Object *oPtr, /* The object to modify. */ + int isPublic, /* 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. */ +{ + int argsc; + Tcl_Obj **argsv; + register ProcedureMethod *pmPtr; + const char *procName; + + if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) { + return NULL; + } + pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); + procName = TclGetString(nameObj); + if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj, + &pmPtr->procPtr) != TCL_OK) { + ckfree((char *) pmPtr); + return NULL; + } + return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj, + isPublic, &procMethodType, pmPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewProcClassMethod -- + * + * Create a new procedure-like method for a class. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewProcClassMethod( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Class *clsPtr, /* The class to modify. */ + int isPublic, /* 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. */ +{ + int argsLen; /* -1 => delete argsObj before exit */ + register ProcedureMethod *pmPtr; + const char *procName; + + if (argsObj == NULL) { + argsLen = -1; + TclNewObj(argsObj); + 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)); + if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj, + &pmPtr->procPtr) != TCL_OK) { + if (argsLen == -1) { + TclDecrRefCount(argsObj); + } + ckfree((char *) pmPtr); + return NULL; + } + if (argsLen == -1) { + TclDecrRefCount(argsObj); + } + return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj, + isPublic, &procMethodType, pmPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * InvokeProcedureMethod -- + * + * 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. */ +{ + CallContext *contextPtr = (CallContext *) context; + ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; + int result, flags = FRAME_IS_METHOD, skip = contextPtr->skip; + CallFrame *framePtr, **framePtrPtr; + Object *oPtr = contextPtr->oPtr; + Command cmd; + const char *namePtr; + Tcl_Obj *nameObj; + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + pmPtr->procPtr->cmdPtr = &cmd; + if (contextPtr->flags & CONSTRUCTOR) { + namePtr = "<constructor>"; + flags |= FRAME_IS_CONSTRUCTOR; + nameObj = Tcl_NewStringObj("<constructor>", -1); + Tcl_IncrRefCount(nameObj); + } else if (contextPtr->flags & DESTRUCTOR) { + namePtr = "<destructor>"; + flags |= FRAME_IS_DESTRUCTOR; + nameObj = Tcl_NewStringObj("<destructor>", -1); + Tcl_IncrRefCount(nameObj); + } else { + nameObj = objv[contextPtr->skip-1]; + namePtr = TclGetString(nameObj); + } + result = TclProcCompileProc(interp, pmPtr->procPtr, + pmPtr->procPtr->bodyPtr, (Namespace *) oPtr->namespacePtr, + "body of method", namePtr); + if (result != TCL_OK) { + return result; + } + + if (contextPtr->callChain[contextPtr->index].isFilter) { + flags |= FRAME_IS_FILTER; + } + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + oPtr->namespacePtr, flags); + if (result != TCL_OK) { + return result; + } + framePtr->ooContextPtr = contextPtr; + framePtr->objc = objc; + framePtr->objv = objv; /* ref counts for args are incremented below */ + framePtr->procPtr = pmPtr->procPtr; + + if (contextPtr->flags & OO_UNKNOWN_METHOD) { + skip--; + } + result = TclObjInterpProcCore(interp, framePtr, nameObj, skip); + if (contextPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) { + TclDecrRefCount(nameObj); + } + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteProcedureMethod, CloneProcedureMethod -- + * + * How to delete and clone procedure-like methods. + * + * ---------------------------------------------------------------------- + */ + +static void +DeleteProcedureMethod( + ClientData clientData) +{ + register ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; + + TclProcDeleteProc(pmPtr->procPtr); + ckfree((char *) pmPtr); +} + +static int +CloneProcedureMethod( + ClientData clientData, + ClientData *newClientData) +{ + ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; + ProcedureMethod *pm2Ptr = (ProcedureMethod *) + ckalloc(sizeof(ProcedureMethod)); + + pm2Ptr->procPtr = pmPtr->procPtr; + pm2Ptr->procPtr->refCount++; + *newClientData = pm2Ptr; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewForwardMethod -- + * + * Create a forwarded method for an object. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewForwardMethod( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + Object *oPtr, /* The object to attach the method to. */ + int isPublic, /* 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_Object) oPtr, nameObj, + isPublic, &fwdMethodType, fmPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewForwardClassMethod -- + * + * Create a new forwarded method for a class. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewForwardClassMethod( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + Class *clsPtr, /* The class to attach the method to. */ + int isPublic, /* 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_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj, + isPublic, &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 = (ForwardMethod *) clientData; + Tcl_Obj **argObjs, **prefixObjs; + int numPrefixes, result, len; + + /* + * 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, contextPtr->skip, + numPrefixes, prefixObjs, &len); + + result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE); + ckfree((char *) argObjs); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteForwardMethod, CloneForwardMethod -- + * + * How to delete and clone forwarded methods. + * + * ---------------------------------------------------------------------- + */ + +static void +DeleteForwardMethod( + ClientData clientData) +{ + ForwardMethod *fmPtr = (ForwardMethod *) clientData; + + TclDecrRefCount(fmPtr->prefixObj); + ckfree((char *) fmPtr); +} + +static int +CloneForwardMethod( + ClientData clientData, + ClientData *newClientData) +{ + ForwardMethod *fmPtr = (ForwardMethod *) clientData; + ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); + + fm2Ptr->prefixObj = fmPtr->prefixObj; + Tcl_IncrRefCount(fm2Ptr->prefixObj); + *newClientData = fm2Ptr; + 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; + } else { + 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) { + 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; + } else { + 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) { + 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, ObjectCmd -- + * + * Main entry point for object invokations. The Public* and Private* + * wrapper functions are just thin wrappers round the main ObjectCmd + * function that does call chain creation, management and invokation. + * + * ---------------------------------------------------------------------- + */ + +static int +PublicObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return ObjectCmd(clientData, interp, objc, objv, 1, + &((Object *)clientData)->publicContextCache); +} + +static int +PrivateObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return ObjectCmd(clientData, interp, objc, objv, 0, + &((Object *)clientData)->privateContextCache); +} + +static int +ObjectCmd( + 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 publicOnly, /* Whether this is an invokation through the + * public or the private command interface. */ + Tcl_HashTable *cachePtr) /* What call chain cache to use. */ +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr; + int result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?"); + return TCL_ERROR; + } + + contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, objv[1], + (publicOnly ? PUBLIC_METHOD :0) | (oPtr->flags & FILTER_HANDLING), + cachePtr); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "impossible to invoke method \"", + TclGetString(objv[1]), + "\": no defined method or unknown method", NULL); + return TCL_ERROR; + } + + Tcl_Preserve(oPtr); + result = TclOOInvokeContext(interp, contextPtr, objc, objv); + if (!(contextPtr->flags & OO_UNKNOWN_METHOD) + && !(oPtr->flags & OBJECT_DELETED)) { + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(cachePtr, (char *) objv[1]); + if (hPtr != NULL && Tcl_GetHashValue(hPtr) == NULL) { + Tcl_SetHashValue(hPtr, contextPtr); + } else { + TclOODeleteContext(contextPtr); + } + } else { + TclOODeleteContext(contextPtr); + } + Tcl_Release(oPtr); + + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassCreate -- + * + * Implementation for oo::class->create method. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassCreate( + 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; + + TclNewObj(cmdnameObj); + Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); + Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), + "\" is not a class", NULL); + TclDecrRefCount(cmdnameObj); + 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, objc, objv, Tcl_ObjectContextSkippedArgs(context)+1); + if (newObject == NULL) { + return TCL_ERROR; + } + Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject), + Tcl_GetObjResult(interp)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassNew -- + * + * Implementation for oo::class->new method. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassNew( + 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; + + TclNewObj(cmdnameObj); + Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); + Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), + "\" is not a class", NULL); + TclDecrRefCount(cmdnameObj); + return TCL_ERROR; + } + + /* + * Make the object and return its name. + */ + + newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, + NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context)); + if (newObject == NULL) { + return TCL_ERROR; + } + Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject), + Tcl_GetObjResult(interp)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectDestroy -- + * + * Implementation for oo::object->destroy method. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjectDestroy( + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectEval -- + * + * Implementation for oo::object->eval method. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjectEval( + 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->flags & PUBLIC_METHOD) { + TclNewObj(objnameObj); + Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(object), + objnameObj); + } else { + TclNewStringObj(objnameObj, "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) { + TclFormatToErrorInfo(interp, + "\n (in \"%s eval\" script line %d)", + TclGetString(objnameObj), interp->errorLine); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + TclDecrRefCount(objnameObj); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectUnknown -- + * + * Default unknown method handler method (defined in oo::object). This + * just creates a suitable error message. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjectUnknown( + 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; + + /* + * Get the list of methods that we want to know about. + */ + + numMethodNames = TclOOGetSortedMethodList(oPtr, + contextPtr->flags & PUBLIC_METHOD, &methodNames); + + /* + * Special message when there are no visible methods at all. + */ + + if (numMethodNames == 0) { + Tcl_Obj *tmpBuf; + + TclNewObj(tmpBuf); + Tcl_GetCommandFullName(interp, oPtr->command, tmpBuf); + Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), + "\" has no visible methods", NULL); + TclDecrRefCount(tmpBuf); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, "unknown method \"", + TclGetString(objv[Tcl_ObjectContextSkippedArgs(context)-1]), + "\": 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; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectLinkVar -- + * + * Implementation of oo::object->variable method. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjectLinkVar( + 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; + Tcl_Obj **argObjs; + const char *varName; + int len; + + /* + * Parse to see if we have a single value in the argument (just the + * name of a variable to use in both the namespace and local scope) or + * a two-argument list (namespace variable name and local variable + * name). Other cases are an error. + */ + + if (Tcl_ListObjGetElements(interp, objv[i], &len, &argObjs)!=TCL_OK) { + return TCL_ERROR; + } + if (len != 1 && len != 2) { + Tcl_AppendResult(interp, "argument must be list " + "of one or two variable names", NULL); + return TCL_ERROR; + } + + varName = TclGetString(argObjs[len-1]); + if (strstr(varName, "::") != NULL) { + /* + * The local var name must not contain a '::' but the ns name is + * OK. Naturally, if they're the same, then the restriction is + * applied equally to both. + */ + + 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, argObjs[0], 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, TclGetString(argObjs[0]), 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); + varPtr->refCount++; + } + + if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectVarName -- + * + * Implementation of the oo::object->varname method. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjectVarName( + 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; + } + + TclNewObj(varNamePtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); + Tcl_SetObjResult(interp, varNamePtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * NextObjCmd -- + * + * Implementation of the [next] command. Note that this command is only + * ever to be used inside the body of a procedure-like method. + * + * ---------------------------------------------------------------------- + */ + +static int +NextObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr, *savedFramePtr; + CallContext *contextPtr; + int index, result, skip; + + /* + * 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->ooContextPtr; + + index = contextPtr->index; + skip = contextPtr->skip; + if (index+1 >= contextPtr->numCallChain) { + Tcl_AppendResult(interp, "no superclass ", + (contextPtr->flags & CONSTRUCTOR ? "constructor" : + (contextPtr->flags & DESTRUCTOR ? "destructor" : "method")), + " implementation", NULL); + return TCL_ERROR; + } + + /* + * Advance to the next method implementation in the chain in the method + * call context while we process the body. However, need to adjust the + * argument-skip control because we're guaranteed to have a single prefix + * arg (i.e., 'next') and not the variable amount that can happen because + * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * (i.e., '$cls new' and '$cls create obj') and destructors (no args at + * all) come through the same code. From here on, the skip is always 1. + */ + + contextPtr->index = index+1; + contextPtr->skip = 1; + + /* + * Invoke the (advanced) method call context in the caller context. Note + * that this is like [uplevel 1] and not [eval]. + */ + + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = savedFramePtr->callerVarPtr; + result = TclOOInvokeContext(interp, contextPtr, objc, objv); + iPtr->varFramePtr = savedFramePtr; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = index; + contextPtr->skip = skip; + + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * SelfObjCmd -- + * + * Implementation of the [self] command, which provides introspection of + * the call context. + * + * ---------------------------------------------------------------------- + */ + +static int +SelfObjCmd( + 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; + + /* + * 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->ooContextPtr; + + /* + * 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; + } + 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_GetCommandFullName(interp, contextPtr->oPtr->command, + Tcl_GetObjResult(interp)); + return TCL_OK; + case SELF_NS: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + contextPtr->oPtr->namespacePtr->fullName,-1)); + return TCL_OK; + case SELF_CLASS: { + Method *mPtr = contextPtr->callChain[contextPtr->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_GetCommandFullName(interp, declarerPtr->command, + Tcl_GetObjResult(interp)); + return TCL_OK; + } + case SELF_METHOD: + if (contextPtr->flags & CONSTRUCTOR) { + Tcl_AppendResult(interp, "<constructor>", NULL); + } else if (contextPtr->flags & DESTRUCTOR) { + Tcl_AppendResult(interp, "<destructor>", NULL); + } else { + Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; + + Tcl_SetObjResult(interp, mPtr->namePtr); + } + return TCL_OK; + case SELF_FILTER: + if (!contextPtr->callChain[contextPtr->index].isFilter) { + Tcl_AppendResult(interp, "not inside a filtering context", NULL); + return TCL_ERROR; + } else { + Method *mPtr = + contextPtr->callChain[contextPtr->filterLength].mPtr; + Tcl_Obj *cmdName; + + // TODO: should indicate who has the filter registration, not the + // first non-filter after the filter! + TclNewObj(cmdName); + Tcl_GetCommandFullName(interp, contextPtr->oPtr->command, + cmdName); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName); + // TODO: Add what type of filter this is + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + mPtr->namePtr); + return TCL_OK; + } + case SELF_CALLER: + if ((framePtr->callerVarPtr != NULL) && + (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) { + CallContext *callerPtr = framePtr->callerVarPtr->ooContextPtr; + Method *mPtr = callerPtr->callChain[callerPtr->index].mPtr; + Object *declarerPtr; + Tcl_Obj *tmpObj; + + 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; + } + + TclNewObj(tmpObj); + Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); + TclNewObj(tmpObj); + Tcl_GetCommandFullName(interp, callerPtr->oPtr->command, tmpObj); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); + if (callerPtr->flags & CONSTRUCTOR) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj("<constructor>", -1)); + } else if (callerPtr->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->numCallChain-1) { + Method *mPtr = contextPtr->callChain[contextPtr->index+1].mPtr; + Object *declarerPtr; + Tcl_Obj *tmpObj; + + 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; + } + + TclNewObj(tmpObj); + Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); + if (contextPtr->flags & CONSTRUCTOR) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj("<constructor>", -1)); + } else if (contextPtr->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 (!contextPtr->callChain[contextPtr->index].isFilter) { + Tcl_AppendResult(interp, "not inside a filtering context", NULL); + return TCL_ERROR; + } else { + Method *mPtr; + Object *declarerPtr; + Tcl_Obj *cmdName; + int i; + + for (i=contextPtr->index ; i<contextPtr->numCallChain ; i++) { + if (!contextPtr->callChain[i].isFilter) { + break; + } + } + if (i == contextPtr->numCallChain) { + Tcl_Panic("filtering call chain without terminal non-filter"); + } + mPtr = contextPtr->callChain[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; + } + TclNewObj(cmdName); + Tcl_GetCommandFullName(interp, declarerPtr->command, cmdName); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + mPtr->namePtr); + return TCL_OK; + } + } + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_GetObjectFromObj -- + * + * Utility function to get an object from a Tcl_Obj containing its name. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_GetObjectFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); + + if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + Tcl_AppendResult(interp, TclGetString(objPtr), + " does not refer to an object", NULL); + return NULL; + } + return cmdPtr->objClientData; +} + +/* + * ---------------------------------------------------------------------- + * + * 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 = startPtr->superclasses.list[0]; + goto tailRecurse; + } + FOREACH(superPtr, startPtr->superclasses) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + return 0; +} + +/* + * ---------------------------------------------------------------------- + * + * 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 = (Tcl_Obj **) ckalloc(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; +} + +Tcl_Method +Tcl_ObjectContextMethod( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return (Tcl_Method) contextPtr->callChain[contextPtr->index].mPtr; +} + +int +Tcl_ObjectContextIsFiltering( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return contextPtr->callChain[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_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; +} + +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; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |