summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog10
-rw-r--r--doc/info.n66
-rw-r--r--doc/next.n8
-rw-r--r--doc/self.n33
-rw-r--r--generic/tclOO.c2
-rw-r--r--generic/tclOOBasic.c120
-rw-r--r--generic/tclOOCall.c223
-rw-r--r--generic/tclOOInfo.c90
-rw-r--r--generic/tclOOInt.h7
-rw-r--r--tests/oo.test4
-rw-r--r--tests/ooNext2.test765
11 files changed, 1313 insertions, 15 deletions
diff --git a/ChangeLog b/ChangeLog
index af7fab6..3118f82 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2011-05-25 Donal K. Fellows <dkf@users.sf.net>
+
+ IMPLEMENTATION OF TIP#381.
+
+ * doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c,
+ * generic/tclOOBasic.c, generic/tclOOCall.c, generic/tclOOInfo.c,
+ * generic/tclOOInt.h, tests/oo.test, tests/ooNext2.test: Added
+ introspection of call chains ([self call], [info object call], [info
+ class call]) and ability to skip ahead in chain ([nextto]).
+
2011-05-24 Venkat Iyer <venkat@comit.com>
* library/tzdata/Africa/Cairo: Update to Olson tzdata2011g
diff --git a/doc/info.n b/doc/info.n
index 2126b21..cb5c6e6 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -399,6 +399,29 @@ been set (e.g. a variable declared but not set by \fBvariable\fR).
The following \fIsubcommand\fR values are supported by \fBinfo class\fR:
.VE 8.6
.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 there is no inspection of whether the method implementations
+actually use \fBnext\fR to transfer control along the call chain.
+.RE
+.VE 8.6
+.TP
\fBinfo class constructor\fI class\fR
.VS 8.6
This subcommand returns a description of the definition of the constructor of
@@ -504,6 +527,28 @@ class's methods, constructor and destructor).
The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
.VE 8.6
.TP
+\fBinfo object call\fI object method\fR
+.VS 8.6
+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 there is no inspection of whether the method implementations
+actually use \fBnext\fR to transfer control along the call chain.
+.RE
+.VE 8.6
+.TP
\fBinfo object class\fI object\fR ?\fIclassName\fR?
.VS 8.6
If \fIclassName\fR is unspecified, this subcommand returns class of the
@@ -672,6 +717,27 @@ 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]
diff --git a/doc/next.n b/doc/next.n
index c8b098e..222d8b3 100644
--- a/doc/next.n
+++ b/doc/next.n
@@ -15,6 +15,7 @@ next \- invoke superclass method implementations
package require TclOO
\fBnext\fR ?\fIarg ...\fR?
+\fBnextto\fI class\fR ?\fIarg ...\fR?
.fi
.BE
@@ -30,6 +31,13 @@ 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
+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.
.SH "THE METHOD CHAIN"
.PP
When a method of an object is invoked, things happen in several stages:
diff --git a/doc/self.n b/doc/self.n
index f01a607..11779ff 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -25,6 +25,17 @@ 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
+.
+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, whose
+names are reported as \fB<constructor>\fR and \fB<destructor>\fR
+respectively), 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).
+.TP
\fBself caller\fR
.
When the method was invoked from inside another object method, this subcommand
@@ -109,6 +120,28 @@ 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\(-> Obj: {{method x object method} {method x ::c method}} 0\fR
+ \fI\(-> Cls: {{method x object method} {method x ::c method}} 1\fR
+ \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR
+.CE
.SH "SEE ALSO"
info(n), next(n)
.SH KEYWORDS
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 6ae82d1..9df3f53 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -346,6 +346,8 @@ InitFoundation(
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,
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 0d38dcd..b286088 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -680,10 +680,11 @@ TclOO_Object_VarName(
/*
* ----------------------------------------------------------------------
*
- * TclOONextObjCmd --
+ * TclOONextObjCmd, TclOONextToObjCmd --
*
- * Implementation of the [next] command. Note that this command is only
- * ever to be used inside the body of a procedure-like method.
+ * Implementation of the [next] and [nextto] commands. Note that these
+ * commands are only ever to be used inside the body of a procedure-like
+ * method.
*
* ----------------------------------------------------------------------
*/
@@ -723,6 +724,97 @@ TclOONextObjCmd(
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
+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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", 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 ; i<contextPtr->callPtr->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].
+ */
+
+ TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
+ INT2PTR(contextPtr->index), NULL);
+ contextPtr->index = i-1;
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ return TclNRObjectContextInvokeNext(interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv, 2);
+ }
+ }
+
+ /*
+ * 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;
+}
+
static int
RestoreFrame(
ClientData data[],
@@ -730,8 +822,12 @@ RestoreFrame(
int result)
{
Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr = data[1];
iPtr->varFramePtr = data[0];
+ if (contextPtr != NULL) {
+ contextPtr->index = PTR2INT(data[2]);
+ }
return result;
}
@@ -754,16 +850,17 @@ TclOOSelfObjCmd(
Tcl_Obj *const *objv)
{
static const char *const 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;
+ Tcl_Obj *result[3];
int index;
#define CurrentlyInvoked(contextPtr) \
@@ -834,7 +931,6 @@ TclOOSelfObjCmd(
return TCL_ERROR;
} else {
register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
- Tcl_Obj *result[3];
Object *oPtr;
const char *type;
@@ -862,7 +958,6 @@ TclOOSelfObjCmd(
CallContext *callerPtr = framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
- Tcl_Obj *result[3];
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -894,7 +989,6 @@ TclOOSelfObjCmd(
Method *mPtr =
contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
Object *declarerPtr;
- Tcl_Obj *result[2];
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -928,7 +1022,6 @@ TclOOSelfObjCmd(
} else {
Method *mPtr;
Object *declarerPtr;
- Tcl_Obj *result[2];
int i;
for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
@@ -957,6 +1050,11 @@ TclOOSelfObjCmd(
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;
}
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 1e8d1a3..3954a6b 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -104,8 +104,10 @@ TclOODeleteContext(
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);
+ }
}
/*
@@ -1099,6 +1101,137 @@ TclOOGetCallContext(
/*
* ----------------------------------------------------------------------
*
+ * 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
@@ -1256,6 +1389,92 @@ AddSimpleClassChainToCallContext(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 ; i<callPtr->numChain ; 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
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 4f25772..ac8ae46 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -17,6 +17,7 @@
#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;
@@ -28,6 +29,7 @@ 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;
@@ -48,6 +50,7 @@ struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
*/
static const struct NameProcMap infoObjectCmds[] = {
+ {"::oo::InfoObject::call", InfoObjectCallCmd},
{"::oo::InfoObject::class", InfoObjectClassCmd},
{"::oo::InfoObject::definition", InfoObjectDefnCmd},
{"::oo::InfoObject::filters", InfoObjectFiltersCmd},
@@ -67,6 +70,7 @@ static const struct NameProcMap infoObjectCmds[] = {
*/
static const struct NameProcMap infoClassCmds[] = {
+ {"::oo::InfoClass::call", InfoClassCallCmd},
{"::oo::InfoClass::constructor", InfoClassConstrCmd},
{"::oo::InfoClass::definition", InfoClassDefnCmd},
{"::oo::InfoClass::destructor", InfoClassDestrCmd},
@@ -1456,6 +1460,92 @@ InfoClassVariablesCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * 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, NULL);
+ 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
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index bd32f22..b151183 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -465,6 +465,9 @@ MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData,
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);
@@ -518,6 +521,8 @@ MODULE_SCOPE void TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Tcl_Obj *cacheInThisObj);
+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);
@@ -544,6 +549,8 @@ 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);
diff --git a/tests/oo.test b/tests/oo.test
index 60d0077..078d888 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1524,7 +1524,7 @@ test oo-16.2 {OO: object introspection} -body {
} -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
@@ -1646,7 +1646,7 @@ test oo-17.3 {OO: class introspection} -setup {
} -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 {
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
new file mode 100644
index 0000000..624a9d9
--- /dev/null
+++ b/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 <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::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 <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-11-08 13:15:55 (GMT)