Index: doc/next.n ================================================================== --- doc/next.n +++ doc/next.n @@ -15,10 +15,11 @@ .SH SYNOPSIS .nf package require TclOO \fBnext\fR ?\fIarg ...\fR? +\fBnextto\fI class\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION .PP @@ -30,10 +31,19 @@ of methods as it chooses). The result of the \fBnext\fR command is the result of the next method in the method chain; if there are no further methods in the method chain, the result of \fBnext\fR will be an error. The arguments, \fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the chain. +.PP +.VS +The \fBnextto\fR command is the same as the \fBnext\fR command, except that it +takes an additional \fIclass\fR argument that identifies a class whose +implementation of the current method chain (see \fBinfo object call\fR) should +be used; the method implementation selected will be the one provided by the +given class, and it must refer to an existing non-filter invocation that lies +further along the chain than the current implementation. +.VE .SH "THE METHOD CHAIN" .PP When a method of an object is invoked, things happen in several stages: .IP [1] The structure of the object, its class, superclasses, filters, and mixins, are Index: doc/ooInfo.n ================================================================== --- doc/ooInfo.n +++ doc/ooInfo.n @@ -29,10 +29,34 @@ and the \fIobject\fR or \fIclass\fR argument naming the object or class to be inspected. .SS "OBJECT INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo object\fR: +.TP +\fBinfo object call\fI object method\fR +.VS +Returns a description of the method implementations that are used to provide +\fIobject\fR's implementation of \fImethod\fR. This consists of a list of +lists of four elements, where each sublist consists of a word that describes +the general type of method implementation (being one of \fBmethod\fR for an +ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a +method that is invoked as part of unknown method handling), a word giving the +name of the particular method invoked (which is always the same as +\fImethod\fR for the \fBmethod\fR type, and +.QW \fBunknown\fR +for the \fBunknown\fR type), a word giving what defined the method (the fully +qualified name of the class, or the literal string \fBobject\fR if the method +implementation is on an instance), and a word describing the type of method +implementation (see \fBinfo object methodtype\fR). +.RS +.PP +Note that the object method type (as reported by \fBinfo object methodtype\fR +and \fBinfo class methodtype\fR) is \fInot\fR reported by this, and there is +no inspection of whether the method implementations actually use \fBnext\fR to +transfer control along the call chain. +.RE +.VE .TP \fBinfo object class\fI object\fR ?\fIclassName\fR? . If \fIclassName\fR is unspecified, this subcommand returns class of the \fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a @@ -140,10 +164,35 @@ given, it is a filter (in the syntax of a \fBstring match\fR glob pattern) that constrains the list of variables returned. .SS "CLASS INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo class\fR: +.TP +\fBinfo class call\fI class method\fR +.VS +Returns a description of the method implementations that are used to provide a +stereotypical instance of \fIclass\fR's implementation of \fImethod\fR +(stereotypical instances being objects instantiated by a class without having +any object-specific definitions added). This consists of a list of lists of +four elements, where each sublist consists of a word that describes the +general type of method implementation (being one of \fBmethod\fR for an +ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a +method that is invoked as part of unknown method handling), a word giving the +name of the particular method invoked (which is always the same as +\fImethod\fR for the \fBmethod\fR type, and +.QW \fBunknown\fR +for the \fBunknown\fR type), a word giving the fully qualified name of the +class that defined the method, and a word describing the type of method +implementation (see \fBinfo class methodtype\fR). +.RS +.PP +Note that the class method type (as reported by \fBinfo class methodtype\fR) +is \fInot\fR reported by this, and there is no inspection of whether the +method implementations actually use \fBnext\fR to transfer control along the +call chain. +.RE +.VE .TP \fBinfo class constructor\fI class\fR . This subcommand returns a description of the definition of the constructor of class \fIclass\fR. The defintion is described as a two element list; the first @@ -235,10 +284,11 @@ Note that these commands are likely to be renamed in the future. .SH EXAMPLES .PP Every object necessarily knows what its class is; this information is trivially extractable through introspection: +.PP .CS oo::class create c c create o puts [\fBinfo object class\fR o] \fI\(-> prints "::c"\fR @@ -246,10 +296,32 @@ \fI\(-> prints "::oo::class"\fR .CE .PP The introspection capabilities can be used to discover what class implements a method and get how it is defined. This procedure illustrates how: +.PP +.CS +proc getDef {obj method} { + foreach inf [\fBinfo object call\fR $obj $method] { + lassign $inf calltype name locus methodtype + # Assume no forwards or filters, and hence no $calltype + # or $methodtype checks... + if {$locus eq "object"} { + return [\fBinfo object definition\fR $obj $name] + } else { + return [\fBinfo class definition\fR $locus $name] + } + } + error "no definition for $method" +} +.CE +.PP +This is an alternate way of implementing the definition lookup is by manually +scanning the list of methods up the inheritance tree. This code assumes that +only single inheritance is in use, and that there is no complex use of +mixed-in classes: +.PP .CS proc getDef {obj method} { if {$method in [\fBinfo object methods\fR $obj]} { # Assume no forwards return [\fBinfo object definition\fR $obj $method] Index: doc/self.n ================================================================== --- doc/self.n +++ doc/self.n @@ -25,10 +25,21 @@ call to a method (i.e. inside a method, constructor or destructor body) is used to allow the method to discover information about how it was called. It takes an argument, \fIsubcommand\fR, that tells it what sort of information is actually desired; if omitted the result will be the same as if \fBself object\fR was invoked. The supported subcommands are: +.TP +\fBself call\fR +.VS +This returns a two-element list describing the method implementations used to +implement the current call chain. The first element is the same as would be +reported by \fBinfo object call\fR for the current method (except that this +also reports useful values from within constructors and destructors), and the +second element is an index into the first element's list that indicates which +actual implementation is currently executing (the first implementation to +execute is always at index 0). +.VE .TP \fBself caller\fR . When the method was invoked from inside another object method, this subcommand returns a three element list describing the containing object and method. The @@ -95,12 +106,14 @@ When invoked inside a filter implementation, this subcommand returns a two element list describing the method being filtered. The first element will be the name of the declarer of the method, and the second element will be the actual name of the method. .SH EXAMPLES +.PP This example shows basic use of \fBself\fR to provide information about the current object: +.PP .CS oo::class create c { method foo {} { puts "this is the [\fBself\fR] object" } @@ -108,14 +121,36 @@ c create a c create b a foo \fI\(-> prints "this is the ::a object"\fR b foo \fI\(-> prints "this is the ::b object"\fR .CE +.PP +This demonstrates what a method call chain looks like, and how traversing +along it changes the index into it: +.PP +.CS +oo::class create c { + method x {} { + puts "Cls: [\fBself call\fR]" + } +} +c create a +oo::objdefine a { + method x {} { + puts "Obj: [\fBself call\fR]" + next + puts "Obj: [\fBself call\fR]" + } +} +a x \fI\(-> prints "Obj: {{method x object} {method x ::c}} 0"\fR + \fI\(-> prints "Cls: {{method x object} {method x ::c}} 1"\fR + \fI\(-> prints "Obj: {{method x object} {method x ::c}} 0"\fR +.CE .SH "SEE ALSO" info(n), next(n) .SH KEYWORDS call, introspection, object .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -345,10 +345,12 @@ * ensemble. */ Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, + 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, Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ generic/tclOOBasic.c @@ -646,10 +646,115 @@ } /* * ---------------------------------------------------------------------- * + * TclOONextToObjCmd -- + * + * Implementation of the [nextto] command. Note that this command is only + * ever to be used inside the body of a procedure-like method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOONextToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + Class *classPtr; + CallContext *contextPtr; + int i; + Tcl_Object object; + + /* + * 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; + } + contextPtr = framePtr->clientData; + + /* + * Sanity check the arguments; we need the first one to refer to a class. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); + return TCL_ERROR; + } + object = Tcl_GetObjectFromObj(interp, objv[1]); + if (object == NULL) { + return TCL_ERROR; + } + classPtr = ((Object *)object)->classPtr; + if (classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + + /* + * Search for an implementation of a method associated with the current + * call on the call chain past the point where we currently are. Do not + * allow jumping backwards! + */ + + for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + /* + * Invoke the (advanced) method call context in the caller + * context. Note that this is like [uplevel 1] and not [eval]. + */ + + int savedDepth = contextPtr->index; + int result; + + contextPtr->index = i - 1; + iPtr->varFramePtr = framePtr->callerVarPtr; + result = Tcl_ObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, objc, objv, 2); + iPtr->varFramePtr = framePtr; + contextPtr->index = savedDepth; + return result; + } + } + + /* + * Generate an appropriate error message, depending on whether the value + * is on the chain but unreachable, or not on the chain at all. + */ + + for (i=contextPtr->index ; i>=0 ; i--) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + Tcl_AppendResult(interp, "method implementation by \"", + TclGetString(objv[1]), "\" not reachable from here", + NULL); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, "method has no non-filter implementation by \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * * TclOOSelfObjCmd -- * * Implementation of the [self] command, which provides introspection of * the call context. * @@ -662,16 +767,16 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { static const char *subcmds[] = { - "caller", "class", "filter", "method", "namespace", "next", "object", - "target", NULL + "call", "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 + SELF_CALL, 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; @@ -861,10 +966,15 @@ result[1] = mPtr->namePtr; } Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } + case SELF_CALL: + result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); + result[1] = Tcl_NewIntObj(contextPtr->index); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); + return TCL_OK; } return TCL_ERROR; } /* Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ generic/tclOOCall.c @@ -98,12 +98,14 @@ CallContext *contextPtr) { register Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); - TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + if (oPtr != NULL) { + TclStackFree(oPtr->fPtr->interp, contextPtr); + DelRef(oPtr); + } } /* * ---------------------------------------------------------------------- * @@ -1060,10 +1062,141 @@ } /* * ---------------------------------------------------------------------- * + * TclOOGetStereotypeCallChain -- + * + * Construct a call-chain for a method that would be used by a + * stereotypical instance of the given class (i.e., where the object has + * no definitions special to itself). + * + * ---------------------------------------------------------------------- + */ + +CallChain * +TclOOGetStereotypeCallChain( + Class *clsPtr, /* 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. */ +{ + CallChain *callPtr; + struct ChainBuilder cb; + int i, count; + Foundation *fPtr = clsPtr->thisPtr->fPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable doneFilters; + Object obj; + + /* + * Synthesize a temporary stereotypical object so that we can use existing + * machinery to produce the stereotypical call chain. + */ + + memset(&obj, 0, sizeof(Object)); + obj.fPtr = fPtr; + obj.selfCls = clsPtr; + obj.refCount = 1; + obj.flags = USE_CLASS_CACHE; + + /* + * 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). + */ + + if (clsPtr->classChainCache != NULL) { + hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, + (char *) methodNameObj); + if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + const int reuseMask = + ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + + callPtr = Tcl_GetHashValue(hPtr); + if (IsStillValid(callPtr, &obj, flags, reuseMask)) { + callPtr->refCount++; + return callPtr; + } + Tcl_SetHashValue(hPtr, NULL); + TclOODeleteChain(callPtr); + } + } else { + hPtr = NULL; + } + + callPtr = (CallChain *) ckalloc(sizeof(CallChain)); + memset(callPtr, 0, sizeof(CallChain)); + callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); + callPtr->epoch = fPtr->epoch; + callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount; + callPtr->objectEpoch = clsPtr->thisPtr->epoch; + callPtr->refCount = 1; + callPtr->chain = callPtr->staticChain; + + cb.callChainPtr = callPtr; + cb.filterLength = 0; + cb.oPtr = &obj; + + /* + * 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). + */ + + Tcl_InitObjHashTable(&doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + Tcl_DeleteHashTable(&doneFilters); + count = cb.filterLength = callPtr->numChain; + + /* + * Add the actual method implementations. + */ + + AddSimpleChainToCallContext(&obj, 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) { + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, 0, NULL); + callPtr->flags |= OO_UNKNOWN_METHOD; + callPtr->epoch = -1; + if (count == callPtr->numChain) { + TclOODeleteChain(callPtr); + return NULL; + } + } else { + if (hPtr == NULL) { + if (clsPtr->classChainCache == NULL) { + clsPtr->classChainCache = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + + Tcl_InitObjHashTable(clsPtr->classChainCache); + } + hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, + (char *) methodNameObj, &i); + } + callPtr->refCount++; + Tcl_SetHashValue(hPtr, callPtr); + StashCallChain(methodNameObj, callPtr); + } + return callPtr; +} + +/* + * ---------------------------------------------------------------------- + * * AddClassFiltersToCallContext -- * * Logic to make extracting all the filters from the class context much * easier. * @@ -1215,13 +1348,99 @@ } case 0: return; } } + +/* + * ---------------------------------------------------------------------- + * + * TclOORenderCallChain -- + * + * Create a description of a call chain. Used in [info object call], + * [info class call], and [self call]. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOORenderCallChain( + Tcl_Interp *interp, + CallChain *callPtr) +{ + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *resultObj, *descObjs[4], **objv; + Foundation *fPtr = TclOOGetFoundation(interp); + int i; + + /* + * Allocate the literals (potentially) used in our description. + */ + + filterLiteral = Tcl_NewStringObj("filter", -1); + Tcl_IncrRefCount(filterLiteral); + methodLiteral = Tcl_NewStringObj("method", -1); + Tcl_IncrRefCount(methodLiteral); + objectLiteral = Tcl_NewStringObj("object", -1); + Tcl_IncrRefCount(objectLiteral); + + /* + * Do the actual construction of the descriptions. They consist of a list + * of triples that describe the details of how a method is understood. For + * each triple, the first word is the type of invokation ("method" is + * normal, "unknown" is special because it adds the method name as an + * extra argument when handled by some method types, and "filter" is + * special because it's a filter method). The second word is the name of + * the method in question (which differs for "unknown" and "filter" types) + * and the third word is the full name of the class that declares the + * method (or "object" if it is declared on the instance). + */ + + objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); + for (i=0 ; inumChain ; i++) { + struct MInvoke *miPtr = &callPtr->chain[i]; + + descObjs[0] = miPtr->isFilter + ? filterLiteral + : callPtr->flags & OO_UNKNOWN_METHOD + ? fPtr->unknownMethodNameObj + : methodLiteral; + descObjs[1] = callPtr->flags & CONSTRUCTOR + ? fPtr->constructorName + : callPtr->flags & DESTRUCTOR + ? fPtr->destructorName + : miPtr->mPtr->namePtr; + descObjs[2] = miPtr->mPtr->declaringClassPtr + ? Tcl_GetObjectName(interp, + (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) + : objectLiteral; + descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); + + objv[i] = Tcl_NewListObj(4, descObjs); + Tcl_IncrRefCount(objv[i]); + } + + /* + * Drop the local references to the literals; if they're actually used, + * they'll live on the description itself. + */ + + Tcl_DecrRefCount(filterLiteral); + Tcl_DecrRefCount(methodLiteral); + Tcl_DecrRefCount(objectLiteral); + + /* + * Finish building the description and return it. + */ + + resultObj = Tcl_NewListObj(callPtr->numChain, objv); + TclStackFree(interp, objv); + return resultObj; +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclOOInfo.c ================================================================== --- generic/tclOOInfo.c +++ generic/tclOOInfo.c @@ -17,10 +17,11 @@ #endif #include "tclInt.h" #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; @@ -28,10 +29,11 @@ static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; +static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; @@ -48,10 +50,11 @@ /* * List of commands that are used to implement the [info object] subcommands. */ static const struct NameProcMap infoObjectCmds[] = { + {"::oo::InfoObject::call", InfoObjectCallCmd}, {"::oo::InfoObject::class", InfoObjectClassCmd}, {"::oo::InfoObject::definition", InfoObjectDefnCmd}, {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, {"::oo::InfoObject::forward", InfoObjectForwardCmd}, {"::oo::InfoObject::isa", InfoObjectIsACmd}, @@ -67,10 +70,11 @@ /* * List of commands that are used to implement the [info class] subcommands. */ static const struct NameProcMap infoClassCmds[] = { + {"::oo::InfoClass::call", InfoClassCallCmd}, {"::oo::InfoClass::constructor", InfoClassConstrCmd}, {"::oo::InfoClass::definition", InfoClassDefnCmd}, {"::oo::InfoClass::destructor", InfoClassDestrCmd}, {"::oo::InfoClass::filters", InfoClassFiltersCmd}, {"::oo::InfoClass::forward", InfoClassForwardCmd}, @@ -1436,13 +1440,99 @@ Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectCallCmd -- + * + * Implements [info object call $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + CallContext *contextPtr; + + 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; + } + + /* + * Get the call context and render its call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + TclOORenderCallChain(interp, contextPtr->callPtr)); + TclOODeleteContext(contextPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassCallCmd -- + * + * Implements [info class call $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + CallChain *callPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get an render the stereotypical call chain. + */ + + callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); + if (callPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); + return TCL_OK; +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -462,10 +462,13 @@ 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 TclOONextToObjCmd(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); @@ -510,10 +513,12 @@ 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 CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, + 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 Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, @@ -530,10 +535,12 @@ 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 Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, + CallChain *callPtr); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored, Tcl_Interp *interp, int objc, Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -1466,11 +1466,11 @@ test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 } -body { list [list [info object class oo::object] \ @@ -1588,11 +1588,11 @@ } -returnCodes 1 -cleanup { foo destroy } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { testClass create foo testClass create bar ADDED tests/ooNext2.test Index: tests/ooNext2.test ================================================================== --- /dev/null +++ tests/ooNext2.test @@ -0,0 +1,765 @@ +# This file contains a collection of tests for Tcl's built-in object system. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2006-2008 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: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $ + +package require -exact TclOO 0.6.2 ;# Must match value in configure.in +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + +test oo-nextto-1.1 {basic nextto functionality} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x args { + lappend ::result ==A== $args + } + } + oo::class create B { + superclass A + method x args { + lappend ::result ==B== $args + nextto A B -> A {*}$args + } + } + oo::class create C { + superclass A + method x args { + lappend ::result ==C== $args + nextto A C -> A {*}$args + } + } + oo::class create D { + superclass B C + method x args { + lappend ::result ==D== $args + next foo + nextto C bar + } + } + set ::result {} + [D new] x + return $::result +} -cleanup { + root destroy +} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}} +test oo-nextto-1.2 {basic nextto functionality} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x args { + lappend ::result ==A== $args + } + } + oo::class create B { + superclass A + method x args { + lappend ::result ==B== $args + nextto A B -> A {*}$args + } + } + oo::class create C { + superclass A + method x args { + lappend ::result ==C== $args + nextto A C -> A {*}$args + } + } + oo::class create D { + superclass B C + method x args { + lappend ::result ==D== $args + nextto B foo {*}$args + nextto C bar {*}$args + } + } + set ::result {} + [D new] x 123 + return $::result +} -cleanup { + root destroy +} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}} +test oo-nextto-1.3 {basic nextto functionality: constructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + variable result + constructor {a c} { + lappend result ==A== a=$a,c=$c + } + } + oo::class create B { + superclass root + variable result + constructor {b} { + lappend result ==B== b=$b + } + } + oo::class create C { + superclass A B + variable result + constructor {p q r} { + lappend result ==C== p=$p,q=$q,r=$r + # Route arguments to superclasses, in non-trival pattern + nextto B $q + nextto A $p $r + } + method result {} {return $result} + } + [C new x y z] result +} -cleanup { + root destroy +} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z} +test oo-nextto-1.4 {basic nextto functionality: destructors} -setup { + oo::class create root {destructor return} +} -body { + oo::class create A { + superclass root + destructor { + lappend ::result ==A== + next + } + } + oo::class create B { + superclass root + destructor { + lappend ::result ==B== + next + } + } + oo::class create C { + superclass A B + destructor { + lappend ::result ==C== + lappend ::result | + nextto B + lappend ::result | + nextto A + lappend ::result | + next + } + } + set ::result "" + [C new] destroy + return $::result +} -cleanup { + root destroy +} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==} + +test oo-nextto-2.1 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {error $y} + } + oo::class create B { + superclass A + method x y {nextto A $y} + } + [B new] x boom +} -cleanup { + root destroy +} -result boom -returnCodes error +test oo-nextto-2.2 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {error $y} + } + oo::class create B { + superclass root + method x y {nextto A $y} + } + [B new] x boom +} -returnCodes error -cleanup { + root destroy +} -result {method has no non-filter implementation by "A"} +test oo-nextto-2.3 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto A $y} + } + [B new] x B +} -returnCodes error -cleanup { + root destroy +} -result {method implementation by "B" not reachable from here} +test oo-nextto-2.4 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto} + } + [B new] x B +} -returnCodes error -cleanup { + root destroy +} -result {wrong # args: should be "nextto class ?arg...?"} +test oo-nextto-2.5 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto $y $y $y} + } + [B new] x A +} -cleanup { + root destroy +} -result {wrong # args: should be "nextto A y"} -returnCodes error +test oo-nextto-2.6 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto $y $y $y} + } + [B new] x [root create notAClass] +} -cleanup { + root destroy +} -result {"::notAClass" is not a class} -returnCodes error +test oo-nextto-2.7 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + filter Y + method Y args {next {*}$args} + } + oo::class create C { + superclass B + method x y {nextto $y $y $y} + } + [C new] x B +} -returnCodes error -cleanup { + root destroy +} -result {method has no non-filter implementation by "B"} + +test oo-call-1.1 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + info object call y x +} -cleanup { + root destroy +} -result {{method x ::A method}} +test oo-call-1.2 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{method x ::B method} {method x ::A method}} +test oo-call-1.3 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + oo::objdefine y method x {} {} + info object call y x +} -cleanup { + root destroy +} -result {{method x object method} {method x ::A method}} +test oo-call-1.4 {object object call introspection - unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + info object call y z +} -cleanup { + root destroy +} -result {{unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.5 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + A create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x ::A method}} +test oo-call-1.6 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.7 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.8 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + method z {} {} + filter z + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.9 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + method z {} {} + filter z + } + B create y + info object call y y +} -cleanup { + root destroy +} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}} +test oo-call-1.10 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + method unknown {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.11 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + A create y + oo::objdefine y method unknown {} {} + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.12 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + } + A create y + oo::objdefine y { + method unknown {} {} + filter y + } + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.13 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + } + A create y + oo::objdefine y { + method unknown {} {} + method x {} {} + filter y + } + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x object method}} +test oo-call-1.14 {object call introspection - errors} -body { + info object call +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.15 {object call introspection - errors} -body { + info object call a +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.16 {object call introspection - errors} -body { + info object call a b c +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.17 {object call introspection - errors} -body { + info object call notanobject x +} -returnCodes error -result {notanobject does not refer to an object} +test oo-call-1.18 {object call introspection - memory leaks} -body { + leaktest { + info object call oo::object destroy + } +} -constraints memory -result 0 + +test oo-call-2.1 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + info class call A x +} -cleanup { + root destroy +} -result {{method x ::A method}} +test oo-call-2.2 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + list [info class call A x] [info class call B x] +} -cleanup { + root destroy +} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}} +test oo-call-2.3 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass A + method x {} {} + } + oo::class create ::D { + superclass C B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}} +test oo-call-2.4 {class call introspection - mixin} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass A + method x {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} +test oo-call-2.5 {class call introspection - mixin + filter} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + filter y + } + oo::class create ::C { + superclass A + method x {} {} + method y {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} +test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method unknown {} {} + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + filter y + } + oo::class create ::C { + superclass A + method x {} {} + method y {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + method unknown {} {} + } + info class call D z +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + filter x + } + info class call B x +} -cleanup { + root destroy +} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}} +test oo-call-2.8 {class call introspection - errors} -body { + info class call +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.9 {class call introspection - errors} -body { + info class call a +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.10 {class call introspection - errors} -body { + info class call a b c +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.11 {class call introspection - errors} -body { + info class call notaclass x +} -returnCodes error -result {notaclass does not refer to an object} +test oo-call-2.11 {class call introspection - errors} -setup { + oo::class create root +} -body { + root create notaclass + info class call notaclass x +} -returnCodes error -cleanup { + root destroy +} -result {"notaclass" is not a class} +test oo-call-2.13 {class call introspection - memory leaks} -body { + leaktest { + info class call oo::class destroy + } +} -constraints memory -result 0 + +test oo-call-3.1 {current call introspection} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x {} {lappend ::result [self call]} + } + oo::class create B { + superclass A + method x {} {lappend ::result [self call];next} + } + B create y + oo::objdefine y method x {} {lappend ::result [self call];next} + set ::result {} + y x +} -cleanup { + root destroy +} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}} +test oo-call-3.2 {current call introspection} -setup { + oo::class create root +} -constraints memory -body { + oo::class create A { + superclass root + method x {} {self call} + } + oo::class create B { + superclass A + method x {} {self call;next} + } + B create y + oo::objdefine y method x {} {self call;next} + leaktest { + y x + } +} -cleanup { + root destroy +} -result 0 +test oo-call-3.3 {current call introspection: in constructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + constructor {} {lappend ::result [self call]} + } + oo::class create B { + superclass A + constructor {} {lappend ::result [self call]; next} + } + set ::result {} + [B new] destroy + return $::result +} -cleanup { + root destroy +} -result {{{{method ::B method} {method ::A method}} 0} {{{method ::B method} {method ::A method}} 1}} +test oo-call-3.4 {current call introspection: in destructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + destructor {lappend ::result [self call]} + } + oo::class create B { + superclass A + destructor {lappend ::result [self call]; next} + } + set ::result {} + [B new] destroy + return $::result +} -cleanup { + root destroy +} -result {{{{method ::B method} {method ::A method}} 0} {{{method ::B method} {method ::A method}} 1}} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: