generic/tclOOBasic.c - main - niceSOFT/tcl

generic/tclOOBasic.c
2 050 строк59 KB
dkf
Indentation corrections
13 июн 2026, 18:56
13 июн 2026, 18:5669d261d
/*
 * tclOOBasic.c --
 *
 *	This file contains implementations of the "simple" commands and
 *	methods from the object-system core.
 *
 * Copyright © 2005-2013 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclTomMath.h"

static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static Tcl_NRPostProc	AfterNRDestructor;
static Tcl_NRPostProc	PostClassConstructor;
static Tcl_NRPostProc	FinalizeConstruction;
static Tcl_NRPostProc	FinalizeEval;
static Tcl_NRPostProc	NextRestoreFrame;
static Tcl_NRPostProc	MarkAsSingleton;
static Tcl_NRPostProc	UpdateClassDelegatesAfterClone;

#define CurrentlyInvoked(contextPtr) \
    ((contextPtr)->callPtr->chain[(contextPtr)->index])

/*
 * ----------------------------------------------------------------------
 *
 * AddCreateCallback, FinalizeConstruction --
 *
 *	Special version of TclNRAddCallback that allows the caller to splice
 *	the object created later on. Always calls FinalizeConstruction, which
 *	converts the object into its name and stores that in the interpreter
 *	result. This is shared by all the construction methods (create,
 *	createWithNamespace, new).
 *
 *	Note that this is the only code in this file (or, indeed, the whole of
 *	TclOO) that uses NRE internals; it is the only code that does
 *	non-standard poking in the NRE guts.
 *
 * ----------------------------------------------------------------------
 */

static inline Tcl_Object *
AddConstructionFinalizer(
    Tcl_Interp *interp)
{
    TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
    return (Tcl_Object *) &(TOP_CB(interp)->data[0]);
}

static int
FinalizeConstruction(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Object *oPtr = (Object *) data[0];

    if (result != TCL_OK) {
	return result;
    }
    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetClassDelegate --
 *
 *	Look up the delegate for a class.
 *
 *----------------------------------------------------------------------
 */
static inline Class *
GetClassDelegate(
    Tcl_Interp *interp,
    Class *clsPtr)
{
    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
	    clsPtr->thisPtr->namespacePtr->fullName);
    Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
    Tcl_DecrRefCount(delegateName);
    return delegatePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * SetDelegateSuperclasses --
 *
 *	Patches in the appropriate class delegates' superclasses.
 *	Somewhat messy because the list of superclasses isn't modified
 *	frequently.
 *
 *----------------------------------------------------------------------
 */
static inline void
SetDelegateSuperclasses(
    Tcl_Interp *interp,
    Class *clsPtr,
    Class *delegatePtr)
{
    // Build new list of superclasses
    Tcl_Size i, j = delegatePtr->superclasses.num, k;
    Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) *
	    (delegatePtr->superclasses.num + clsPtr->superclasses.num));
    if (delegatePtr->superclasses.num) {
	memcpy(supers, delegatePtr->superclasses.list,
		sizeof(Class *) * delegatePtr->superclasses.num);
    }
    FOREACH(superPtr, clsPtr->superclasses) {
	Class *superDelegatePtr = GetClassDelegate(interp, superPtr);
	if (!superDelegatePtr) {
	    continue;
	}
	for (k=0 ; k<=j ; k++) {
	    if (k == j) {
		supers[j++] = superDelegatePtr;
		TclOOAddToSubclasses(delegatePtr, superDelegatePtr);
		AddRef(superDelegatePtr->thisPtr);
		break;
	    } else if (supers[k] == superDelegatePtr) {
		break;
	    }
	}
    }

    // Install new list of superclasses;
    if (delegatePtr->superclasses.num) {
	Tcl_Free(delegatePtr->superclasses.list);
    }
    delegatePtr->superclasses.list = supers;
    delegatePtr->superclasses.num = j;

    // Definitely don't need to bump any epoch here
}

/*
 *----------------------------------------------------------------------
 *
 * InstallDelegateAsMixin --
 *
 *	Mixes the delegate into its controlling class.
 *
 *----------------------------------------------------------------------
 */
static inline void
InstallDelegateAsMixin(
    Tcl_Interp *interp,
    Class *clsPtr,
    Class *delegatePtr)
{
    if (clsPtr->thisPtr->mixins.num == 0) {
	TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr);
	return;
    }
    Class **mixins = (Class **) TclStackAlloc(interp,
	    sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1));
    for (Tcl_Size i = 0; i < clsPtr->thisPtr->mixins.num; i++) {
	mixins[i] = clsPtr->thisPtr->mixins.list[i];
	if (mixins[i] == delegatePtr) {
	    TclStackFree(interp, (void *) mixins);
	    return;
	}
    }
    mixins[clsPtr->thisPtr->mixins.num] = delegatePtr;
    TclOOObjectSetMixins(clsPtr->thisPtr, clsPtr->thisPtr->mixins.num + 1, mixins);
    TclStackFree(interp, mixins);
}

/*
 * ----------------------------------------------------------------------
 *
 * MixinClassDelegates --
 *
 *	Internal utility for patching the class delegate in where it belongs.
 *	Runs after the class has called [oo::define] on its argument.
 *
 * ----------------------------------------------------------------------
 */
static void
MixinClassDelegates(
    Tcl_Interp *interp,
    Object *oPtr,
    Tcl_Obj *delegateName)
{
    Class *clsPtr = oPtr->classPtr;
    if (clsPtr) {
	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
	if (delegatePtr) {
	    SetDelegateSuperclasses(interp, clsPtr, delegatePtr);
	    InstallDelegateAsMixin(interp, clsPtr, delegatePtr);
	}
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Constructor --
 *
 *	Implementation for oo::class constructor.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_Constructor(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
    if (objc > skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv,
		"?definitionScript?");
	return TCL_ERROR;
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     *
     * This needs to be done before consideration of whether to pass the script
     * argument to [oo::define]. [Bug 680503]
     */

    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
	    oPtr->namespacePtr->fullName);
    Tcl_IncrRefCount(delegateName);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(delegateName), NULL, TCL_INDEX_NONE, NULL, 0);

    /*
     * If there's nothing else to do, we're done.
     */

    if (objc == skip) {
	Tcl_InterpState saved = Tcl_SaveInterpState(interp, TCL_OK);
	MixinClassDelegates(interp, oPtr, delegateName);
	Tcl_DecrRefCount(delegateName);
	return Tcl_RestoreInterpState(interp, saved);
    }

    /*
     * Delegate to [oo::define] to do the work.
     */

    Tcl_Obj **invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc - 1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, PostClassConstructor,
	    invoke, oPtr, delegateName, NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * PostClassConstructor --
 *
 *	Called *after* [oo::define] inside the constructor of a class.
 *	Cleans up some temporary storage and sets up the delegate.
 *
 *----------------------------------------------------------------------
 */
static int
PostClassConstructor(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = (Tcl_Obj **) data[0];
    Object *oPtr = (Object *) data[1];
    Tcl_Obj *delegateName = (Tcl_Obj *) data[2];

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    TclStackFree(interp, invoke);

    Tcl_InterpState saved = Tcl_SaveInterpState(interp, result);
    MixinClassDelegates(interp, oPtr, delegateName);
    Tcl_DecrRefCount(delegateName);
    return Tcl_RestoreInterpState(interp, saved);
}

/*
 *----------------------------------------------------------------------
 *
 * ContextClass --
 *
 *	Get the context object (see Tcl_ObjectContextObject) as a class.
 *	Should only be called inside a class method implementation, where
 *	the context object must exist.
 *
 * Returns:
 *	The context class, if it is a valid class. Otherwise NULL (with an
 *	error message in the interpreter).
 *
 *----------------------------------------------------------------------
 */
static inline Tcl_Class
ContextClass(
    Tcl_Interp *interp,		/* Interpreter used for error reporting. */
    Tcl_ObjectContext context)	/* The object/call context. */
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);

    /*
     * Sanity check; should not be possible to invoke this from methods on a
     * non-class.
     */

    if (oPtr->classPtr == NULL) {
	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);

	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS",
		(char *)NULL);
	return NULL;
    }
    return (Tcl_Class) oPtr->classPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --
 *
 *	Implementation for oo::class->create method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_Create(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Tcl_Class cls = ContextClass(interp, context);
    const char *objName;
    Tcl_Size len;

    /*
     * Sanity check; should not be possible to invoke this method on a
     * non-class.
     */

    if (!cls) {
	return TCL_ERROR;
    }

    /*
     * Check we have the right number of (sensible) arguments.
     */

    if (objc < 1 + Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"objectName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", TCL_AUTO_LENGTH));
	OO_ERROR(interp, EMPTY_NAME);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

    return TclNRNewObjectInstance(interp, cls, objName, NULL, objc, objv,
	    Tcl_ObjectContextSkippedArgs(context)+1,
	    AddConstructionFinalizer(interp));
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_CreateNs --
 *
 *	Implementation for oo::class->createWithNamespace method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_CreateNs(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Tcl_Class cls = ContextClass(interp, context);
    const char *objName, *nsName;
    Tcl_Size len;

    /*
     * Sanity check; should not be possible to invoke this method on a
     * non-class.
     */

    if (!cls) {
	return TCL_ERROR;
    }

    /*
     * Check we have the right number of (sensible) arguments.
     */

    if (objc + 1 < Tcl_ObjectContextSkippedArgs(context) + 3) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"objectName namespaceName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", TCL_AUTO_LENGTH));
	OO_ERROR(interp, EMPTY_NAME);
	return TCL_ERROR;
    }
    nsName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context) + 1], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"namespace name must not be empty", TCL_AUTO_LENGTH));
	OO_ERROR(interp, EMPTY_NAME);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

    return TclNRNewObjectInstance(interp, cls, objName, nsName, objc, objv,
	    Tcl_ObjectContextSkippedArgs(context) + 2,
	    AddConstructionFinalizer(interp));
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_New --
 *
 *	Implementation for oo::class->new method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_New(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Tcl_Class cls = ContextClass(interp, context);

    /*
     * Sanity check; should not be possible to invoke this method on a
     * non-class.
     */

    if (!cls) {
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

    return TclNRNewObjectInstance(interp, cls, NULL, NULL, objc, objv,
	    Tcl_ObjectContextSkippedArgs(context),
	    AddConstructionFinalizer(interp));
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Cloned --
 *
 *	Handler for cloning classes, which fixes up the delegates. This allows
 *	the clone's class methods to evolve independently of the origin's
 *	class methods; this is how TclOO works by default.
 *
 * ----------------------------------------------------------------------
 */
int
TclOO_Class_Cloned(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Tcl_Object targetObject = Tcl_ObjectContextObject(context);
    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip >= objc) {
	Tcl_WrongNumArgs(interp, skip, objv, "originObject");
	return TCL_ERROR;
    }
    Tcl_Object originObject = Tcl_GetObjectFromObj(interp, objv[skip]);
    if (!originObject) {
	return TCL_ERROR;
    }
    // Add references so things won't vanish until after
    // UpdateClassDelegatesAfterClone is finished with them.
    AddRef((Object *) originObject);
    AddRef((Object *) targetObject);
    TclNRAddCallback(interp, UpdateClassDelegatesAfterClone,
	    originObject, targetObject, NULL, NULL);
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
}

// Rebuilds the class inheritance delegation class.
static int
UpdateClassDelegatesAfterClone(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Object *originPtr = (Object *) data[0];
    Object *targetPtr = (Object *) data[1];
    if (result == TCL_OK && originPtr->classPtr && targetPtr->classPtr) {
	// Get the originating delegate to be cloned.

	Tcl_Obj *originName = Tcl_ObjPrintf("%s:: oo ::delegate",
		originPtr->namespacePtr->fullName);
	Object *originDelegate = (Object *) Tcl_GetObjectFromObj(interp,
		originName);
	Tcl_BounceRefCount(originName);
	// Delegates never have their own delegates, so silently make sure we
	// don't try to make a clone of them.
	if (!(originDelegate && originDelegate->classPtr)) {
	    goto noOriginDelegate;
	}

	// Create the cloned target delegate.

	Tcl_Obj *targetName = Tcl_ObjPrintf("%s:: oo ::delegate",
		targetPtr->namespacePtr->fullName);
	Object *targetDelegate = (Object *) Tcl_CopyObjectInstance(interp,
		(Tcl_Object) originDelegate, Tcl_GetString(targetName), NULL);
	Tcl_BounceRefCount(targetName);
	if (targetDelegate == NULL) {
	    result = TCL_ERROR;
	    goto noOriginDelegate;
	}

	// Point the cloned target class at the cloned target delegate.
	// This is like TclOOObjectSetMixins() but more efficient in this
	// case as there's definitely no relevant call chains to invalidate
	// and we're doing a one-for-one replacement.

	Tcl_Size i;
	Class *mixin;
	FOREACH(mixin, targetPtr->mixins) {
	    if (mixin == originDelegate->classPtr) {
		TclOORemoveFromInstances(targetPtr, originDelegate->classPtr);
		TclOODecrRefCount(originDelegate);
		targetPtr->mixins.list[i] = targetDelegate->classPtr;
		TclOOAddToInstances(targetPtr, targetDelegate->classPtr);
		AddRef(targetDelegate);
		break;
	    }
	}
    }
  noOriginDelegate:
    TclOODecrRefCount(originPtr);
    TclOODecrRefCount(targetPtr);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Configurable_Constructor --
 *
 *	Implementation for oo::configurable constructor.
 *
 * ----------------------------------------------------------------------
 */
int
TclOO_Configurable_Constructor(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
    if (objc != skip && objc != skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?");
	return TCL_ERROR;
    }
    Tcl_Obj *cfgSupportName = Tcl_NewStringObj(
	    "::oo::configuresupport::configurable", TCL_AUTO_LENGTH);
    Class *mixin = TclOOGetClassFromObj(interp, cfgSupportName);
    Tcl_BounceRefCount(cfgSupportName);
    if (!mixin) {
	return TCL_ERROR;
    }
    TclOOClassSetMixins(interp, oPtr->classPtr, 1, &mixin);
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_Cloned --
 *
 *	Handler for cloning objects that clones basic bits (only!) of the
 *	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
 *	more complex (and class-specific) handling.
 *
 * ----------------------------------------------------------------------
 */
int
TclOO_Object_Cloned(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		// Interpreter for error reporting.
    Tcl_ObjectContext context,	// The object/call context.
    Tcl_Size objc,			// Number of arguments.
    Tcl_Obj *const *objv)	// The actual arguments.
{
    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
    if (objc != skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv, "originObject");
	return TCL_ERROR;
    }
    Object *targetObject = (Object *) Tcl_ObjectContextObject(context);
    Object *originObject = (Object *) Tcl_GetObjectFromObj(interp, objv[skip]);
    if (!originObject) {
	return TCL_ERROR;
    }

    Namespace *originNs = (Namespace *) originObject->namespacePtr;
    Namespace *targetNs = (Namespace *) targetObject->namespacePtr;
    if (TclCopyNamespaceProcedures(interp, originNs, targetNs) != TCL_OK) {
	return TCL_ERROR;
    }
    return TclCopyNamespaceVariables(interp, originNs, targetNs);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_Destroy --
 *
 *	Implementation for oo::object->destroy method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Object_Destroy(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    CallContext *contextPtr;

    if (objc != Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
	oPtr->flags |= DESTRUCTOR_CALLED;
	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
		NULL);
	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
		    NULL, NULL, NULL);
	    TclPushTailcallPoint(interp);
	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
	}
    }
    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(interp, oPtr->command);
    }
    return TCL_OK;
}

/* Post-NRE-callback for TclOO_Object_Destroy. Deletes the object command if
 * it's still there, which triggers destruction of the namespace and attached
 * structures. */
static int
AfterNRDestructor(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = (CallContext *) data[0];

    if (contextPtr->oPtr->command) {
	Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
    }
    TclOODeleteContext(contextPtr);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_Eval --
 *
 *	Implementation for oo::object->eval method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Object_Eval(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    CallContext *contextPtr = (CallContext *) context;
    Tcl_Object object = Tcl_ObjectContextObject(context);
    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
    CallFrame *framePtr, **framePtrPtr = &framePtr;
    Tcl_Obj *scriptPtr;
    CmdFrame *invoker;

    if (objc < skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Make the object's namespace the current namespace and evaluate the
     * command(s).
     */

    (void)TclPushStackFrame(interp, (Tcl_CallFrame **)framePtrPtr,
	    Tcl_GetObjectNamespace(object), FRAME_IS_METHOD);
    framePtr->clientData = context;
    framePtr->objc = objc;
    framePtr->objv = objv;	/* Reference counts do not need to be
				 * incremented here. */

    if (!(contextPtr->callPtr->flags & PUBLIC_METHOD)) {
	object = NULL;		/* Now just for error mesage printing. */
    }

    /*
     * Work out what script we are actually going to evaluate.
     *
     * When there's more than one argument, we concatenate them together with
     * spaces between, then evaluate the result. Tcl_EvalObjEx will delete the
     * object when it decrements its refcount after eval'ing it.
     */

    if (objc != skip+1) {
	scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
	invoker = NULL;
    } else {
	scriptPtr = objv[skip];
	invoker = ((Interp *) interp)->cmdFramePtr;
    }

    /*
     * Evaluate the script now, with FinalizeEval to do the processing after
     * the script completes.
     */

    TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL);
    return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip);
}

/* Post-NRE-callback for TclOO_Object_Eval. Cleans up. */
static int
FinalizeEval(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    if (result == TCL_ERROR) {
	Object *oPtr = (Object *) data[0];
	const char *namePtr;

	if (oPtr) {
	    namePtr = TclGetString(TclOOObjectName(interp, oPtr));
	} else {
	    namePtr = "my";
	}

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (in \"%s eval\" script line %d)",
		namePtr, Tcl_GetErrorLine(interp)));
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_Unknown --
 *
 *	Default unknown method handler method (defined in oo::object). This
 *	just creates a suitable error message.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Object_Unknown(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    CallContext *contextPtr = (CallContext *) context;
    Object *callerObj = NULL;
    Class *callerCls = NULL;
    Object *oPtr = contextPtr->oPtr;
    Tcl_Obj **methodNames;
    Tcl_Size numMethodNames, i;
    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    Tcl_Obj *errorMsg;

    /*
     * If no method name, generate an error asking for a method name. (Only by
     * overriding *this* method can an object handle the absence of a method
     * name without an error).
     */

    if (objc < skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Determine if the calling context should know about extra private
     * methods, and if so, which.
     */

    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	CallContext *callerContext = (CallContext *) framePtr->clientData;
	Method *mPtr = CurrentlyInvoked(callerContext).mPtr;

	if (mPtr->declaringObjectPtr) {
	    if (oPtr == mPtr->declaringObjectPtr) {
		callerObj = mPtr->declaringObjectPtr;
	    }
	} else {
	    if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
		callerCls = mPtr->declaringClassPtr;
	    }
	}
    }

    /*
     * Get the list of methods that we want to know about.
     */

    numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
	    contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);

    /*
     * Special message when there are no visible methods at all.
     */

    if (numMethodNames == 0) {
	Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
	const char *piece;

	if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
	    piece = "visible methods";
	} else {
	    piece = "methods";
	}
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[skip]), (char *)NULL);
	return TCL_ERROR;
    }

    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
	    TclGetString(objv[skip]));
    for (i=0 ; i<numMethodNames-1 ; i++) {
	if (i) {
	    Tcl_AppendToObj(errorMsg, ", ", TCL_AUTO_LENGTH);
	}
	Tcl_AppendObjToObj(errorMsg, methodNames[i]);
    }
    if (i) {
	Tcl_AppendToObj(errorMsg, " or ", TCL_AUTO_LENGTH);
    }
    Tcl_AppendObjToObj(errorMsg, methodNames[i]);
    Tcl_Free((void *)methodNames);
    Tcl_SetObjResult(interp, errorMsg);
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[skip]), (char *)NULL);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_LinkVar --
 *
 *	Implementation of oo::object->variable method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Object_LinkVar(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Object object = Tcl_ObjectContextObject(context);
    Namespace *savedNsPtr;
    Tcl_Size i;

    if (objc < Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?varName ...?");
	return TCL_ERROR;
    }

    /*
     * A sanity check. Shouldn't ever happen. (This is all that remains of a
     * more complex check inherited from [global] after we have applied the
     * fix for [Bug 2903811]; note that the fix involved *removing* code.)
     */

    if (iPtr->varFramePtr == NULL) {
	return TCL_OK;
    }

    for (i = Tcl_ObjectContextSkippedArgs(context) ; i < objc ; i++) {
	Var *varPtr, *aryPtr;
	const char *varName = TclGetString(objv[i]);

	/*
	 * The variable name must not contain a '::' since that's illegal in
	 * local names.
	 */

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "variable name \"%s\" illegal: must not contain namespace"
		    " separator", varName));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL);
	    return TCL_ERROR;
	}

	/*
	 * Switch to the object's namespace for the duration of this call.
	 * Like this, the variable is looked up in the namespace of the
	 * object, and not in the namespace of the caller. Otherwise this
	 * would only work if the caller was a method of the object itself,
	 * which might not be true if the method was exported. This is a bit
	 * of a hack, but the simplest way to do this (pushing a stack frame
	 * would be horribly expensive by comparison).
	 */

	savedNsPtr = iPtr->varFramePtr->nsPtr;
	iPtr->varFramePtr->nsPtr = (Namespace *)
		Tcl_GetObjectNamespace(object);
	varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
		"define", 1, 0, &aryPtr);
	iPtr->varFramePtr->nsPtr = savedNsPtr;

	if (varPtr == NULL || aryPtr != NULL) {
	    /*
	     * Variable cannot be an element in an array. If aryPtr is not
	     * NULL, it is an element, so throw up an error and return.
	     */

	    TclVarErrMsg(interp, varName, NULL, "define",
		    "name refers to an element in an array");
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL);
	    return TCL_ERROR;
	}

	/*
	 * Arrange for the lifetime of the variable to be correctly managed.
	 * This is copied out of Tcl_VariableObjCmd...
	 */

	if (!TclIsVarNamespaceVar(varPtr)) {
	    TclSetVarNamespaceVar(varPtr);
	}

	if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOLookupObjectVar --
 *
 *	Look up a variable in an object. Tricky because of private variables.
 *
 * Returns:
 *	Handle to the variable if it can be found, or NULL if there's an error.
 *
 * ----------------------------------------------------------------------
 */
Tcl_Var
TclOOLookupObjectVar(
    Tcl_Interp *interp,
    Tcl_Object object,		/* Object we're looking up within. */
    Tcl_Obj *varName,		/* User-visible name we're looking up. */
    Tcl_Var *aryPtr)		/* Where to write the handle to the array
				 * containing the element; if not an element,
				 * then the variable this points to is set to
				 * NULL. */
{
    const char *arg = TclGetString(varName);
    Tcl_Obj *varNamePtr;

    /*
     * Convert the variable name to fully-qualified form if it wasn't already.
     * This has to be done prior to lookup because we can run into problems
     * with resolvers otherwise. [Bug 3603695]
     *
     * We still need to do the lookup; the variable could be linked to another
     * variable and we want the target's name.
     */

    if (arg[0] == ':' && arg[1] == ':') {
	varNamePtr = varName;
    } else {
	Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(object);
	CallFrame *framePtr = ((Interp *) interp)->varFramePtr;

	/*
	 * Private method handling. [TIP 500]
	 *
	 * If we're in a context that can see some private methods of an
	 * object, we may need to precede a variable name with its prefix.
	 * This is a little tricky as we need to check through the inheritance
	 * hierarchy when the method was declared by a class to see if the
	 * current object is an instance of that class.
	 */

	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	    Object *oPtr = (Object *) object;
	    CallContext *callerContext = (CallContext *) framePtr->clientData;
	    Method *mPtr = CurrentlyInvoked(callerContext).mPtr;
	    PrivateVariableMapping *pvPtr;
	    Tcl_Size i;

	    if (mPtr->declaringObjectPtr == oPtr) {
		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
		    if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
			    TCL_INDEX_NONE)) {
			varName = pvPtr->fullNameObj;
			break;
		    }
		}
	    } else if (mPtr->declaringClassPtr &&
		    mPtr->declaringClassPtr->privateVariables.num) {
		Class *clsPtr = mPtr->declaringClassPtr;
		bool isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
		Class *mixinCls;

		if (!isInstance) {
		    FOREACH(mixinCls, oPtr->mixins) {
			if (TclOOIsReachable(clsPtr, mixinCls)) {
			    isInstance = true;
			    break;
			}
		    }
		}
		if (isInstance) {
		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
			if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
				TCL_INDEX_NONE)) {
			    varName = pvPtr->fullNameObj;
			    break;
			}
		    }
		}
	    }
	}

	// The namespace isn't the global one; necessarily true for any object!
	varNamePtr = Tcl_ObjPrintf("%s::%s",
		namespacePtr->fullName, TclGetString(varName));
    }
    Tcl_IncrRefCount(varNamePtr);
    Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL,
	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1,
	    (Var **) aryPtr);
    Tcl_DecrRefCount(varNamePtr);
    if (var == NULL) {
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL);
    } else if (*aryPtr == NULL && TclIsVarArrayElement((Var *) var)) {
	/*
	 * If the varPtr points to an element of an array but we don't already
	 * have the array, find it now. Note that this can't be easily
	 * backported; the arrayPtr field is new in Tcl 9.0. [Bug 2da1cb0c80]
	 */
	*aryPtr = (Tcl_Var) TclVarParentArray(var);
    }

    return var;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Object_VarName --
 *
 *	Implementation of the oo::object->varname method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Object_VarName(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Tcl_Var varPtr, aryVar;
    Tcl_Obj *varNamePtr;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"varName");
	return TCL_ERROR;
    }

    varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
	    objv[objc - 1], &aryVar);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * The variable reference must not disappear too soon. [Bug 74b6110204]
     */
    if (!TclIsVarArrayElement((Var *) varPtr)) {
	TclSetVarNamespaceVar((Var *) varPtr);
    }

    /*
     * Now that we've pinned down what variable we're really talking about
     * (including traversing variable links), convert back to a name.
     */

    TclNewObj(varNamePtr);

    if (aryVar != NULL) {
	Tcl_GetVariableFullName(interp, aryVar, varNamePtr);
	Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString(
		VarHashGetKey(varPtr)));
    } else {
	Tcl_GetVariableFullName(interp, varPtr, varNamePtr);
    }
    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOLinkObjCmd --
 *
 *	Implementation of the [link] command, that makes a command that
 *	invokes a method on the current object. The name of the command and
 *	the name of the method match by default. Note that this command is
 *	only ever to be used inside the body of a procedure-like method,
 *	and is typically intended for constructors.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOLinkObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    // Set up common bits.
    CallContext *context = TclOOGetContextFromCurrentStackFrame(interp,
	    TclGetString(objv[0]));
    if (!context) {
	return TCL_ERROR;
    }
    Object *oPtr = context->oPtr;
    if (!oPtr->myCommand) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"cannot link to non-existent callback handle"));
	OO_ERROR(interp, MY_GONE);
	return TCL_ERROR;
    }
    Tcl_Obj *myCmd = Tcl_NewObj();
    Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd);
    if (!oPtr->linkedCmdsList) {
	oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL);
	Tcl_IncrRefCount(oPtr->linkedCmdsList);
    }

    // For each argument
    for (Tcl_Size i=1; i<objc; i++) {
	Tcl_Size linkc;
	Tcl_Obj **linkv, *src, *dst;

	// Parse as list of (one or) two items: source and destination names
	if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) {
	    Tcl_BounceRefCount(myCmd);
	    return TCL_ERROR;
	}
	switch (linkc) {
	case 1:
	    // Degenerate case
	    src = dst = linkv[0];
	    break;
	case 2:
	    src = linkv[0];
	    dst = linkv[1];
	    break;
	default:
	    Tcl_BounceRefCount(myCmd);
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad link description; must only have one or two elements"));
	    OO_ERROR(interp, CMDLINK_FORMAT);
	    return TCL_ERROR;
	}

	// Qualify the source if necessary
	const char *srcStr = TclGetString(src);
	if (srcStr[0] != ':' || srcStr[1] != ':') {
	    src = Tcl_ObjPrintf("%s::%s",
		    context->oPtr->namespacePtr->fullName, srcStr);
	}

	// Make the alias command
	if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) {
	    Tcl_BounceRefCount(myCmd);
	    Tcl_BounceRefCount(src);
	    return TCL_ERROR;
	}

	// Remember the alias for cleanup if necessary
	Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src);
    }
    Tcl_BounceRefCount(myCmd);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOONextObjCmd, TclOONextToObjCmd --
 *
 *	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.
 *
 * ----------------------------------------------------------------------
 */

int
TclOONextObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    Tcl_ObjectContext context = (Tcl_ObjectContext)
	    TclOOGetContextFromCurrentStackFrame(interp, TclGetString(objv[0]));

    /*
     * 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 (!context) {
	return TCL_ERROR;
    }

    /*
     * Invoke the (advanced) method call context in the caller context. Note
     * that this is like [uplevel 1] and not [eval].
     */

    TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
    iPtr->varFramePtr = framePtr->callerVarPtr;
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}

int
TclOONextToObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    /*
     * 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.
     */

    CallContext *contextPtr = TclOOGetContextFromCurrentStackFrame(interp,
	    TclGetString(objv[0]));
    if (!contextPtr) {
	return TCL_ERROR;
    }

    /*
     * 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;
    }
    Class *classPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (classPtr == 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!
     */

    Tcl_Size i;
    for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
	MInvoke *miPtr = &contextPtr->callPtr->chain[i];

	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
	    Interp *iPtr = (Interp *) interp;
	    CallFrame *framePtr = iPtr->varFramePtr;

	    /*
	     * Invoke the (advanced) method call context in the caller
	     * context. Note that this is like [uplevel 1] and not [eval].
	     */

	    TclNRAddCallback(interp, NextRestoreFrame, 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.
     */

    const char *methodType = TclOOContextTypeName(contextPtr);
    for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
	MInvoke *miPtr = &contextPtr->callPtr->chain[i];

	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "%s implementation by \"%s\" not reachable from here",
		    methodType, TclGetString(objv[1])));
	    OO_ERROR(interp, CLASS_NOT_REACHABLE);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "%s has no non-filter implementation by \"%s\"",
	    methodType, TclGetString(objv[1])));
    OO_ERROR(interp, CLASS_NOT_THERE);
    return TCL_ERROR;
}

/* Post-NRE-callback for [next] and [nextto]. */
static int
NextRestoreFrame(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    CallContext *contextPtr = (CallContext *) data[1];

    iPtr->varFramePtr = (CallFrame *) data[0];
    if (contextPtr != NULL) {
	contextPtr->index = PTR2UINT(data[2]);
    }
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * MethodName --
 *
 *	Helper for TclOOSelfObjCmd to generate the correct name for a method.
 *
 * ----------------------------------------------------------------------
 */
static inline Tcl_Obj *
MethodName(
    Foundation *fPtr,
    CallContext *contextPtr,
    Method *mPtr)
{
    switch (contextPtr->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) {
    case CONSTRUCTOR:
	return fPtr->constructorName;
    case DESTRUCTOR:
	return fPtr->destructorName;
    default:
	return mPtr->namePtr;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * Declarer --
 *
 *	Helper for TclOOSelfObjCmd to get the (named) entity declaring a method.
 *
 * ----------------------------------------------------------------------
 */
static inline Object *
Declarer(
    Method *mPtr)
{
    if (mPtr->declaringClassPtr != NULL) {
	return mPtr->declaringClassPtr->thisPtr;
    } else if (mPtr->declaringObjectPtr != NULL) {
	return mPtr->declaringObjectPtr;
    } else {
	TCL_UNREACHABLE();
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOSelfObjCmd --
 *
 *	Implementation of the [self] command, which provides introspection of
 *	the call context.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOSelfObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    static const char *const subcmds[] = {
	"call", "caller", "class", "filter", "method", "namespace", "next",
	"object", "target", NULL
    };
    enum SelfCmds {
	SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
	SELF_NEXT, SELF_OBJECT, SELF_TARGET
    } index;
    Interp *iPtr = (Interp *) interp;
    Foundation *fPtr = (Foundation *) iPtr->objectFoundation;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *result[3];

    /*
     * Start with sanity checks on the calling context and the method context.
     */

    contextPtr = TclOOGetContextFromCurrentStackFrame(interp,
	    TclGetString(objv[0]));
    if (!contextPtr) {
	return TCL_ERROR;
    }

    /*
     * Now we do "conventional" argument parsing for a while. Note that no
     * subcommand takes arguments.
     */

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
	return TCL_ERROR;
    } else if (objc == 1) {
	index = SELF_OBJECT;
    } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case SELF_OBJECT:
	Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
	return TCL_OK;
    case SELF_NS:
	Tcl_SetObjResult(interp,
		TclNewNamespaceObj(contextPtr->oPtr->namespacePtr));
	return TCL_OK;
    case SELF_CLASS: {
	Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;

	if (clsPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "method not defined by a class", TCL_AUTO_LENGTH));
	    OO_ERROR(interp, UNMATCHED_CONTEXT);
	    return TCL_ERROR;
	}

	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
	return TCL_OK;
    }
    case SELF_METHOD:
	Tcl_SetObjResult(interp, MethodName(fPtr, contextPtr,
		CurrentlyInvoked(contextPtr).mPtr));
	return TCL_OK;
    case SELF_FILTER:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", TCL_AUTO_LENGTH));
	    OO_ERROR(interp, UNMATCHED_CONTEXT);
	    return TCL_ERROR;
	} else {
	    MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
	    Object *oPtr;
	    const char *type;

	    if (miPtr->filterDeclarer != NULL) {
		oPtr = miPtr->filterDeclarer->thisPtr;
		type = "class";
	    } else {
		oPtr = contextPtr->oPtr;
		type = "object";
	    }

	    result[0] = TclOOObjectName(interp, oPtr);
	    result[1] = Tcl_NewStringObj(type, TCL_AUTO_LENGTH);
	    result[2] = miPtr->mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_CALLER:
	if ((framePtr->callerVarPtr == NULL) ||
		!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "caller is not an object", TCL_AUTO_LENGTH));
	    OO_ERROR(interp, CONTEXT_REQUIRED);
	    return TCL_ERROR;
	} else {
	    CallContext *callerPtr = (CallContext *)
		    framePtr->callerVarPtr->clientData;
	    Method *mPtr = CurrentlyInvoked(callerPtr).mPtr;

	    result[0] = TclOOObjectName(interp, Declarer(mPtr));
	    result[1] = TclOOObjectName(interp, callerPtr->oPtr);
	    result[2] = MethodName(fPtr, callerPtr, mPtr);
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_NEXT:
	if (contextPtr->index < contextPtr->callPtr->numChain - 1) {
	    Method *mPtr =
		    contextPtr->callPtr->chain[contextPtr->index + 1].mPtr;

	    result[0] = TclOOObjectName(interp, Declarer(mPtr));
	    result[1] = MethodName(fPtr, contextPtr, mPtr);
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	}
	return TCL_OK;
    case SELF_TARGET:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", TCL_AUTO_LENGTH));
	    OO_ERROR(interp, UNMATCHED_CONTEXT);
	    return TCL_ERROR;
	} else {
	    Method *mPtr;
	    Tcl_Size i;

	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++) {
		if (!contextPtr->callPtr->chain[i].isFilter) {
		    break;
		}
	    }
	    if (i == contextPtr->callPtr->numChain) {
		Tcl_Panic("filtering call chain without terminal non-filter");
	    }
	    mPtr = contextPtr->callPtr->chain[i].mPtr;
	    result[0] = TclOOObjectName(interp, Declarer(mPtr));
	    result[1] = MethodName(fPtr, contextPtr, mPtr);
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	    return TCL_OK;
	}
    case SELF_CALL:
	result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
	TclNewIndexObj(result[1], contextPtr->index);
	Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	return TCL_OK;
    default:
	TCL_UNREACHABLE();
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * CopyObjectCmd --
 *
 *	Implementation of the [oo::copy] command, which clones an object (but
 *	not its namespace). Note that no constructors are called during this
 *	process.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOCopyObjectCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Tcl_Object oPtr, o2Ptr;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"sourceName ?targetName? ?targetNamespace?");
	return TCL_ERROR;
    }

    oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Create a cloned object of the correct class. Note that constructors are
     * not called. Also note that we must resolve the object name ourselves
     * because we do not want to create the object in the current namespace,
     * but rather in the context of the namespace of the caller of the overall
     * [oo::define] command.
     */

    if (objc == 2) {
	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
    } else {
	const char *name, *namespaceName;

	name = TclGetString(objv[2]);
	if (name[0] == '\0') {
	    name = NULL;
	}

	/*
	 * Choose a unique namespace name if the user didn't supply one.
	 */

	namespaceName = NULL;
	if (objc == 4) {
	    namespaceName = TclGetString(objv[3]);

	    if (namespaceName[0] == '\0') {
		namespaceName = NULL;
	    } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
		    0) != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"%s refers to an existing namespace", namespaceName));
		return TCL_ERROR;
	    }
	}

	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
    }

    if (o2Ptr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Return the name of the cloned object.
     */

    Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOCallbackObjCmd --
 *
 *	Implementation of the [callback] command, which constructs callbacks
 *	into the current object.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOCallbackObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    /*
     * 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.
     */

    CallContext *contextPtr = TclOOGetContextFromCurrentStackFrame(interp,
	    TclGetString(objv[0]));
    if (!contextPtr) {
	return TCL_ERROR;
    }
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "method ...");
	return TCL_ERROR;
    }

    // Get the [my] real name.
    Tcl_Obj *namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
    if (!namePtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no possible safe callback without my", TCL_AUTO_LENGTH));
	OO_ERROR(interp, NO_MY);
	return TCL_ERROR;
    }

    // No check that the method exists; could be dynamically added.

    Tcl_Obj *listPtr = Tcl_NewListObj(1, &namePtr);
    (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassVariableObjCmd --
 *
 *	Implementation of the [classvariable] command, which links to
 *	variables in the class of the current object.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOClassVariableObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ...");
	return TCL_ERROR;
    }

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

    // Get a reference to the class's namespace
    CallContext *contextPtr = TclOOGetContextFromCurrentStackFrame(interp,
	    TclGetString(objv[0]));
    if (!contextPtr) {
	return TCL_ERROR;
    }
    Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
    if (clsPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method not defined by a class", TCL_AUTO_LENGTH));
	OO_ERROR(interp, UNMATCHED_CONTEXT);
	return TCL_ERROR;
    }
    Tcl_Namespace *clsNsPtr = clsPtr->thisPtr->namespacePtr;

    // Check the list of variable names
    for (Tcl_Size i = 1; i < objc; i++) {
	const char *varName = TclGetString(objv[i]);
	if (Tcl_StringMatch(varName, "*(*)")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad variable name \"%s\": can't create a %s",
		    varName, "scalar variable that looks like an array element"));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*::*")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad variable name \"%s\": can't create a %s",
		    varName, "local variable with a namespace separator in it"));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL);
	    return TCL_ERROR;
	}
    }

    // Lastly, link the caller's local variables to the class's variables
    Interp *iPtr = (Interp *) interp;
    Tcl_Namespace *ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
    for (Tcl_Size i = 1; i < objc; i++) {
	// Locate the other variable.
	iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
	Var *arrayPtr, *otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
		(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
		"access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
	iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr;
	if (otherPtr == NULL) {
	    return TCL_ERROR;
	}

	// Create the new variable and link it to otherPtr.
	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
		TCL_INDEX_NONE) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODelegateNameObjCmd --
 *
 *	Implementation of the [oo::DelegateName] command, which is a utility
 *	that gets the name of the class delegate for a class. It's trivial,
 *	but makes working with them much easier as delegate names are
 *	intentionally hard to create by accident.
 *
 *	Not part of TclOO public API. No public documentation.
 *
 * ----------------------------------------------------------------------
 */
int
TclOODelegateNameObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "class");
	return TCL_ERROR;
    }
    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate",
	    clsPtr->thisPtr->namespacePtr->fullName));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Singleton_New, MarkAsSingleton --
 *
 *	Implementation for oo::singleton->new method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Singleton_New(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Class *clsPtr = oPtr->classPtr;

    if (clsPtr->instances.num) {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->instances.list[0]));
	return TCL_OK;
    }

    TclNRAddCallback(interp, MarkAsSingleton, clsPtr, NULL, NULL, NULL);
    return TclNRNewObjectInstance(interp, (Tcl_Class) clsPtr,
	    NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context),
	    AddConstructionFinalizer(interp));
}

/* Once the singleton object is made, this mixes in a class to disable easy
 * deleting of the instance. */
static int
MarkAsSingleton(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Class *clsPtr = (Class *) data[0];
    if (result == TCL_OK && clsPtr->instances.num) {
	// Prepend oo::SingletonInstance to the list of mixins
	Tcl_Obj *singletonInstanceName = Tcl_NewStringObj(
		"::oo::SingletonInstance", TCL_AUTO_LENGTH);
	Class *singInst = TclOOGetClassFromObj(interp, singletonInstanceName);
	Tcl_BounceRefCount(singletonInstanceName);
	if (!singInst) {
	    return TCL_ERROR;
	}
	Object *oPtr = clsPtr->instances.list[0];
	Tcl_Size mixinc = oPtr->mixins.num;
	Class **mixins = (Class **)TclStackAlloc(interp,
		sizeof(Class *) * (mixinc + 1));
	if (mixinc > 0) {
	    memcpy(mixins + 1, oPtr->mixins.list, mixinc * sizeof(Class *));
	}
	mixins[0] = singInst;
	TclOOObjectSetMixins(oPtr, mixinc + 1, mixins);
	TclStackFree(interp, mixins);
    }
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_SingletonInstance_Destroy, TclOO_SingletonInstance_Cloned --
 *
 *	Implementation for oo::SingletonInstance->destroy method and its
 *	cloning callback method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_SingletonInstance_Destroy(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    TCL_UNUSED(Tcl_ObjectContext),
    TCL_UNUSED(Tcl_Size),
    TCL_UNUSED(Tcl_Obj *const *))
{
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "may not destroy a singleton object"));
    OO_ERROR(interp, SINGLETON);
    return TCL_ERROR;
}

int
TclOO_SingletonInstance_Cloned(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    TCL_UNUSED(Tcl_ObjectContext),
    TCL_UNUSED(Tcl_Size),
    TCL_UNUSED(Tcl_Obj *const *))
{
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "may not clone a singleton object"));
    OO_ERROR(interp, SINGLETON);
    return TCL_ERROR;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */