Tcl Source Code

    }

    /*
     * 'proc'. Common to all frame types. Conditional on having an associated
     * Procedure CallFrame.
     */

    if (procPtr != NULL) {





	Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;

	if (namePtr) {
	    Tcl_Obj *procNameObj;

	    /*
	     * This is a regular command.

				 * before the method executes. */
    TclOO_PostCallProc *postCallProc;
				/* Callback to allow for additional cleanup
				 * after the method executes. */
    GetFrameInfoValueProc *gfivProc;
				/* Callback to allow for fine tuning of how
				 * the method reports itself. */
    Command cmd;		/* Space used to connect to [info frame] */
    ExtraFrameInfo efi;		/* Space used to store data for [info frame] */
    Tcl_Interp *interp;		/* Interpreter in which to compute the name of
				 * the method. */
    Tcl_Method method;		/* Method to compute the name of. */
    int callSiteFlags;		/* Flags from the call chain. Only interested
				 * in whether this is a constructor or
				 * destructor, which we can't know until then
				 * for messy reasons. Other flags are variable
				 * but not used. */
} ProcedureMethod;

#define TCLOO_PROCEDURE_METHOD_VERSION 0

/*
 * Flags for use in a ProcedureMethod.
 *

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












/*
 * Structure used to contain all the information needed about a call frame
 * used in a procedure-like method.
 */

typedef struct {
    CallFrame *framePtr;	/* Reference to the call frame itself (it's
				 * actually allocated on the Tcl stack). */
    ProcErrorProc *errProc;	/* The error handler for the body. */
    Tcl_Obj *nameObj;		/* The "name" of the command. Only used for a



				 * few moments, so not reference. */


} PMFrameData;

/*
 * Structure used to pass information about variable resolution to the
 * on-the-ground resolvers used when working with resolved compiled variables.
 */

			    void *clientData, void **newClientData);
static void		MethodErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static void		ConstructorErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static void		DestructorErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static Tcl_Obj *	RenderMethodName(void *clientData);
static Tcl_Obj *	RenderDeclarerName(void *clientData);
static int		InvokeForwardMethod(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static void		DeleteForwardMethod(void *clientData);
static int		CloneForwardMethod(Tcl_Interp *interp,
			    void *clientData, void **newClientData);

 * Helper macros (derived from things private to tclVar.c)
 */

#define TclVarTable(contextNs) \
    ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
    ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))

static inline ProcedureMethod *
AllocProcedureMethodRecord(
    int flags)
{
    ProcedureMethod *pmPtr = (ProcedureMethod *)
	    ckalloc(sizeof(ProcedureMethod));
    memset(pmPtr, 0, sizeof(ProcedureMethod));
    pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
    pmPtr->flags = flags & USE_DECLARER_NS;
    pmPtr->refCount = 1;
    pmPtr->cmd.clientData = &pmPtr->efi;
    return pmPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * Tcl_NewInstanceMethod --
 *
 *	Attach a method to an object instance.

    int argsLen;
    ProcedureMethod *pmPtr;
    Tcl_Method method;

    if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
	return NULL;
    }





    pmPtr = AllocProcedureMethodRecord(flags);
    method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
	    argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
    if (method == NULL) {
	ckfree(pmPtr);
    } else if (pmPtrPtr != NULL) {
	*pmPtrPtr = pmPtr;
    }

	procName = "<destructor>";
    } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
	return NULL;
    } else {
	procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
    }






    pmPtr = AllocProcedureMethodRecord(flags);
    method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
	    argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);

    if (argsLen == -1) {
	Tcl_DecrRefCount(argsObj);
    }
    if (method == NULL) {

 *	How to invoke a procedure-like method.
 *
 * ----------------------------------------------------------------------
 */

static int
InvokeProcedureMethod(
    void *clientData,		/* Pointer to some per-method context. */
    Tcl_Interp *interp,
    Tcl_ObjectContext context,	/* The method calling context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
{
    ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
    int result;

    if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) ||
	Tcl_InterpDeleted(interp)
    ) {
	return TclNRObjectContextInvokeNext(interp, context, objc, objv,
		Tcl_ObjectContextSkippedArgs(context));
    }

    /*
     * Finishes filling out the extra frame info so that [info frame] works if
     * that is not already set up.
     */

    if (pmPtr->efi.length == 0) {
	Tcl_Method method = Tcl_ObjectContextMethod(context);

	pmPtr->efi.length = 2;
	pmPtr->efi.fields[0].name = "method";
	pmPtr->efi.fields[0].proc = RenderMethodName;
	pmPtr->efi.fields[0].clientData = pmPtr;
	pmPtr->callSiteFlags = ((CallContext *)
		context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR);
	pmPtr->interp = interp;
	pmPtr->method = method;
	if (pmPtr->gfivProc != NULL) {
	    pmPtr->efi.fields[1].name = "";
	    pmPtr->efi.fields[1].proc = pmPtr->gfivProc;
	    pmPtr->efi.fields[1].clientData = pmPtr;
	} else {
	    if (Tcl_MethodDeclarerObject(method) != NULL) {
		pmPtr->efi.fields[1].name = "object";
	    } else {
		pmPtr->efi.fields[1].name = "class";
	    }
	    pmPtr->efi.fields[1].proc = RenderDeclarerName;
	    pmPtr->efi.fields[1].clientData = pmPtr;
	}
    }

    /*
     * Allocate the special frame data.
     */

    fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData));

    if (pmPtr->preCallProc != NULL) {
	int isFinished;

	result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
		(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
	if (isFinished || result != TCL_OK) {







	    Tcl_PopCallFrame(interp);
	    TclStackFree(interp, fdPtr->framePtr);
	    if (pmPtr->refCount-- <= 1) {
		DeleteProcedureMethodRecord(pmPtr);
	    }
	    TclStackFree(interp, fdPtr);
	    return result;

    if (pmPtr->postCallProc) {
	result = pmPtr->postCallProc(pmPtr->clientData, interp, context,
		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),
		result);
    }








    /*
     * Scrap the special frame data now that we're done with it. Note that we
     * are inlining DeleteProcedureMethod() here; this location is highly
     * sensitive when it comes to performance!
     */

    if (pmPtr->refCount-- <= 1) {

    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv,	/* Array of arguments. */
    PMFrameData *fdPtr)		/* Place to store information about the call
				 * frame. */
{
    Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
    int result;

    CallFrame **framePtrPtr = &fdPtr->framePtr;

    /*
     * Compute basic information on the basis of the type of method it is.
     */

    if (contextPtr->callPtr->flags & CONSTRUCTOR) {

	fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
	fdPtr->errProc = ConstructorErrorHandler;
    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {

	fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName;
	fdPtr->errProc = DestructorErrorHandler;
    } else {
	fdPtr->nameObj = Tcl_MethodName(
		Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));

	fdPtr->errProc = MethodErrorHandler;
    }
    if (pmPtr->errProc != NULL) {
	fdPtr->errProc = pmPtr->errProc;
    }

    /*
     * Magic to enable things like [incr Tcl], which wants methods to run in
     * their class's namespace.
     */

    if (pmPtr->flags & USE_DECLARER_NS) {

	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;

	if (mPtr->declaringClassPtr != NULL) {
	    nsPtr = (Namespace *)
		    mPtr->declaringClassPtr->thisPtr->namespacePtr;
	} else {
	    nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr;
	}
    }

    /*








     * Compile the body.

     *







     * [Bug 2037727] Always call TclProcCompileProc so that we check not only
     * that we have bytecode, but also that it remains valid. Note that we set
     * the namespace of the code here directly; this is a hack, but the
     * alternative is *so* slow...
     */

    pmPtr->procPtr->cmdPtr = &pmPtr->cmd;
    if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
	ByteCode *codePtr =
		pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;

	codePtr->nsPtr = nsPtr;
    }
    result = TclProcCompileProc(interp, pmPtr->procPtr,
	    pmPtr->procPtr->bodyPtr, nsPtr, "body of method",
	    TclGetString(fdPtr->nameObj));
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Make the stack frame and fill it out with information about this call.
     * This operation doesn't ever actually fail.
     */

    (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
	    (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD);

    fdPtr->framePtr->clientData = contextPtr;
    fdPtr->framePtr->objc = objc;
    fdPtr->framePtr->objv = objv;
    fdPtr->framePtr->procPtr = pmPtr->procPtr;



























    return TCL_OK;









}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOSetupVariableResolver, etc. --
 *

    *rPtrPtr = &infoPtr->info;
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * RenderMethodName --
 *
 *	Returns the name of the declared method. Used for producing information
 *	for [info frame].
 *
 * ----------------------------------------------------------------------
 */

static Tcl_Obj *
RenderMethodName(
    void *clientData)
{
    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;

    if (pmPtr->callSiteFlags & CONSTRUCTOR) {
	return TclOOGetFoundation(pmPtr->interp)->constructorName;
    } else if (pmPtr->callSiteFlags & DESTRUCTOR) {
	return TclOOGetFoundation(pmPtr->interp)->destructorName;
    } else {
	return Tcl_MethodName(pmPtr->method);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * RenderDeclarerName --
 *
 *	Returns the name of the entity (object or class) which declared a
 *	method. Used for producing information for [info frame] in such a way
 *	that the expensive part of this (generating the object or class name
 *	itself) isn't done until it is needed.
 *
 * ----------------------------------------------------------------------
 */

static Tcl_Obj *
RenderDeclarerName(
    void *clientData)
{
    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
    Tcl_Object object = Tcl_MethodDeclarerObject(pmPtr->method);

    if (object == NULL) {
	object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pmPtr->method));
    }
    return TclOOObjectName(pmPtr->interp, (Object *) object);
}

/*
 * ----------------------------------------------------------------------
 *
 * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler --
 *

     * Create the actual copy of the method record, manufacturing a new proc
     * record.
     */

    pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
    memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
    pm2Ptr->refCount = 1;
    pm2Ptr->cmd.clientData = &pm2Ptr->efi;
    pm2Ptr->efi.length = 0;	/* Trigger a reinit of this. */
    Tcl_IncrRefCount(argsObj);
    Tcl_IncrRefCount(bodyObj);
    if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
	    &pm2Ptr->procPtr) != TCL_OK) {
	Tcl_DecrRefCount(argsObj);
	Tcl_DecrRefCount(bodyObj);
	ckfree(pm2Ptr);

	lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
	info frame 0
    }
    [c new] test
} -match glob -cleanup {
    c destroy
} -result {* cmd {info frame 0} method test class ::c level 0}

# Common code for oo-22.{3,4,5,6}
oo::class create WorkerBase
oo::class create WorkerSupport {
    superclass oo::class WorkerBase
    variable result stop
    method WithWorkers {nworkers args script} {
	set workers {}
	try {
	    for {set n 1} {$n <= $nworkers} {incr n} {

		lappend workers [set worker [[self] new]]
		$worker schedule {*}$args
	    }

	    return [uplevel 1 $script]
	} finally {

	    foreach worker $workers {$worker destroy}
	} 
    }
    method run {nworkers} {
	set result {}
	set stopvar [my varname stop]
	set stop false
	my WithWorkers $nworkers [list my Work [my varname result]] {
	    after idle [namespace code {set stop true}]
	    vwait $stopvar
	}
	return $result
    }
}
oo::class create Worker {
    superclass WorkerBase
    method schedule {args} {
	set coro [namespace current]::coro
	if {![llength [info commands $coro]]} {
	    coroutine $coro {*}$args
	}
    }
    method Work args {error unimplemented}







    method dump {} {
	info frame [expr {[info frame] - 1}]
    }
}
test oo-22.3 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
    # Triggers a crash with incorrectly restored pmPtr->procPtr->cmdPtr
    WorkerSupport create A {
	superclass Worker
	method Work {var} {
	    after 0 [info coroutine]
	    yield
	    lappend $var [my dump]
	}
    }
    A run 2
} -cleanup {
    catch {rename dump {}}
    catch {A destroy}
} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}}
test oo-22.4 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
    # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr
    WorkerSupport create A {
	superclass Worker
	method Work {var} {
	    after 0 [info coroutine]
	    yield
	    lappend $var [my dump]
	}
    }
    # Copies the methods, changing the declarer
    # Test it works with the source class still around
    oo::copy A B
    B run 2
} -cleanup {
    catch {rename dump {}}
    catch {A destroy}
    catch {B destroy}
} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}}
test oo-22.5 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
    # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr
    WorkerSupport create A {
	superclass Worker
	method Work {var} {
	    after 0 [info coroutine]
	    yield
	    lappend $var [my dump]
	}
    }
    # Copies the methods, changing the declarer
    # Test it works with the source class deleted
    oo::copy A B
    catch {A destroy}
    B run 2
} -cleanup {
    catch {rename dump {}}
    catch {B destroy}
} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}}
test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
    # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr
    WorkerSupport create A {
	superclass Worker
	method Work {var} {
	    after 0 [info coroutine]
	    yield
	    lappend $var [my dump]
	}
    }
    # Copies the methods, changing the declarer
    # Test it works in the original source class with the copy around
    oo::copy A B
    B run 2
    A run 2
} -cleanup {
    catch {rename dump {}}
    catch {A destroy}
    catch {B destroy}
} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}}
WorkerBase destroy

# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
    oo::class create SELF {
	superclass oo::class
	unexport create new
	# Next is just a convenience