1765 lines
51 KiB
C
1765 lines
51 KiB
C
/*
|
||
* tclOOMethod.c --
|
||
*
|
||
* This file contains code to create and manage methods.
|
||
*
|
||
* Copyright (c) 2005-2011 by 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 "tclCompile.h"
|
||
|
||
/*
|
||
* Structure used to help delay computing names of objects or classes for
|
||
* [info frame] until needed, making invokation faster in the normal case.
|
||
*/
|
||
|
||
struct PNI {
|
||
Tcl_Interp *interp; /* Interpreter in which to compute the name of
|
||
* a method. */
|
||
Tcl_Method method; /* Method to compute the name of. */
|
||
};
|
||
|
||
/*
|
||
* 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. */
|
||
Command cmd; /* The command structure. Mostly bogus. */
|
||
ExtraFrameInfo efi; /* Extra information used for [info frame]. */
|
||
Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a
|
||
* recursive call returns. */
|
||
struct PNI pni; /* Specialist information used in the efi
|
||
* field for this type of call. */
|
||
} PMFrameData;
|
||
|
||
/*
|
||
* Structure used to pass information about variable resolution to the
|
||
* on-the-ground resolvers used when working with resolved compiled variables.
|
||
*/
|
||
|
||
typedef struct {
|
||
Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
|
||
* variable can be linked to the namespace
|
||
* variable at the right time. */
|
||
Tcl_Obj *variableObj; /* The name of the variable. */
|
||
Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class
|
||
* variables be cached? */
|
||
} OOResVarInfo;
|
||
|
||
/*
|
||
* Function declarations for things defined in this file.
|
||
*/
|
||
|
||
static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
|
||
Tcl_Obj *const *objv, int toRewrite,
|
||
int rewriteLength, Tcl_Obj *const *rewriteObjs,
|
||
int *lengthPtr);
|
||
static int InvokeProcedureMethod(ClientData clientData,
|
||
Tcl_Interp *interp, Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const *objv);
|
||
static Tcl_NRPostProc FinalizeForwardCall;
|
||
static Tcl_NRPostProc FinalizePMCall;
|
||
static int PushMethodCallFrame(Tcl_Interp *interp,
|
||
CallContext *contextPtr, ProcedureMethod *pmPtr,
|
||
int objc, Tcl_Obj *const *objv,
|
||
PMFrameData *fdPtr);
|
||
static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
|
||
static void DeleteProcedureMethod(ClientData clientData);
|
||
static int CloneProcedureMethod(Tcl_Interp *interp,
|
||
ClientData clientData, ClientData *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 * RenderDeclarerName(ClientData clientData);
|
||
static int InvokeForwardMethod(ClientData clientData,
|
||
Tcl_Interp *interp, Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const *objv);
|
||
static void DeleteForwardMethod(ClientData clientData);
|
||
static int CloneForwardMethod(Tcl_Interp *interp,
|
||
ClientData clientData, ClientData *newClientData);
|
||
static int ProcedureMethodVarResolver(Tcl_Interp *interp,
|
||
const char *varName, Tcl_Namespace *contextNs,
|
||
int flags, Tcl_Var *varPtr);
|
||
static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp,
|
||
const char *varName, int length,
|
||
Tcl_Namespace *contextNs,
|
||
Tcl_ResolvedVarInfo **rPtrPtr);
|
||
|
||
/*
|
||
* The types of methods defined by the core OO system.
|
||
*/
|
||
|
||
static const Tcl_MethodType procMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT, "method",
|
||
InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
|
||
};
|
||
static const Tcl_MethodType fwdMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT, "forward",
|
||
InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
|
||
};
|
||
|
||
/*
|
||
* 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)))
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* Tcl_NewInstanceMethod --
|
||
*
|
||
* Attach a method to an object instance.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Method
|
||
Tcl_NewInstanceMethod(
|
||
Tcl_Interp *interp, /* Unused? */
|
||
Tcl_Object object, /* The object that has the method attached to
|
||
* it. */
|
||
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
|
||
* up to caller to manage storage (e.g., when
|
||
* it is a constructor or destructor). */
|
||
int flags, /* Whether this is a public method. */
|
||
const Tcl_MethodType *typePtr,
|
||
/* The type of method this is, which defines
|
||
* how to invoke, delete and clone the
|
||
* method. */
|
||
ClientData clientData) /* Some data associated with the particular
|
||
* method to be created. */
|
||
{
|
||
Object *oPtr = (Object *) object;
|
||
Method *mPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
int isNew;
|
||
|
||
if (nameObj == NULL) {
|
||
mPtr = ckalloc(sizeof(Method));
|
||
mPtr->namePtr = NULL;
|
||
mPtr->refCount = 1;
|
||
goto populate;
|
||
}
|
||
if (!oPtr->methodsPtr) {
|
||
oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
|
||
Tcl_InitObjHashTable(oPtr->methodsPtr);
|
||
oPtr->flags &= ~USE_CLASS_CACHE;
|
||
}
|
||
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
|
||
if (isNew) {
|
||
mPtr = ckalloc(sizeof(Method));
|
||
mPtr->namePtr = nameObj;
|
||
mPtr->refCount = 1;
|
||
Tcl_IncrRefCount(nameObj);
|
||
Tcl_SetHashValue(hPtr, mPtr);
|
||
} else {
|
||
mPtr = Tcl_GetHashValue(hPtr);
|
||
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
|
||
mPtr->typePtr->deleteProc(mPtr->clientData);
|
||
}
|
||
}
|
||
|
||
populate:
|
||
mPtr->typePtr = typePtr;
|
||
mPtr->clientData = clientData;
|
||
mPtr->flags = 0;
|
||
mPtr->declaringObjectPtr = oPtr;
|
||
mPtr->declaringClassPtr = NULL;
|
||
if (flags) {
|
||
mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
|
||
}
|
||
oPtr->epoch++;
|
||
return (Tcl_Method) mPtr;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* Tcl_NewMethod --
|
||
*
|
||
* Attach a method to a class.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Method
|
||
Tcl_NewMethod(
|
||
Tcl_Interp *interp, /* The interpreter containing the class. */
|
||
Tcl_Class cls, /* The class to attach the method to. */
|
||
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
|
||
* for constructors or destructors); if so, up
|
||
* to caller to manage storage. */
|
||
int flags, /* Whether this is a public method. */
|
||
const Tcl_MethodType *typePtr,
|
||
/* The type of method this is, which defines
|
||
* how to invoke, delete and clone the
|
||
* method. */
|
||
ClientData clientData) /* Some data associated with the particular
|
||
* method to be created. */
|
||
{
|
||
Class *clsPtr = (Class *) cls;
|
||
Method *mPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
int isNew;
|
||
|
||
if (nameObj == NULL) {
|
||
mPtr = ckalloc(sizeof(Method));
|
||
mPtr->namePtr = NULL;
|
||
mPtr->refCount = 1;
|
||
goto populate;
|
||
}
|
||
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
|
||
if (isNew) {
|
||
mPtr = ckalloc(sizeof(Method));
|
||
mPtr->refCount = 1;
|
||
mPtr->namePtr = nameObj;
|
||
Tcl_IncrRefCount(nameObj);
|
||
Tcl_SetHashValue(hPtr, mPtr);
|
||
} else {
|
||
mPtr = Tcl_GetHashValue(hPtr);
|
||
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
|
||
mPtr->typePtr->deleteProc(mPtr->clientData);
|
||
}
|
||
}
|
||
|
||
populate:
|
||
clsPtr->thisPtr->fPtr->epoch++;
|
||
mPtr->typePtr = typePtr;
|
||
mPtr->clientData = clientData;
|
||
mPtr->flags = 0;
|
||
mPtr->declaringObjectPtr = NULL;
|
||
mPtr->declaringClassPtr = clsPtr;
|
||
if (flags) {
|
||
mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
|
||
}
|
||
|
||
return (Tcl_Method) mPtr;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOODelMethodRef --
|
||
*
|
||
* How to delete a method.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclOODelMethodRef(
|
||
Method *mPtr)
|
||
{
|
||
if ((mPtr != NULL) && (mPtr->refCount-- <= 1)) {
|
||
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
|
||
mPtr->typePtr->deleteProc(mPtr->clientData);
|
||
}
|
||
if (mPtr->namePtr != NULL) {
|
||
Tcl_DecrRefCount(mPtr->namePtr);
|
||
}
|
||
|
||
ckfree(mPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOONewBasicMethod --
|
||
*
|
||
* Helper that makes it cleaner to create very simple methods during
|
||
* basic system initialization. Not suitable for general use.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclOONewBasicMethod(
|
||
Tcl_Interp *interp,
|
||
Class *clsPtr, /* Class to attach the method to. */
|
||
const DeclaredClassMethod *dcm)
|
||
/* Name of the method, whether it is public,
|
||
* and the function to implement it. */
|
||
{
|
||
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
|
||
|
||
Tcl_IncrRefCount(namePtr);
|
||
Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
|
||
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
|
||
Tcl_DecrRefCount(namePtr);
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOONewProcInstanceMethod --
|
||
*
|
||
* Create a new procedure-like method for an object.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Method *
|
||
TclOONewProcInstanceMethod(
|
||
Tcl_Interp *interp, /* The interpreter containing the object. */
|
||
Object *oPtr, /* The object to modify. */
|
||
int flags, /* Whether this is a public method. */
|
||
Tcl_Obj *nameObj, /* The name of the method, which must not be
|
||
* NULL. */
|
||
Tcl_Obj *argsObj, /* The formal argument list for the method,
|
||
* which must not be NULL. */
|
||
Tcl_Obj *bodyObj, /* The body of the method, which must not be
|
||
* NULL. */
|
||
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
|
||
* structure to allow for deeper tuning of the
|
||
* structure's contents. NULL if caller is not
|
||
* interested. */
|
||
{
|
||
int argsLen;
|
||
ProcedureMethod *pmPtr;
|
||
Tcl_Method method;
|
||
|
||
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
|
||
return NULL;
|
||
}
|
||
pmPtr = ckalloc(sizeof(ProcedureMethod));
|
||
memset(pmPtr, 0, sizeof(ProcedureMethod));
|
||
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
|
||
pmPtr->flags = flags & USE_DECLARER_NS;
|
||
pmPtr->refCount = 1;
|
||
|
||
method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
|
||
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
|
||
if (method == NULL) {
|
||
ckfree(pmPtr);
|
||
} else if (pmPtrPtr != NULL) {
|
||
*pmPtrPtr = pmPtr;
|
||
}
|
||
return (Method *) method;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOONewProcMethod --
|
||
*
|
||
* Create a new procedure-like method for a class.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Method *
|
||
TclOONewProcMethod(
|
||
Tcl_Interp *interp, /* The interpreter containing the class. */
|
||
Class *clsPtr, /* The class to modify. */
|
||
int flags, /* Whether this is a public method. */
|
||
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
|
||
* if so, up to caller to manage storage
|
||
* (e.g., because it is a constructor or
|
||
* destructor). */
|
||
Tcl_Obj *argsObj, /* The formal argument list for the method,
|
||
* which may be NULL; if so, it is equivalent
|
||
* to an empty list. */
|
||
Tcl_Obj *bodyObj, /* The body of the method, which must not be
|
||
* NULL. */
|
||
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
|
||
* structure to allow for deeper tuning of the
|
||
* structure's contents. NULL if caller is not
|
||
* interested. */
|
||
{
|
||
int argsLen; /* -1 => delete argsObj before exit */
|
||
ProcedureMethod *pmPtr;
|
||
const char *procName;
|
||
Tcl_Method method;
|
||
|
||
if (argsObj == NULL) {
|
||
argsLen = -1;
|
||
argsObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(argsObj);
|
||
procName = "<destructor>";
|
||
} else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
|
||
return NULL;
|
||
} else {
|
||
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
|
||
}
|
||
|
||
pmPtr = ckalloc(sizeof(ProcedureMethod));
|
||
memset(pmPtr, 0, sizeof(ProcedureMethod));
|
||
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
|
||
pmPtr->flags = flags & USE_DECLARER_NS;
|
||
pmPtr->refCount = 1;
|
||
|
||
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
|
||
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
|
||
|
||
if (argsLen == -1) {
|
||
Tcl_DecrRefCount(argsObj);
|
||
}
|
||
if (method == NULL) {
|
||
ckfree(pmPtr);
|
||
} else if (pmPtrPtr != NULL) {
|
||
*pmPtrPtr = pmPtr;
|
||
}
|
||
|
||
return (Method *) method;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOOMakeProcInstanceMethod --
|
||
*
|
||
* The guts of the code to make a procedure-like method for an object.
|
||
* Split apart so that it is easier for other extensions to reuse (in
|
||
* particular, it frees them from having to pry so deeply into Tcl's
|
||
* guts).
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Method
|
||
TclOOMakeProcInstanceMethod(
|
||
Tcl_Interp *interp, /* The interpreter containing the object. */
|
||
Object *oPtr, /* The object to modify. */
|
||
int flags, /* Whether this is a public method. */
|
||
Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
|
||
* NULL. */
|
||
Tcl_Obj *argsObj, /* The formal argument list for the method,
|
||
* which _must not_ be NULL. */
|
||
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
|
||
* NULL. */
|
||
const Tcl_MethodType *typePtr,
|
||
/* The type of the method to create. */
|
||
ClientData clientData, /* The per-method type-specific data. */
|
||
Proc **procPtrPtr) /* A pointer to the variable in which to write
|
||
* the procedure record reference. Presumably
|
||
* inside the structure indicated by the
|
||
* pointer in clientData. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Proc *procPtr;
|
||
|
||
if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
|
||
procPtrPtr) != TCL_OK) {
|
||
return NULL;
|
||
}
|
||
procPtr = *procPtrPtr;
|
||
procPtr->cmdPtr = NULL;
|
||
|
||
if (iPtr->cmdFramePtr) {
|
||
CmdFrame context = *iPtr->cmdFramePtr;
|
||
|
||
if (context.type == TCL_LOCATION_BC) {
|
||
/*
|
||
* Retrieve source information from the bytecode, if possible. If
|
||
* the information is retrieved successfully, context.type will be
|
||
* TCL_LOCATION_SOURCE and the reference held by
|
||
* context.data.eval.path will be counted.
|
||
*/
|
||
|
||
TclGetSrcInfoForPc(&context);
|
||
} else if (context.type == TCL_LOCATION_SOURCE) {
|
||
/*
|
||
* The copy into 'context' up above has created another reference
|
||
* to 'context.data.eval.path'; account for it.
|
||
*/
|
||
|
||
Tcl_IncrRefCount(context.data.eval.path);
|
||
}
|
||
|
||
if (context.type == TCL_LOCATION_SOURCE) {
|
||
/*
|
||
* We can account for source location within a proc only if the
|
||
* proc body was not created by substitution.
|
||
* (FIXME: check that this is sane and correct!)
|
||
*/
|
||
|
||
if (context.line
|
||
&& (context.nline >= 4) && (context.line[3] >= 0)) {
|
||
int isNew;
|
||
CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
cfPtr->level = -1;
|
||
cfPtr->type = context.type;
|
||
cfPtr->line = ckalloc(sizeof(int));
|
||
cfPtr->line[0] = context.line[3];
|
||
cfPtr->nline = 1;
|
||
cfPtr->framePtr = NULL;
|
||
cfPtr->nextPtr = NULL;
|
||
|
||
cfPtr->data.eval.path = context.data.eval.path;
|
||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||
|
||
cfPtr->cmd = NULL;
|
||
cfPtr->len = 0;
|
||
|
||
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
|
||
(char *) procPtr, &isNew);
|
||
Tcl_SetHashValue(hPtr, cfPtr);
|
||
}
|
||
|
||
/*
|
||
* 'context' is going out of scope; account for the reference that
|
||
* it's holding to the path name.
|
||
*/
|
||
|
||
Tcl_DecrRefCount(context.data.eval.path);
|
||
context.data.eval.path = NULL;
|
||
}
|
||
}
|
||
|
||
return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
|
||
typePtr, clientData);
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOOMakeProcMethod --
|
||
*
|
||
* The guts of the code to make a procedure-like method for a class.
|
||
* Split apart so that it is easier for other extensions to reuse (in
|
||
* particular, it frees them from having to pry so deeply into Tcl's
|
||
* guts).
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Method
|
||
TclOOMakeProcMethod(
|
||
Tcl_Interp *interp, /* The interpreter containing the class. */
|
||
Class *clsPtr, /* The class to modify. */
|
||
int flags, /* Whether this is a public method. */
|
||
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
|
||
* if so, up to caller to manage storage
|
||
* (e.g., because it is a constructor or
|
||
* destructor). */
|
||
const char *namePtr, /* The name of the method as a string, which
|
||
* _must not_ be NULL. */
|
||
Tcl_Obj *argsObj, /* The formal argument list for the method,
|
||
* which _must not_ be NULL. */
|
||
Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
|
||
* NULL. */
|
||
const Tcl_MethodType *typePtr,
|
||
/* The type of the method to create. */
|
||
ClientData clientData, /* The per-method type-specific data. */
|
||
Proc **procPtrPtr) /* A pointer to the variable in which to write
|
||
* the procedure record reference. Presumably
|
||
* inside the structure indicated by the
|
||
* pointer in clientData. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Proc *procPtr;
|
||
|
||
if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
|
||
procPtrPtr) != TCL_OK) {
|
||
return NULL;
|
||
}
|
||
procPtr = *procPtrPtr;
|
||
procPtr->cmdPtr = NULL;
|
||
|
||
if (iPtr->cmdFramePtr) {
|
||
CmdFrame context = *iPtr->cmdFramePtr;
|
||
|
||
if (context.type == TCL_LOCATION_BC) {
|
||
/*
|
||
* Retrieve source information from the bytecode, if possible. If
|
||
* the information is retrieved successfully, context.type will be
|
||
* TCL_LOCATION_SOURCE and the reference held by
|
||
* context.data.eval.path will be counted.
|
||
*/
|
||
|
||
TclGetSrcInfoForPc(&context);
|
||
} else if (context.type == TCL_LOCATION_SOURCE) {
|
||
/*
|
||
* The copy into 'context' up above has created another reference
|
||
* to 'context.data.eval.path'; account for it.
|
||
*/
|
||
|
||
Tcl_IncrRefCount(context.data.eval.path);
|
||
}
|
||
|
||
if (context.type == TCL_LOCATION_SOURCE) {
|
||
/*
|
||
* We can account for source location within a proc only if the
|
||
* proc body was not created by substitution.
|
||
* (FIXME: check that this is sane and correct!)
|
||
*/
|
||
|
||
if (context.line
|
||
&& (context.nline >= 4) && (context.line[3] >= 0)) {
|
||
int isNew;
|
||
CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
cfPtr->level = -1;
|
||
cfPtr->type = context.type;
|
||
cfPtr->line = ckalloc(sizeof(int));
|
||
cfPtr->line[0] = context.line[3];
|
||
cfPtr->nline = 1;
|
||
cfPtr->framePtr = NULL;
|
||
cfPtr->nextPtr = NULL;
|
||
|
||
cfPtr->data.eval.path = context.data.eval.path;
|
||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||
|
||
cfPtr->cmd = NULL;
|
||
cfPtr->len = 0;
|
||
|
||
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
|
||
(char *) procPtr, &isNew);
|
||
Tcl_SetHashValue(hPtr, cfPtr);
|
||
}
|
||
|
||
/*
|
||
* 'context' is going out of scope; account for the reference that
|
||
* it's holding to the path name.
|
||
*/
|
||
|
||
Tcl_DecrRefCount(context.data.eval.path);
|
||
context.data.eval.path = NULL;
|
||
}
|
||
}
|
||
|
||
return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
|
||
clientData);
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* InvokeProcedureMethod, PushMethodCallFrame --
|
||
*
|
||
* How to invoke a procedure-like method.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
InvokeProcedureMethod(
|
||
ClientData 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 = clientData;
|
||
int result;
|
||
PMFrameData *fdPtr; /* Important data that has to have a lifetime
|
||
* matched by this function (or rather, by the
|
||
* call frame's lifetime). */
|
||
|
||
/*
|
||
* If the object namespace (or interpreter) were deleted, we just skip to
|
||
* the next thing in the chain.
|
||
*/
|
||
|
||
if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) ||
|
||
Tcl_InterpDeleted(interp)
|
||
) {
|
||
return TclNRObjectContextInvokeNext(interp, context, objc, objv,
|
||
Tcl_ObjectContextSkippedArgs(context));
|
||
}
|
||
|
||
/*
|
||
* Allocate the special frame data.
|
||
*/
|
||
|
||
fdPtr = TclStackAlloc(interp, sizeof(PMFrameData));
|
||
|
||
/*
|
||
* Create a call frame for this method.
|
||
*/
|
||
|
||
result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
|
||
objc, objv, fdPtr);
|
||
if (result != TCL_OK) {
|
||
TclStackFree(interp, fdPtr);
|
||
return result;
|
||
}
|
||
pmPtr->refCount++;
|
||
|
||
/*
|
||
* Give the pre-call callback a chance to do some setup and, possibly,
|
||
* veto the call.
|
||
*/
|
||
|
||
if (pmPtr->preCallProc != NULL) {
|
||
int isFinished;
|
||
|
||
result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
|
||
(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
|
||
if (isFinished || result != TCL_OK) {
|
||
/*
|
||
* Restore the old cmdPtr so that a subsequent use of [info frame]
|
||
* won't crash on us. [Bug 3001438]
|
||
*/
|
||
|
||
pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
|
||
|
||
Tcl_PopCallFrame(interp);
|
||
TclStackFree(interp, fdPtr->framePtr);
|
||
if (pmPtr->refCount-- <= 1) {
|
||
DeleteProcedureMethodRecord(pmPtr);
|
||
}
|
||
TclStackFree(interp, fdPtr);
|
||
return result;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Now invoke the body of the method.
|
||
*/
|
||
|
||
TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
|
||
return TclNRInterpProcCore(interp, fdPtr->nameObj,
|
||
Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
|
||
}
|
||
|
||
static int
|
||
FinalizePMCall(
|
||
ClientData data[],
|
||
Tcl_Interp *interp,
|
||
int result)
|
||
{
|
||
ProcedureMethod *pmPtr = data[0];
|
||
Tcl_ObjectContext context = data[1];
|
||
PMFrameData *fdPtr = data[2];
|
||
|
||
/*
|
||
* Give the post-call callback a chance to do some cleanup. Note that at
|
||
* this point the call frame itself is invalid; it's already been popped.
|
||
*/
|
||
|
||
if (pmPtr->postCallProc) {
|
||
result = pmPtr->postCallProc(pmPtr->clientData, interp, context,
|
||
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),
|
||
result);
|
||
}
|
||
|
||
/*
|
||
* Restore the old cmdPtr so that a subsequent use of [info frame] won't
|
||
* crash on us. [Bug 3001438]
|
||
*/
|
||
|
||
pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
|
||
|
||
/*
|
||
* 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) {
|
||
DeleteProcedureMethodRecord(pmPtr);
|
||
}
|
||
TclStackFree(interp, fdPtr);
|
||
return result;
|
||
}
|
||
|
||
static int
|
||
PushMethodCallFrame(
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
CallContext *contextPtr, /* Current method call context. */
|
||
ProcedureMethod *pmPtr, /* Information about this procedure-like
|
||
* method. */
|
||
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;
|
||
const char *namePtr;
|
||
CallFrame **framePtrPtr = &fdPtr->framePtr;
|
||
|
||
/*
|
||
* Compute basic information on the basis of the type of method it is.
|
||
*/
|
||
|
||
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
|
||
namePtr = "<constructor>";
|
||
fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
|
||
fdPtr->errProc = ConstructorErrorHandler;
|
||
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
|
||
namePtr = "<destructor>";
|
||
fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName;
|
||
fdPtr->errProc = DestructorErrorHandler;
|
||
} else {
|
||
fdPtr->nameObj = Tcl_MethodName(
|
||
Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));
|
||
namePtr = TclGetString(fdPtr->nameObj);
|
||
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;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Save the old cmdPtr so that when this recursive call returns, we can
|
||
* restore it. To do otherwise causes crashes in [info frame] after we
|
||
* return from a recursive call. [Bug 3001438]
|
||
*/
|
||
|
||
fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr;
|
||
|
||
/*
|
||
* Compile the body. This operation may fail.
|
||
*/
|
||
|
||
fdPtr->efi.length = 2;
|
||
memset(&fdPtr->cmd, 0, sizeof(Command));
|
||
fdPtr->cmd.nsPtr = nsPtr;
|
||
fdPtr->cmd.clientData = &fdPtr->efi;
|
||
pmPtr->procPtr->cmdPtr = &fdPtr->cmd;
|
||
|
||
/*
|
||
* [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...
|
||
*/
|
||
|
||
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", namePtr);
|
||
if (result != TCL_OK) {
|
||
goto failureReturn;
|
||
}
|
||
|
||
/*
|
||
* Make the stack frame and fill it out with information about this call.
|
||
* This operation may 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;
|
||
|
||
/*
|
||
* Finish filling out the extra frame info so that [info frame] works.
|
||
*/
|
||
|
||
fdPtr->efi.fields[0].name = "method";
|
||
fdPtr->efi.fields[0].proc = NULL;
|
||
fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
|
||
if (pmPtr->gfivProc != NULL) {
|
||
fdPtr->efi.fields[1].name = "";
|
||
fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
|
||
fdPtr->efi.fields[1].clientData = pmPtr;
|
||
} else {
|
||
Tcl_Method method =
|
||
Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
|
||
|
||
if (Tcl_MethodDeclarerObject(method) != NULL) {
|
||
fdPtr->efi.fields[1].name = "object";
|
||
} else {
|
||
fdPtr->efi.fields[1].name = "class";
|
||
}
|
||
fdPtr->efi.fields[1].proc = RenderDeclarerName;
|
||
fdPtr->efi.fields[1].clientData = &fdPtr->pni;
|
||
fdPtr->pni.interp = interp;
|
||
fdPtr->pni.method = method;
|
||
}
|
||
|
||
return TCL_OK;
|
||
|
||
/*
|
||
* Restore the old cmdPtr so that a subsequent use of [info frame] won't
|
||
* crash on us. [Bug 3001438]
|
||
*/
|
||
|
||
failureReturn:
|
||
pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOOSetupVariableResolver, etc. --
|
||
*
|
||
* Variable resolution engine used to connect declared variables to local
|
||
* variables used in methods. The compiled variable resolver is more
|
||
* important, but both are needed as it is possible to have a variable
|
||
* that is only referred to in ways that aren't compilable and we can't
|
||
* force LVT presence. [TIP #320]
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclOOSetupVariableResolver(
|
||
Tcl_Namespace *nsPtr)
|
||
{
|
||
Tcl_ResolverInfo info;
|
||
|
||
Tcl_GetNamespaceResolvers(nsPtr, &info);
|
||
if (info.compiledVarResProc == NULL) {
|
||
Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver,
|
||
ProcedureMethodCompiledVarResolver);
|
||
}
|
||
}
|
||
|
||
static int
|
||
ProcedureMethodVarResolver(
|
||
Tcl_Interp *interp,
|
||
const char *varName,
|
||
Tcl_Namespace *contextNs,
|
||
int flags,
|
||
Tcl_Var *varPtr)
|
||
{
|
||
int result;
|
||
Tcl_ResolvedVarInfo *rPtr = NULL;
|
||
|
||
result = ProcedureMethodCompiledVarResolver(interp, varName,
|
||
strlen(varName), contextNs, &rPtr);
|
||
|
||
if (result != TCL_OK) {
|
||
return result;
|
||
}
|
||
|
||
*varPtr = rPtr->fetchProc(interp, rPtr);
|
||
|
||
/*
|
||
* Must not retain reference to resolved information. [Bug 3105999]
|
||
*/
|
||
|
||
rPtr->deleteProc(rPtr);
|
||
return (*varPtr ? TCL_OK : TCL_CONTINUE);
|
||
}
|
||
|
||
static Tcl_Var
|
||
ProcedureMethodCompiledVarConnect(
|
||
Tcl_Interp *interp,
|
||
Tcl_ResolvedVarInfo *rPtr)
|
||
{
|
||
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
|
||
Interp *iPtr = (Interp *) interp;
|
||
CallFrame *framePtr = iPtr->varFramePtr;
|
||
CallContext *contextPtr;
|
||
Tcl_Obj *variableObj;
|
||
Tcl_HashEntry *hPtr;
|
||
int i, isNew, cacheIt, varLen, len;
|
||
const char *match, *varName;
|
||
|
||
/*
|
||
* Check that the variable is being requested in a context that is also a
|
||
* method call; if not (i.e. we're evaluating in the object's namespace or
|
||
* in a procedure of that namespace) then we do nothing.
|
||
*/
|
||
|
||
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
|
||
return NULL;
|
||
}
|
||
contextPtr = framePtr->clientData;
|
||
|
||
/*
|
||
* If we've done the work before (in a comparable context) then reuse that
|
||
* rather than performing resolution ourselves.
|
||
*/
|
||
|
||
if (infoPtr->cachedObjectVar) {
|
||
return infoPtr->cachedObjectVar;
|
||
}
|
||
|
||
/*
|
||
* Check if the variable is one we want to resolve at all (i.e. whether it
|
||
* is in the list provided by the user). If not, we mustn't do anything
|
||
* either.
|
||
*/
|
||
|
||
varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
|
||
if (contextPtr->callPtr->chain[contextPtr->index]
|
||
.mPtr->declaringClassPtr != NULL) {
|
||
FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
|
||
.mPtr->declaringClassPtr->variables) {
|
||
match = TclGetStringFromObj(variableObj, &len);
|
||
if ((len == varLen) && !memcmp(match, varName, len)) {
|
||
cacheIt = 0;
|
||
goto gotMatch;
|
||
}
|
||
}
|
||
} else {
|
||
FOREACH(variableObj, contextPtr->oPtr->variables) {
|
||
match = TclGetStringFromObj(variableObj, &len);
|
||
if ((len == varLen) && !memcmp(match, varName, len)) {
|
||
cacheIt = 1;
|
||
goto gotMatch;
|
||
}
|
||
}
|
||
}
|
||
return NULL;
|
||
|
||
/*
|
||
* It is a variable we want to resolve, so resolve it.
|
||
*/
|
||
|
||
gotMatch:
|
||
hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
|
||
(char *) variableObj, &isNew);
|
||
if (isNew) {
|
||
TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
|
||
}
|
||
if (cacheIt) {
|
||
infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr);
|
||
|
||
/*
|
||
* We must keep a reference to the variable so everything will
|
||
* continue to work correctly even if it is unset; being unset does
|
||
* not end the life of the variable at this level. [Bug 3185009]
|
||
*/
|
||
|
||
VarHashRefCount(infoPtr->cachedObjectVar)++;
|
||
}
|
||
return TclVarHashGetValue(hPtr);
|
||
}
|
||
|
||
static void
|
||
ProcedureMethodCompiledVarDelete(
|
||
Tcl_ResolvedVarInfo *rPtr)
|
||
{
|
||
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
|
||
|
||
/*
|
||
* Release the reference to the variable if we were holding it.
|
||
*/
|
||
|
||
if (infoPtr->cachedObjectVar) {
|
||
VarHashRefCount(infoPtr->cachedObjectVar)--;
|
||
TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
|
||
}
|
||
Tcl_DecrRefCount(infoPtr->variableObj);
|
||
ckfree(infoPtr);
|
||
}
|
||
|
||
static int
|
||
ProcedureMethodCompiledVarResolver(
|
||
Tcl_Interp *interp,
|
||
const char *varName,
|
||
int length,
|
||
Tcl_Namespace *contextNs,
|
||
Tcl_ResolvedVarInfo **rPtrPtr)
|
||
{
|
||
OOResVarInfo *infoPtr;
|
||
Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
|
||
|
||
/*
|
||
* Do not create resolvers for cases that contain namespace separators or
|
||
* which look like array accesses. Both will lead us astray.
|
||
*/
|
||
|
||
if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
|
||
Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
|
||
Tcl_DecrRefCount(variableObj);
|
||
return TCL_CONTINUE;
|
||
}
|
||
|
||
infoPtr = ckalloc(sizeof(OOResVarInfo));
|
||
infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
|
||
infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
|
||
infoPtr->cachedObjectVar = NULL;
|
||
infoPtr->variableObj = variableObj;
|
||
Tcl_IncrRefCount(variableObj);
|
||
*rPtrPtr = &infoPtr->info;
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
ClientData clientData)
|
||
{
|
||
struct PNI *pni = clientData;
|
||
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
|
||
|
||
if (object == NULL) {
|
||
object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
|
||
}
|
||
return TclOOObjectName(pni->interp, (Object *) object);
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler --
|
||
*
|
||
* How to fill in the stack trace correctly upon error in various forms
|
||
* of procedure-like methods. LIMIT is how long the inserted strings in
|
||
* the error traces should get before being converted to have ellipses,
|
||
* and ELLIPSIFY is a macro to do the conversion (with the help of a
|
||
* %.*s%s format field). Note that ELLIPSIFY is only safe for use in
|
||
* suitable formatting contexts.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
#define LIMIT 60
|
||
#define ELLIPSIFY(str,len) \
|
||
((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
|
||
|
||
static void
|
||
MethodErrorHandler(
|
||
Tcl_Interp *interp,
|
||
Tcl_Obj *methodNameObj)
|
||
{
|
||
int nameLen, objectNameLen;
|
||
CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
|
||
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
|
||
const char *objectName, *kindName, *methodName =
|
||
Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
|
||
Object *declarerPtr;
|
||
|
||
if (mPtr->declaringObjectPtr != NULL) {
|
||
declarerPtr = mPtr->declaringObjectPtr;
|
||
kindName = "object";
|
||
} else {
|
||
if (mPtr->declaringClassPtr == NULL) {
|
||
Tcl_Panic("method not declared in class or object");
|
||
}
|
||
declarerPtr = mPtr->declaringClassPtr->thisPtr;
|
||
kindName = "class";
|
||
}
|
||
|
||
objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
|
||
&objectNameLen);
|
||
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
||
"\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
|
||
kindName, ELLIPSIFY(objectName, objectNameLen),
|
||
ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
|
||
}
|
||
|
||
static void
|
||
ConstructorErrorHandler(
|
||
Tcl_Interp *interp,
|
||
Tcl_Obj *methodNameObj)
|
||
{
|
||
CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
|
||
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
|
||
Object *declarerPtr;
|
||
const char *objectName, *kindName;
|
||
int objectNameLen;
|
||
|
||
if (mPtr->declaringObjectPtr != NULL) {
|
||
declarerPtr = mPtr->declaringObjectPtr;
|
||
kindName = "object";
|
||
} else {
|
||
if (mPtr->declaringClassPtr == NULL) {
|
||
Tcl_Panic("method not declared in class or object");
|
||
}
|
||
declarerPtr = mPtr->declaringClassPtr->thisPtr;
|
||
kindName = "class";
|
||
}
|
||
|
||
objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
|
||
&objectNameLen);
|
||
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
||
"\n (%s \"%.*s%s\" constructor line %d)", kindName,
|
||
ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
|
||
}
|
||
|
||
static void
|
||
DestructorErrorHandler(
|
||
Tcl_Interp *interp,
|
||
Tcl_Obj *methodNameObj)
|
||
{
|
||
CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
|
||
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
|
||
Object *declarerPtr;
|
||
const char *objectName, *kindName;
|
||
int objectNameLen;
|
||
|
||
if (mPtr->declaringObjectPtr != NULL) {
|
||
declarerPtr = mPtr->declaringObjectPtr;
|
||
kindName = "object";
|
||
} else {
|
||
if (mPtr->declaringClassPtr == NULL) {
|
||
Tcl_Panic("method not declared in class or object");
|
||
}
|
||
declarerPtr = mPtr->declaringClassPtr->thisPtr;
|
||
kindName = "class";
|
||
}
|
||
|
||
objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
|
||
&objectNameLen);
|
||
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
||
"\n (%s \"%.*s%s\" destructor line %d)", kindName,
|
||
ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* DeleteProcedureMethod, CloneProcedureMethod --
|
||
*
|
||
* How to delete and clone procedure-like methods.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
DeleteProcedureMethodRecord(
|
||
ProcedureMethod *pmPtr)
|
||
{
|
||
TclProcDeleteProc(pmPtr->procPtr);
|
||
if (pmPtr->deleteClientdataProc) {
|
||
pmPtr->deleteClientdataProc(pmPtr->clientData);
|
||
}
|
||
ckfree(pmPtr);
|
||
}
|
||
|
||
static void
|
||
DeleteProcedureMethod(
|
||
ClientData clientData)
|
||
{
|
||
ProcedureMethod *pmPtr = clientData;
|
||
|
||
if (pmPtr->refCount-- <= 1) {
|
||
DeleteProcedureMethodRecord(pmPtr);
|
||
}
|
||
}
|
||
|
||
static int
|
||
CloneProcedureMethod(
|
||
Tcl_Interp *interp,
|
||
ClientData clientData,
|
||
ClientData *newClientData)
|
||
{
|
||
ProcedureMethod *pmPtr = clientData;
|
||
ProcedureMethod *pm2Ptr;
|
||
Tcl_Obj *bodyObj, *argsObj;
|
||
CompiledLocal *localPtr;
|
||
|
||
/*
|
||
* Copy the argument list.
|
||
*/
|
||
|
||
argsObj = Tcl_NewObj();
|
||
for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
|
||
localPtr=localPtr->nextPtr) {
|
||
if (TclIsVarArgument(localPtr)) {
|
||
Tcl_Obj *argObj = Tcl_NewObj();
|
||
|
||
Tcl_ListObjAppendElement(NULL, argObj,
|
||
Tcl_NewStringObj(localPtr->name, -1));
|
||
if (localPtr->defValuePtr != NULL) {
|
||
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, argsObj, argObj);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Must strip the internal representation in order to ensure that any
|
||
* bound references to instance variables are removed. [Bug 3609693]
|
||
*/
|
||
|
||
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
|
||
Tcl_GetString(bodyObj);
|
||
TclFreeIntRep(bodyObj);
|
||
|
||
/*
|
||
* Create the actual copy of the method record, manufacturing a new proc
|
||
* record.
|
||
*/
|
||
|
||
pm2Ptr = ckalloc(sizeof(ProcedureMethod));
|
||
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
|
||
pm2Ptr->refCount = 1;
|
||
Tcl_IncrRefCount(argsObj);
|
||
Tcl_IncrRefCount(bodyObj);
|
||
if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
|
||
&pm2Ptr->procPtr) != TCL_OK) {
|
||
Tcl_DecrRefCount(argsObj);
|
||
Tcl_DecrRefCount(bodyObj);
|
||
ckfree(pm2Ptr);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_DecrRefCount(argsObj);
|
||
Tcl_DecrRefCount(bodyObj);
|
||
|
||
if (pmPtr->cloneClientdataProc) {
|
||
pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
|
||
}
|
||
*newClientData = pm2Ptr;
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOONewForwardInstanceMethod --
|
||
*
|
||
* Create a forwarded method for an object.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Method *
|
||
TclOONewForwardInstanceMethod(
|
||
Tcl_Interp *interp, /* Interpreter for error reporting. */
|
||
Object *oPtr, /* The object to attach the method to. */
|
||
int flags, /* Whether the method is public or not. */
|
||
Tcl_Obj *nameObj, /* The name of the method. */
|
||
Tcl_Obj *prefixObj) /* List of arguments that form the command
|
||
* prefix to forward to. */
|
||
{
|
||
int prefixLen;
|
||
ForwardMethod *fmPtr;
|
||
|
||
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
|
||
return NULL;
|
||
}
|
||
if (prefixLen < 1) {
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
||
"method forward prefix must be non-empty", -1));
|
||
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
|
||
return NULL;
|
||
}
|
||
|
||
fmPtr = ckalloc(sizeof(ForwardMethod));
|
||
fmPtr->prefixObj = prefixObj;
|
||
Tcl_IncrRefCount(prefixObj);
|
||
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
|
||
nameObj, flags, &fwdMethodType, fmPtr);
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOONewForwardMethod --
|
||
*
|
||
* Create a new forwarded method for a class.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Method *
|
||
TclOONewForwardMethod(
|
||
Tcl_Interp *interp, /* Interpreter for error reporting. */
|
||
Class *clsPtr, /* The class to attach the method to. */
|
||
int flags, /* Whether the method is public or not. */
|
||
Tcl_Obj *nameObj, /* The name of the method. */
|
||
Tcl_Obj *prefixObj) /* List of arguments that form the command
|
||
* prefix to forward to. */
|
||
{
|
||
int prefixLen;
|
||
ForwardMethod *fmPtr;
|
||
|
||
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
|
||
return NULL;
|
||
}
|
||
if (prefixLen < 1) {
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
||
"method forward prefix must be non-empty", -1));
|
||
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
|
||
return NULL;
|
||
}
|
||
|
||
fmPtr = ckalloc(sizeof(ForwardMethod));
|
||
fmPtr->prefixObj = prefixObj;
|
||
Tcl_IncrRefCount(prefixObj);
|
||
return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
|
||
flags, &fwdMethodType, fmPtr);
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* InvokeForwardMethod --
|
||
*
|
||
* How to invoke a forwarded method. Works by doing some ensemble-like
|
||
* command rearranging and then invokes some other Tcl command.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
InvokeForwardMethod(
|
||
ClientData 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. */
|
||
{
|
||
CallContext *contextPtr = (CallContext *) context;
|
||
ForwardMethod *fmPtr = clientData;
|
||
Tcl_Obj **argObjs, **prefixObjs;
|
||
int numPrefixes, len, skip = contextPtr->skip;
|
||
|
||
/*
|
||
* Build the real list of arguments to use. Note that we know that the
|
||
* prefixObj field of the ForwardMethod structure holds a reference to a
|
||
* non-empty list, so there's a whole class of failures ("not a list") we
|
||
* can ignore here.
|
||
*/
|
||
|
||
Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
|
||
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
|
||
numPrefixes, prefixObjs, &len);
|
||
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
|
||
/*
|
||
* NOTE: The combination of direct set of iPtr->lookupNsPtr and the use
|
||
* of the TCL_EVAL_NOERR flag results in an evaluation configuration
|
||
* very much like TCL_EVAL_INVOKE.
|
||
*/
|
||
((Interp *)interp)->lookupNsPtr
|
||
= (Namespace *) contextPtr->oPtr->namespacePtr;
|
||
return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
|
||
}
|
||
|
||
static int
|
||
FinalizeForwardCall(
|
||
ClientData data[],
|
||
Tcl_Interp *interp,
|
||
int result)
|
||
{
|
||
Tcl_Obj **argObjs = data[0];
|
||
|
||
TclStackFree(interp, argObjs);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* DeleteForwardMethod, CloneForwardMethod --
|
||
*
|
||
* How to delete and clone forwarded methods.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
DeleteForwardMethod(
|
||
ClientData clientData)
|
||
{
|
||
ForwardMethod *fmPtr = clientData;
|
||
|
||
Tcl_DecrRefCount(fmPtr->prefixObj);
|
||
ckfree(fmPtr);
|
||
}
|
||
|
||
static int
|
||
CloneForwardMethod(
|
||
Tcl_Interp *interp,
|
||
ClientData clientData,
|
||
ClientData *newClientData)
|
||
{
|
||
ForwardMethod *fmPtr = clientData;
|
||
ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
|
||
|
||
fm2Ptr->prefixObj = fmPtr->prefixObj;
|
||
Tcl_IncrRefCount(fm2Ptr->prefixObj);
|
||
*newClientData = fm2Ptr;
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
|
||
*
|
||
* Utility functions used for procedure-like and forwarding method
|
||
* introspection.
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Proc *
|
||
TclOOGetProcFromMethod(
|
||
Method *mPtr)
|
||
{
|
||
if (mPtr->typePtr == &procMethodType) {
|
||
ProcedureMethod *pmPtr = mPtr->clientData;
|
||
|
||
return pmPtr->procPtr;
|
||
}
|
||
return NULL;
|
||
}
|
||
|
||
Tcl_Obj *
|
||
TclOOGetMethodBody(
|
||
Method *mPtr)
|
||
{
|
||
if (mPtr->typePtr == &procMethodType) {
|
||
ProcedureMethod *pmPtr = mPtr->clientData;
|
||
|
||
if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
|
||
(void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
|
||
}
|
||
return pmPtr->procPtr->bodyPtr;
|
||
}
|
||
return NULL;
|
||
}
|
||
|
||
Tcl_Obj *
|
||
TclOOGetFwdFromMethod(
|
||
Method *mPtr)
|
||
{
|
||
if (mPtr->typePtr == &fwdMethodType) {
|
||
ForwardMethod *fwPtr = mPtr->clientData;
|
||
|
||
return fwPtr->prefixObj;
|
||
}
|
||
return NULL;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* InitEnsembleRewrite --
|
||
*
|
||
* Utility function that wraps up a lot of the complexity involved in
|
||
* doing ensemble-like command forwarding. Here is a picture of memory
|
||
* management plan:
|
||
*
|
||
* <-----------------objc---------------------->
|
||
* objv: |=============|===============================|
|
||
* <-toRewrite-> |
|
||
* \
|
||
* <-rewriteLength-> \
|
||
* rewriteObjs: |=================| \
|
||
* | |
|
||
* V V
|
||
* argObjs: |=================|===============================|
|
||
* <------------------*lengthPtr------------------->
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
static Tcl_Obj **
|
||
InitEnsembleRewrite(
|
||
Tcl_Interp *interp, /* Place to log the rewrite info. */
|
||
int objc, /* Number of real arguments. */
|
||
Tcl_Obj *const *objv, /* The real arguments. */
|
||
int toRewrite, /* Number of real arguments to replace. */
|
||
int rewriteLength, /* Number of arguments to insert instead. */
|
||
Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
|
||
int *lengthPtr) /* Where to write the resulting length of the
|
||
* array of rewritten arguments. */
|
||
{
|
||
unsigned len = rewriteLength + objc - toRewrite;
|
||
Tcl_Obj **argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
|
||
|
||
memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
|
||
memcpy(argObjs + rewriteLength, objv + toRewrite,
|
||
sizeof(Tcl_Obj *) * (objc - toRewrite));
|
||
|
||
/*
|
||
* Now plumb this into the core ensemble rewrite logging system so that
|
||
* Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
|
||
* how to store the rewrite rules get complex solely because of the case
|
||
* where an ensemble rewrites itself out of the picture; when that
|
||
* happens, the quality of the error message rewrite falls drastically
|
||
* (and unavoidably).
|
||
*/
|
||
|
||
if (TclInitRewriteEnsemble(interp, toRewrite, rewriteLength, objv)) {
|
||
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
|
||
}
|
||
*lengthPtr = len;
|
||
return argObjs;
|
||
}
|
||
|
||
/*
|
||
* ----------------------------------------------------------------------
|
||
*
|
||
* assorted trivial 'getter' functions
|
||
*
|
||
* ----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Object
|
||
Tcl_MethodDeclarerObject(
|
||
Tcl_Method method)
|
||
{
|
||
return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
|
||
}
|
||
|
||
Tcl_Class
|
||
Tcl_MethodDeclarerClass(
|
||
Tcl_Method method)
|
||
{
|
||
return (Tcl_Class) ((Method *) method)->declaringClassPtr;
|
||
}
|
||
|
||
Tcl_Obj *
|
||
Tcl_MethodName(
|
||
Tcl_Method method)
|
||
{
|
||
return ((Method *) method)->namePtr;
|
||
}
|
||
|
||
int
|
||
Tcl_MethodIsType(
|
||
Tcl_Method method,
|
||
const Tcl_MethodType *typePtr,
|
||
ClientData *clientDataPtr)
|
||
{
|
||
Method *mPtr = (Method *) method;
|
||
|
||
if (mPtr->typePtr == typePtr) {
|
||
if (clientDataPtr != NULL) {
|
||
*clientDataPtr = mPtr->clientData;
|
||
}
|
||
return 1;
|
||
}
|
||
return 0;
|
||
}
|
||
|
||
int
|
||
Tcl_MethodIsPublic(
|
||
Tcl_Method method)
|
||
{
|
||
return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
|
||
}
|
||
|
||
/*
|
||
* Extended method construction for itcl-ng.
|
||
*/
|
||
|
||
Tcl_Method
|
||
TclOONewProcInstanceMethodEx(
|
||
Tcl_Interp *interp, /* The interpreter containing the object. */
|
||
Tcl_Object oPtr, /* The object to modify. */
|
||
TclOO_PreCallProc *preCallPtr,
|
||
TclOO_PostCallProc *postCallPtr,
|
||
ProcErrorProc *errProc,
|
||
ClientData clientData,
|
||
Tcl_Obj *nameObj, /* The name of the method, which must not be
|
||
* NULL. */
|
||
Tcl_Obj *argsObj, /* The formal argument list for the method,
|
||
* which must not be NULL. */
|
||
Tcl_Obj *bodyObj, /* The body of the method, which must not be
|
||
* NULL. */
|
||
int flags, /* Whether this is a public method. */
|
||
void **internalTokenPtr) /* If non-NULL, points to a variable that gets
|
||
* the reference to the ProcedureMethod
|
||
* structure. */
|
||
{
|
||
ProcedureMethod *pmPtr;
|
||
Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp,
|
||
(Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
|
||
|
||
if (method == NULL) {
|
||
return NULL;
|
||
}
|
||
pmPtr->flags = flags & USE_DECLARER_NS;
|
||
pmPtr->preCallProc = preCallPtr;
|
||
pmPtr->postCallProc = postCallPtr;
|
||
pmPtr->errProc = errProc;
|
||
pmPtr->clientData = clientData;
|
||
if (internalTokenPtr != NULL) {
|
||
*internalTokenPtr = pmPtr;
|
||
}
|
||
return method;
|
||
}
|
||
|
||
Tcl_Method
|
||
TclOONewProcMethodEx(
|
||
Tcl_Interp *interp, /* The interpreter containing the class. */
|
||
Tcl_Class clsPtr, /* The class to modify. */
|
||
TclOO_PreCallProc *preCallPtr,
|
||
TclOO_PostCallProc *postCallPtr,
|
||
ProcErrorProc *errProc,
|
||
ClientData clientData,
|
||
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
|
||
* if so, up to caller to manage storage
|
||
* (e.g., because it is a constructor or
|
||
* destructor). */
|
||
Tcl_Obj *argsObj, /* The formal argument list for the method,
|
||
* which may be NULL; if so, it is equivalent
|
||
* to an empty list. */
|
||
Tcl_Obj *bodyObj, /* The body of the method, which must not be
|
||
* NULL. */
|
||
int flags, /* Whether this is a public method. */
|
||
void **internalTokenPtr) /* If non-NULL, points to a variable that gets
|
||
* the reference to the ProcedureMethod
|
||
* structure. */
|
||
{
|
||
ProcedureMethod *pmPtr;
|
||
Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp,
|
||
(Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
|
||
|
||
if (method == NULL) {
|
||
return NULL;
|
||
}
|
||
pmPtr->flags = flags & USE_DECLARER_NS;
|
||
pmPtr->preCallProc = preCallPtr;
|
||
pmPtr->postCallProc = postCallPtr;
|
||
pmPtr->errProc = errProc;
|
||
pmPtr->clientData = clientData;
|
||
if (internalTokenPtr != NULL) {
|
||
*internalTokenPtr = pmPtr;
|
||
}
|
||
return method;
|
||
}
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* End:
|
||
*/
|