TclOO Package

.SH NAME
next \- invoke superclass method implementations
.SH SYNOPSIS
.nf
package require TclOO

\fBnext\fR ?\fIarg ...\fR?
\fBnextto\fI class\fR ?\fIarg ...\fR?
.fi
.BE

.SH DESCRIPTION
.PP
The \fBnext\fR command is used to call implementations of a method by a class,
superclass or mixin that are overridden by the current method. It can only be
used from within a method. It is also used within filters to indicate the
point where a filter calls the actual implementation (the filter may decide to
not go along the chain, and may process the results of going along the chain
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
examined to build a \fImethod chain\fR, which contains a list of method
implementations to invoke.

commands that provide introspection capabilities to the object system, with
the \fIsubcommand\fR argument designating which aspect is to be inspectected
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
boolean value indicating whether the \fIobject\fR is of that class.
.TP

This subcommand returns a list of all variables in the private namespace of
the object named \fIobject\fR. If the optional \fIpattern\fR argument is
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
element is the list of arguments to the constructor in a form suitable for
passing to another call to \fBproc\fR or a method defintion, and the second

.VE
.SH "FUTURE CHANGES"
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
puts [\fBinfo object class\fR c]
                     \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]
    }
    set cls [\fBinfo object class\fR $obj]

.SH DESCRIPTION
The \fBself\fR command, which should only be used from within the context of a
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
first element describes the declaring object or class of the method, the
second element is the name of the object on which the containing method was

\fBself target\fR
.
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"
    }
}
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:

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */

    Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::Helpers::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,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);

    iPtr->varFramePtr = framePtr;
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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 ; 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].
	     */

	    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.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOSelfObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    static const char *subcmds[] = {
	"caller", "class", "filter", "method", "namespace", "next", "object",
	"target", NULL
	"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;
    Tcl_Obj *result[3];
    Object *declarerPtr;

		result[1] = declarerPtr->fPtr->destructorName;
	    } else {
		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;
}

/*
 * ----------------------------------------------------------------------
 *

void
TclOODeleteContext(
    CallContext *contextPtr)
{
    register Object *oPtr = contextPtr->oPtr;

    TclOODeleteChain(contextPtr->callPtr);
    if (oPtr != NULL) {
    TclStackFree(oPtr->fPtr->interp, contextPtr);
    DelRef(oPtr);
	TclStackFree(oPtr->fPtr->interp, contextPtr);
	DelRef(oPtr);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteChainCache --
 *

    contextPtr->index = 0;
    return contextPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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.
 *
 * ----------------------------------------------------------------------
 */

	    AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
		    doneFilters, flags, filterDecl);
	}
    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 ; 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
 * fill-column: 78
 * End:
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#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;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
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;
static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;

struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };

/*
 * List of commands that are used to implement the [info object] subcommands.
 */

static const struct NameProcMap infoObjectCmds[] = {
    {"::oo::InfoObject::call",	     InfoObjectCallCmd},
    {"::oo::InfoObject::class",	     InfoObjectClassCmd},
    {"::oo::InfoObject::definition", InfoObjectDefnCmd},
    {"::oo::InfoObject::filters",    InfoObjectFiltersCmd},
    {"::oo::InfoObject::forward",    InfoObjectForwardCmd},
    {"::oo::InfoObject::isa",	     InfoObjectIsACmd},
    {"::oo::InfoObject::methods",    InfoObjectMethodsCmd},
    {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd},
    {"::oo::InfoObject::mixins",     InfoObjectMixinsCmd},
    {"::oo::InfoObject::namespace",  InfoObjectNsCmd},
    {"::oo::InfoObject::variables",  InfoObjectVariablesCmd},
    {"::oo::InfoObject::vars",	     InfoObjectVarsCmd},
    {NULL, NULL}
};

/*
 * List of commands that are used to implement the [info class] subcommands.
 */

static const struct NameProcMap infoClassCmds[] = {
    {"::oo::InfoClass::call",	      InfoClassCallCmd},
    {"::oo::InfoClass::constructor",  InfoClassConstrCmd},
    {"::oo::InfoClass::definition",   InfoClassDefnCmd},
    {"::oo::InfoClass::destructor",   InfoClassDestrCmd},
    {"::oo::InfoClass::filters",      InfoClassFiltersCmd},
    {"::oo::InfoClass::forward",      InfoClassForwardCmd},
    {"::oo::InfoClass::instances",    InfoClassInstancesCmd},
    {"::oo::InfoClass::methods",      InfoClassMethodsCmd},

    resultObj = Tcl_NewObj();
    FOREACH(variableObj, clsPtr->variables) {
	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:
 */

			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOCopyObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOONextObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	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);

/*
 * Method implementations (in tclOOBasic.c).

MODULE_SCOPE void	TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE 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,
			    int flags, const char ***stringsPtr);
MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
			    const char ***stringsPtr);
MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int	TclOOInvokeContext(Tcl_Interp *interp,
			    CallContext *contextPtr, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
			    Class *mixinPtr);
MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
			    Class *superPtr);
MODULE_SCOPE 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,
			    Tcl_Obj *const objv[]);


    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\""
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] \
	      [info object class oo::class] \
	      [info object class meta] \

} -body {
    info class superclass foo
} -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
    testClass create spong
    lsort [info class instances testClass]

# 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: