diff options
Diffstat (limited to 'generic/tclNamesp.c')
| -rw-r--r-- | generic/tclNamesp.c | 6968 |
1 files changed, 4973 insertions, 1995 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 4130c66..1747c99 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1,164 +1,264 @@ /* * tclNamesp.c -- * - * Contains support for namespaces, which provide a separate context of - * commands and global variables. The global :: namespace is the - * traditional Tcl "global" scope. Other namespaces are created as - * children of the global namespace. These other namespaces contain - * special-purpose commands and variables for packages. + * Contains support for namespaces, which provide a separate context of + * commands and global variables. The global :: namespace is the + * traditional Tcl "global" scope. Other namespaces are created as + * children of the global namespace. These other namespaces contain + * special-purpose commands and variables for packages. Also includes the + * TIP#112 ensemble machinery. * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2002-2005 Donal K. Fellows. + * Copyright (c) 2006 Neil Madden. + * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* - * Flag passed to TclGetNamespaceForQualName to indicate that it should - * search for a namespace rather than a command or variable inside a - * namespace. Note that this flag's value must not conflict with the values - * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN. + * Thread-local storage used to avoid having a global lock on data that is not + * limited to a single interpreter. */ -#define FIND_ONLY_NS 0x1000 +typedef struct ThreadSpecificData { + long numNsCreated; /* Count of the number of namespaces created + * within the thread. This value is used as a + * unique id for each namespace. Cannot be + * per-interp because the nsId is used to + * distinguish objects which can be passed + * around between interps in the same thread, + * but does not need to be global because + * object internal reps are always per-thread + * anyway. */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; /* - * Initial size of stack allocated space for tail list - used when resetting - * shadowed command references in the functin: TclResetShadowedCmdRefs. + * This structure contains a cached pointer to a namespace that is the result + * of resolving the namespace's name in some other namespace. It is the + * internal representation for a nsName object. It contains the pointer along + * with some information that is used to check the cached pointer's validity. */ -#define NUM_TRAIL_ELEMS 5 +typedef struct ResolvedNsName { + Namespace *nsPtr; /* A cached pointer to the Namespace that the + * name resolved to. */ + Namespace *refNsPtr; /* Points to the namespace context in which the + * name was resolved. NULL if the name is fully + * qualified and thus the resolution does not + * depend on the context. */ + int refCount; /* Reference count: 1 for each nsName object + * that has a pointer to this ResolvedNsName + * structure as its internal rep. This + * structure can be freed when refCount + * becomes zero. */ +} ResolvedNsName; /* - * Count of the number of namespaces created. This value is used as a - * unique id for each namespace. + * The client data for an ensemble command. This consists of the table of + * commands that are actually exported by the namespace, and an epoch counter + * that, combined with the exportLookupEpoch field of the namespace structure, + * defines whether the table contains valid data or will need to be recomputed + * next time the ensemble command is called. */ -static long numNsCreated = 0; -TCL_DECLARE_MUTEX(nsMutex) +typedef struct EnsembleConfig { + Namespace *nsPtr; /* The namspace backing this ensemble up. */ + Tcl_Command token; /* The token for the command that provides + * ensemble support for the namespace, or NULL + * if the command has been deleted (or never + * existed; the global namespace never has an + * ensemble command.) */ + int epoch; /* The epoch at which this ensemble's table of + * exported commands is valid. */ + char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all + * consistent points, this will have the same + * number of entries as there are entries in + * the subcommandTable hash. */ + Tcl_HashTable subcommandTable; + /* Hash table of ensemble subcommand names, + * which are its keys so this also provides + * the storage management for those subcommand + * names. The contents of the entry values are + * object version the prefix lists to use when + * substituting for the command/subcommand to + * build the ensemble implementation command. + * Has to be stored here as well as in + * subcommandDict because that field is NULL + * when we are deriving the ensemble from the + * namespace exports list. FUTURE WORK: use + * object hash table here. */ + struct EnsembleConfig *next;/* The next ensemble in the linked list of + * ensembles associated with a namespace. If + * this field points to this ensemble, the + * structure has already been unlinked from + * all lists, and cannot be found by scanning + * the list from the namespace's ensemble + * field. */ + int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, ENS_DEAD + * and ENSEMBLE_COMPILE. */ + + /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ + + Tcl_Obj *subcommandDict; /* Dictionary providing mapping from + * subcommands to their implementing command + * prefixes, or NULL if we are to build the + * map automatically from the namespace + * exports. */ + Tcl_Obj *subcmdList; /* List of commands that this ensemble + * actually provides, and whose implementation + * will be built using the subcommandDict (if + * present and defined) and by simple mapping + * to the namespace otherwise. If NULL, + * indicates that we are using the (dynamic) + * list of currently exported commands. */ + Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when + * no match is found (according to the rule + * defined by flag bit TCL_ENSEMBLE_PREFIX) or + * NULL to use the default error-generating + * behaviour. The script execution gets all + * the arguments to the ensemble command + * (including objv[0]) and will have the + * results passed directly back to the caller + * (including the error code) unless the code + * is TCL_CONTINUE in which case the + * subcommand will be reparsed by the ensemble + * core, presumably because the ensemble + * itself has been updated. */ +} EnsembleConfig; + +#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead + * and on its way out. */ /* - * This structure contains a cached pointer to a namespace that is the - * result of resolving the namespace's name in some other namespace. It is - * the internal representation for a nsName object. It contains the - * pointer along with some information that is used to check the cached - * pointer's validity. + * Declarations for functions local to this file: */ -typedef struct ResolvedNsName { - Namespace *nsPtr; /* A cached namespace pointer. */ - long nsId; /* nsPtr's unique namespace id. Used to - * verify that nsPtr is still valid - * (e.g., it's possible that the namespace - * was deleted and a new one created at - * the same address). */ - Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that - * contains the referenced namespace). */ - int refCount; /* Reference count: 1 for each nsName - * object that has a pointer to this - * ResolvedNsName structure as its internal - * rep. This structure can be freed when - * refCount becomes zero. */ -} ResolvedNsName; +static void DeleteImportedCmd(ClientData clientData); +static int DoImport(Tcl_Interp *interp, + Namespace *nsPtr, Tcl_HashEntry *hPtr, + const char *cmdName, const char *pattern, + Namespace *importNsPtr, int allowOverwrite); +static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); +static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char * EstablishErrorCodeTraces(ClientData clientData, + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); +static char * EstablishErrorInfoTraces(ClientData clientData, + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); +static void FreeNsNameInternalRep(Tcl_Obj *objPtr); +static int GetNamespaceFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); +static int InvokeImportedCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceChildrenCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceCurrentCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceEnsembleCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static void NamespaceFree(Namespace *nsPtr); +static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceInscopeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceQualifiersCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceUnknownCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static int NsEnsembleImplementationCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); +static int NsEnsembleStringOrder(const void *strPtr1, + const void *strPtr2); +static void DeleteEnsembleConfig(ClientData clientData); +static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, + const char *subcmdName, Tcl_Obj *prefixObjPtr); +static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); +static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); +static void UnlinkNsPath(Namespace *nsPtr); /* - * Declarations for procedures local to this file: - */ - -static void DeleteImportedCmd _ANSI_ARGS_(( - ClientData clientData)); -static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); -static void FreeNsNameInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); -static int GetNamespaceFromObj _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Namespace **nsPtrPtr)); -static int InvokeImportedCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceChildrenCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceCodeCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceCurrentCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceDeleteCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceEvalCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceExistsCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceExportCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceForgetCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); -static int NamespaceImportCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceInscopeCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceOriginCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceParentCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceQualifiersCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceTailCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceWhichCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int SetNsNameFromAny _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr)); -static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); - -/* - * This structure defines a Tcl object type that contains a - * namespace reference. It is used in commands that take the - * name of a namespace as an argument. The namespace reference - * is resolved, and the result in cached in the object. - */ - -Tcl_ObjType tclNsNameType = { + * This structure defines a Tcl object type that contains a namespace + * reference. It is used in commands that take the name of a namespace as an + * argument. The namespace reference is resolved, and the result in cached in + * the object. + */ + +static Tcl_ObjType nsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ - UpdateStringOfNsName, /* updateStringProc */ + NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; + +/* + * This structure defines a Tcl object type that contains a reference to an + * ensemble subcommand (e.g. the "length" in [string length ab]). It is used + * to cache the mapping between the subcommand itself and the real command + * that implements it. + */ + +Tcl_ObjType tclEnsembleCmdType = { + "ensembleCommand", /* the type's name */ + FreeEnsembleCmdRep, /* freeIntRepProc */ + DupEnsembleCmdRep, /* dupIntRepProc */ + StringOfEnsembleCmdRep, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; /* *---------------------------------------------------------------------- * * TclInitNamespaceSubsystem -- * - * This procedure is called to initialize all the structures that - * are used by namespaces on a per-process basis. + * This function is called to initialize all the structures that are used + * by namespaces on a per-process basis. * * Results: * None. @@ -170,7 +270,7 @@ Tcl_ObjType tclNsNameType = { */ void -TclInitNamespaceSubsystem() +TclInitNamespaceSubsystem(void) { /* * Does nothing for now. @@ -194,19 +294,11 @@ TclInitNamespaceSubsystem() */ Tcl_Namespace * -Tcl_GetCurrentNamespace(interp) - register Tcl_Interp *interp; /* Interpreter whose current namespace is - * being queried. */ +Tcl_GetCurrentNamespace( + register Tcl_Interp *interp)/* Interpreter whose current namespace is + * being queried. */ { - register Interp *iPtr = (Interp *) interp; - register Namespace *nsPtr; - - if (iPtr->varFramePtr != NULL) { - nsPtr = iPtr->varFramePtr->nsPtr; - } else { - nsPtr = iPtr->globalNsPtr; - } - return (Tcl_Namespace *) nsPtr; + return TclGetCurrentNamespace(interp); } /* @@ -226,13 +318,11 @@ Tcl_GetCurrentNamespace(interp) */ Tcl_Namespace * -Tcl_GetGlobalNamespace(interp) - register Tcl_Interp *interp; /* Interpreter whose global namespace - * should be returned. */ +Tcl_GetGlobalNamespace( + register Tcl_Interp *interp)/* Interpreter whose global namespace should + * be returned. */ { - register Interp *iPtr = (Interp *) interp; - - return (Tcl_Namespace *) iPtr->globalNsPtr; + return TclGetGlobalNamespace(interp); } /* @@ -240,9 +330,9 @@ Tcl_GetGlobalNamespace(interp) * * Tcl_PushCallFrame -- * - * Pushes a new call frame onto the interpreter's Tcl call stack. - * Called when executing a Tcl procedure or a "namespace eval" or - * "namespace inscope" command. + * Pushes a new call frame onto the interpreter's Tcl call stack. Called + * when executing a Tcl procedure or a "namespace eval" or "namespace + * inscope" command. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error @@ -255,45 +345,53 @@ Tcl_GetGlobalNamespace(interp) */ int -Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) - Tcl_Interp *interp; /* Interpreter in which the new call frame - * is to be pushed. */ - Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to - * push. Storage for this has already been - * allocated by the caller; typically this - * is the address of a CallFrame structure - * allocated on the caller's C stack. The - * call frame will be initialized by this - * procedure. The caller can pop the frame - * later with Tcl_PopCallFrame, and it is - * responsible for freeing the frame's - * storage. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace in which the - * frame will execute. If NULL, the - * interpreter's current namespace will - * be used. */ - int isProcCallFrame; /* If nonzero, the frame represents a - * called Tcl procedure and may have local - * vars. Vars will ordinarily be looked up - * in the frame. If new variables are - * created, they will be created in the - * frame. If 0, the frame is for a - * "namespace eval" or "namespace inscope" - * command and var references are treated - * as references to namespace variables. */ +Tcl_PushCallFrame( + Tcl_Interp *interp, /* Interpreter in which the new call frame is + * to be pushed. */ + Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push. + * Storage for this has already been allocated + * by the caller; typically this is the + * address of a CallFrame structure allocated + * on the caller's C stack. The call frame + * will be initialized by this function. The + * caller can pop the frame later with + * Tcl_PopCallFrame, and it is responsible for + * freeing the frame's storage. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame + * will execute. If NULL, the interpreter's + * current namespace will be used. */ + int isProcCallFrame) /* If nonzero, the frame represents a called + * Tcl procedure and may have local vars. Vars + * will ordinarily be looked up in the frame. + * If new variables are created, they will be + * created in the frame. If 0, the frame is + * for a "namespace eval" or "namespace + * inscope" command and var references are + * treated as references to namespace + * variables. */ { Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { - nsPtr = (Namespace *) namespacePtr; - if (nsPtr->flags & NS_DEAD) { - panic("Trying to push call frame for dead namespace"); + nsPtr = (Namespace *) namespacePtr; + + /* + * TODO: Examine whether it would be better to guard based on NS_DYING + * or NS_KILLED. It appears that these are not tested because they can + * be set in a global interp that has been [namespace delete]d, but + * which never really completely goes away because of lingering global + * things like ::errorInfo and [::unknown] and hidden commands. + * Review of those designs might permit stricter checking here. + */ + + if (nsPtr->flags & NS_DEAD) { + Tcl_Panic("Trying to push call frame for dead namespace"); /*NOTREACHED*/ - } + } } nsPtr->activationCount++; @@ -304,18 +402,20 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { - framePtr->level = (iPtr->varFramePtr->level + 1); + framePtr->level = (iPtr->varFramePtr->level + 1); } else { - framePtr->level = 1; + framePtr->level = 0; } - framePtr->procPtr = NULL; /* no called procedure */ - framePtr->varTablePtr = NULL; /* and no local variables */ + framePtr->procPtr = NULL; /* no called procedure */ + framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; + framePtr->clientData = NULL; + framePtr->localCachePtr = NULL; /* - * Push the new call frame onto the interpreter's stack of procedure - * call frames making it the current frame. + * Push the new call frame onto the interpreter's stack of procedure call + * frames making it the current frame. */ iPtr->framePtr = framePtr; @@ -336,51 +436,57 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) * * Side effects: * Modifies the call stack of the interpreter. Resets various fields of - * the popped call frame. If a namespace has been deleted and - * has no more activations on the call stack, the namespace is - * destroyed. + * the popped call frame. If a namespace has been deleted and has no more + * activations on the call stack, the namespace is destroyed. * *---------------------------------------------------------------------- */ void -Tcl_PopCallFrame(interp) - Tcl_Interp* interp; /* Interpreter with call frame to pop. */ +Tcl_PopCallFrame( + Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { register Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* - * It's important to remove the call frame from the interpreter's stack - * of call frames before deleting local variables, so that traces - * invoked by the variable deletion don't see the partially-deleted - * frame. + * It's important to remove the call frame from the interpreter's stack of + * call frames before deleting local variables, so that traces invoked by + * the variable deletion don't see the partially-deleted frame. */ - iPtr->framePtr = framePtr->callerPtr; - iPtr->varFramePtr = framePtr->callerVarPtr; + if (framePtr->callerPtr) { + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + } else { + /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ + } if (framePtr->varTablePtr != NULL) { - TclDeleteVars(iPtr, framePtr->varTablePtr); - ckfree((char *) framePtr->varTablePtr); - framePtr->varTablePtr = NULL; + TclDeleteVars(iPtr, framePtr->varTablePtr); + ckfree((char *) framePtr->varTablePtr); + framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { - TclDeleteCompiledLocalVars(iPtr, framePtr); + TclDeleteCompiledLocalVars(iPtr, framePtr); + if (--framePtr->localCachePtr->refCount == 0) { + TclFreeLocalCache(interp, framePtr->localCachePtr); + } + framePtr->localCachePtr = NULL; } /* - * Decrement the namespace's count of active call frames. If the - * namespace is "dying" and there are no more active call frames, - * call Tcl_DeleteNamespace to destroy it. + * Decrement the namespace's count of active call frames. If the namespace + * is "dying" and there are no more active call frames, call + * Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) - && (nsPtr->activationCount == 0)) { - Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); + && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { + Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; } @@ -388,137 +494,346 @@ Tcl_PopCallFrame(interp) /* *---------------------------------------------------------------------- * + * TclPushStackFrame -- + * + * Allocates a new call frame in the interpreter's execution stack, then + * pushes it onto the interpreter's Tcl call stack. Called when executing + * a Tcl procedure or a "namespace eval" or "namespace inscope" command. + * + * Results: + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter's result object) if something goes wrong. + * + * Side effects: + * Modifies the interpreter's Tcl call stack. + * + *---------------------------------------------------------------------- + */ + +int +TclPushStackFrame( + Tcl_Interp *interp, /* Interpreter in which the new call frame is + * to be pushed. */ + Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack + * allocated call frame. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame + * will execute. If NULL, the interpreter's + * current namespace will be used. */ + int isProcCallFrame) /* If nonzero, the frame represents a called + * Tcl procedure and may have local vars. Vars + * will ordinarily be looked up in the frame. + * If new variables are created, they will be + * created in the frame. If 0, the frame is + * for a "namespace eval" or "namespace + * inscope" command and var references are + * treated as references to namespace + * variables. */ +{ + *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); + return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, + isProcCallFrame); +} + +void +TclPopStackFrame( + Tcl_Interp *interp) /* Interpreter with call frame to pop. */ +{ + CallFrame *freePtr = ((Interp *)interp)->framePtr; + + Tcl_PopCallFrame(interp); + TclStackFree(interp, freePtr); +} + +/* + *---------------------------------------------------------------------- + * + * EstablishErrorCodeTraces -- + * + * Creates traces on the ::errorCode variable to keep its value + * consistent with the expectations of legacy code. + * + * Results: + * None. + * + * Side effects: + * Read and unset traces are established on ::errorCode. + * + *---------------------------------------------------------------------- + */ + +static char * +EstablishErrorCodeTraces( + ClientData clientData, + Tcl_Interp *interp, + const char *name1, + const char *name2, + int flags) +{ + Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, + ErrorCodeRead, NULL); + Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, + EstablishErrorCodeTraces, NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ErrorCodeRead -- + * + * Called when the ::errorCode variable is read. Copies the current value + * of the interp's errorCode field into ::errorCode. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ErrorCodeRead( + ClientData clientData, + Tcl_Interp *interp, + const char *name1, + const char *name2, + int flags) +{ + Interp *iPtr = (Interp *)interp; + + if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { + return NULL; + } + if (iPtr->errorCode) { + Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, + iPtr->errorCode, TCL_GLOBAL_ONLY); + return NULL; + } + if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) { + Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, + Tcl_NewObj(), TCL_GLOBAL_ONLY); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * EstablishErrorInfoTraces -- + * + * Creates traces on the ::errorInfo variable to keep its value + * consistent with the expectations of legacy code. + * + * Results: + * None. + * + * Side effects: + * Read and unset traces are established on ::errorInfo. + * + *---------------------------------------------------------------------- + */ + +static char * +EstablishErrorInfoTraces( + ClientData clientData, + Tcl_Interp *interp, + const char *name1, + const char *name2, + int flags) +{ + Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, + ErrorInfoRead, NULL); + Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, + EstablishErrorInfoTraces, NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ErrorInfoRead -- + * + * Called when the ::errorInfo variable is read. Copies the current value + * of the interp's errorInfo field into ::errorInfo. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ErrorInfoRead( + ClientData clientData, + Tcl_Interp *interp, + const char *name1, + const char *name2, + int flags) +{ + Interp *iPtr = (Interp *) interp; + + if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { + return NULL; + } + if (iPtr->errorInfo) { + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + return NULL; + } + if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) { + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, + Tcl_NewObj(), TCL_GLOBAL_ONLY); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_CreateNamespace -- * - * Creates a new namespace with the given name. If there is no - * active namespace (i.e., the interpreter is being initialized), - * the global :: namespace is created and returned. + * Creates a new namespace with the given name. If there is no active + * namespace (i.e., the interpreter is being initialized), the global :: + * namespace is created and returned. * * Results: - * Returns a pointer to the new namespace if successful. If the - * namespace already exists or if another error occurs, this routine - * returns NULL, along with an error message in the interpreter's - * result object. + * Returns a pointer to the new namespace if successful. If the namespace + * already exists or if another error occurs, this routine returns NULL, + * along with an error message in the interpreter's result object. * * Side effects: - * If the name contains "::" qualifiers and a parent namespace does - * not already exist, it is automatically created. + * If the name contains "::" qualifiers and a parent namespace does not + * already exist, it is automatically created. * *---------------------------------------------------------------------- */ Tcl_Namespace * -Tcl_CreateNamespace(interp, name, clientData, deleteProc) - Tcl_Interp *interp; /* Interpreter in which a new namespace - * is being created. Also used for - * error reporting. */ - CONST char *name; /* Name for the new namespace. May be a - * qualified name with names of ancestor - * namespaces separated by "::"s. */ - ClientData clientData; /* One-word value to store with - * namespace. */ - Tcl_NamespaceDeleteProc *deleteProc; - /* Procedure called to delete client - * data when the namespace is deleted. - * NULL if no procedure should be - * called. */ +Tcl_CreateNamespace( + Tcl_Interp *interp, /* Interpreter in which a new namespace is + * being created. Also used for error + * reporting. */ + const char *name, /* Name for the new namespace. May be a + * qualified name with names of ancestor + * namespaces separated by "::"s. */ + ClientData clientData, /* One-word value to store with namespace. */ + Tcl_NamespaceDeleteProc *deleteProc) + /* Function called to delete client data when + * the namespace is deleted. NULL if no + * function should be called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; - CONST char *simpleName; + const char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; - int newEntry; + Tcl_DString *namePtr, *buffPtr; + int newEntry, nameLen; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * If there is no active namespace, the interpreter is being - * initialized. + * If there is no active namespace, the interpreter is being initialized. */ if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { /* - * Treat this namespace as the global namespace, and avoid - * looking for a parent. + * Treat this namespace as the global namespace, and avoid looking for + * a parent. */ - - parentPtr = NULL; - simpleName = ""; + + parentPtr = NULL; + simpleName = ""; } else if (*name == '\0') { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't create namespace \"\": " + "only global namespace can have empty name", NULL); return NULL; } else { /* * Find the parent for the new namespace. */ - TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + TclGetNamespaceForQualName(interp, name, NULL, + /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new - * namespace was already (recursively) created and is pointed to - * by parentPtr. + * "::"s after the namespace's name which we ignore. The new namespace + * was already (recursively) created and is pointed to by parentPtr. */ if (*simpleName == '\0') { return (Tcl_Namespace *) parentPtr; } - /* - * Check for a bad namespace name and make sure that the name - * does not already exist in the parent namespace. + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. */ - if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't create namespace \"", name, - "\": already exists", (char *) NULL); - return NULL; - } + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { + Tcl_AppendResult(interp, "can't create namespace \"", name, + "\": already exists", NULL); + return NULL; + } } /* - * Create the new namespace and root it in its parent. Increment the - * count of namespaces created. + * Create the new namespace and root it in its parent. Increment the count + * of namespaces created. */ - nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); - nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); + nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); - nsPtr->fullName = NULL; /* set below */ - nsPtr->clientData = clientData; - nsPtr->deleteProc = deleteProc; - nsPtr->parentPtr = parentPtr; + nsPtr->fullName = NULL; /* Set below. */ + nsPtr->clientData = clientData; + nsPtr->deleteProc = deleteProc; + nsPtr->parentPtr = parentPtr; Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); - Tcl_MutexLock(&nsMutex); - numNsCreated++; - nsPtr->nsId = numNsCreated; - Tcl_MutexUnlock(&nsMutex); - nsPtr->interp = interp; - nsPtr->flags = 0; + nsPtr->nsId = ++(tsdPtr->numNsCreated); + nsPtr->interp = interp; + nsPtr->flags = 0; nsPtr->activationCount = 0; - nsPtr->refCount = 0; + nsPtr->refCount = 0; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); - nsPtr->exportArrayPtr = NULL; + TclInitVarHashTable(&nsPtr->varTable, nsPtr); + nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; - nsPtr->cmdRefEpoch = 0; - nsPtr->resolverEpoch = 0; - nsPtr->cmdResProc = NULL; - nsPtr->varResProc = NULL; + nsPtr->cmdRefEpoch = 0; + nsPtr->resolverEpoch = 0; + nsPtr->cmdResProc = NULL; + nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; + nsPtr->exportLookupEpoch = 0; + nsPtr->ensembles = NULL; + nsPtr->unknownHandlerPtr = NULL; + nsPtr->commandPathLength = 0; + nsPtr->commandPathArray = NULL; + nsPtr->commandPathSourceList = NULL; if (parentPtr != NULL) { - entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, - &newEntry); - Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); + entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, + &newEntry); + Tcl_SetHashValue(entryPtr, nsPtr); + } else { + /* + * In the global namespace create traces to maintain the ::errorInfo + * and ::errorCode variables. + */ + + iPtr->globalNsPtr = nsPtr; + EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0); + EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0); } /* @@ -527,22 +842,41 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) Tcl_DStringInit(&buffer1); Tcl_DStringInit(&buffer2); - for (ancestorPtr = nsPtr; ancestorPtr != NULL; + namePtr = &buffer1; + buffPtr = &buffer2; + for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { - if (ancestorPtr != globalNsPtr) { - Tcl_DStringAppend(&buffer1, "::", 2); - Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); - } - Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); + if (ancestorPtr != globalNsPtr) { + register Tcl_DString *tempPtr = namePtr; + + Tcl_DStringAppend(buffPtr, "::", 2); + Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); + Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr), + Tcl_DStringLength(namePtr)); + + /* + * Clear the unwanted buffer or we end up appending to previous + * results, making the namespace fullNames of nested namespaces + * very wrong (and strange). + */ + + Tcl_DStringSetLength(namePtr, 0); + + /* + * Now swap the buffer pointers so that we build in the other + * buffer. This is faster than repeated copying back and forth + * between buffers. + */ - Tcl_DStringSetLength(&buffer2, 0); - Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); - Tcl_DStringSetLength(&buffer1, 0); + namePtr = buffPtr; + buffPtr = tempPtr; + } } - - name = Tcl_DStringValue(&buffer2); - nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); - strcpy(nsPtr->fullName, name); + + name = Tcl_DStringValue(namePtr); + nameLen = Tcl_DStringLength(namePtr); + nsPtr->fullName = ckalloc((unsigned) (nameLen+1)); + memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); @@ -566,50 +900,79 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * None. * * Side effects: - * When a namespace is deleted, it is automatically removed as a - * child of its parent namespace. Also, all its commands, variables - * and child namespaces are deleted. + * When a namespace is deleted, it is automatically removed as a child of + * its parent namespace. Also, all its commands, variables and child + * namespaces are deleted. * *---------------------------------------------------------------------- */ void -Tcl_DeleteNamespace(namespacePtr) - Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ +Tcl_DeleteNamespace( + Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; - Namespace *globalNsPtr = - (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); + Namespace *globalNsPtr = (Namespace *) + TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; /* + * If the namespace has associated ensemble commands, delete them first. + * This leaves the actual contents of the namespace alone (unless they are + * linked ensemble commands, of course). Note that this code is actually + * reentrant so command delete traces won't purturb things badly. + */ + + while (nsPtr->ensembles != NULL) { + EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; + + /* + * Splice out and link to indicate that we've already been killed. + */ + + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; + ensemblePtr->next = ensemblePtr; + Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); + } + + /* + * If the namespace has a registered unknown handler (TIP 181), then free + * it here. + */ + + if (nsPtr->unknownHandlerPtr != NULL) { + Tcl_DecrRefCount(nsPtr->unknownHandlerPtr); + nsPtr->unknownHandlerPtr = NULL; + } + + /* * If the namespace is on the call frame stack, it is marked as "dying" - * (NS_DYING is OR'd into its flags): the namespace can't be looked up - * by name but its commands and variables are still usable by those - * active call frames. When all active call frames referring to the - * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will - * call this procedure again to delete everything in the namespace. - * If no nsName objects refer to the namespace (i.e., if its refCount - * is zero), its commands and variables are deleted and the storage for - * its namespace structure is freed. Otherwise, if its refCount is - * nonzero, the namespace's commands and variables are deleted but the - * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's - * flags to allow the namespace resolution code to recognize that the - * namespace is "deleted". The structure's storage is freed by - * FreeNsNameInternalRep when its refCount reaches 0. - */ - - if (nsPtr->activationCount > 0) { - nsPtr->flags |= NS_DYING; - if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + * (NS_DYING is OR'd into its flags): the namespace can't be looked up by + * name but its commands and variables are still usable by those active + * call frames. When all active call frames referring to the namespace + * have been popped from the Tcl stack, Tcl_PopCallFrame will call this + * function again to delete everything in the namespace. If no nsName + * objects refer to the namespace (i.e., if its refCount is zero), its + * commands and variables are deleted and the storage for its namespace + * structure is freed. Otherwise, if its refCount is nonzero, the + * namespace's commands and variables are deleted but the structure isn't + * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the + * namespace resolution code to recognize that the namespace is "deleted". + * The structure's storage is freed by FreeNsNameInternalRep when its + * refCount reaches 0. + */ + + if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { + nsPtr->flags |= NS_DYING; + if (nsPtr->parentPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, nsPtr->name); - if (entryPtr != NULL) { - Tcl_DeleteHashEntry(entryPtr); - } - } - nsPtr->parentPtr = NULL; + if (entryPtr != NULL) { + Tcl_DeleteHashEntry(entryPtr); + } + } + nsPtr->parentPtr = NULL; } else if (!(nsPtr->flags & NS_KILLED)) { /* * Delete the namespace and everything in it. If this is the global @@ -620,38 +983,46 @@ Tcl_DeleteNamespace(namespacePtr) */ nsPtr->flags |= (NS_DYING|NS_KILLED); - - TclTeardownNamespace(nsPtr); - if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { - /* + TclTeardownNamespace(nsPtr); + + if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { + /* * If this is the global namespace, then it may have residual - * "errorInfo" and "errorCode" variables for errors that - * occurred while it was being torn down. Try to clear the - * variable list one last time. + * "errorInfo" and "errorCode" variables for errors that occurred + * while it was being torn down. Try to clear the variable list + * one last time. + */ + + TclDeleteNamespaceVars(nsPtr); + + Tcl_DeleteHashTable(&nsPtr->childTable); + Tcl_DeleteHashTable(&nsPtr->cmdTable); + + /* + * If the reference count is 0, then discard the namespace. + * Otherwise, mark it as "dead" so that it can't be used. */ - TclDeleteNamespaceVars(nsPtr); - - Tcl_DeleteHashTable(&nsPtr->childTable); - Tcl_DeleteHashTable(&nsPtr->cmdTable); - - /* - * If the reference count is 0, then discard the namespace. - * Otherwise, mark it as "dead" so that it can't be used. - */ - - if (nsPtr->refCount == 0) { - NamespaceFree(nsPtr); - } else { - nsPtr->flags |= NS_DEAD; - } - } else { + if (nsPtr->refCount == 0) { + NamespaceFree(nsPtr); + } else { + nsPtr->flags |= NS_DEAD; + } + } else { + /* + * Restore the ::errorInfo and ::errorCode traces. + */ + + EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); + EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); + /* - * We didn't really kill it, so remove the KILLED marks, so - * it can get killed later, avoiding mem leaks + * We didn't really kill it, so remove the KILLED marks, so it can + * get killed later, avoiding mem leaks. */ - nsPtr->flags &= ~(NS_DYING|NS_KILLED); + + nsPtr->flags &= ~(NS_DYING|NS_KILLED); } } } @@ -666,9 +1037,7 @@ Tcl_DeleteNamespace(namespacePtr) * commands, variables, and child namespaces. * * This is kept separate from Tcl_DeleteNamespace so that the global - * namespace can be handled specially. Global variables like - * "errorInfo" and "errorCode" need to remain intact while other - * namespaces and commands are torn down, in case any errors occur. + * namespace can be handled specially. * * Results: * None. @@ -676,15 +1045,13 @@ Tcl_DeleteNamespace(namespacePtr) * Side effects: * Removes this namespace from its parent's child namespace hashtable. * Deletes all commands, variables and namespaces in this namespace. - * If this is the global namespace, the "errorInfo" and "errorCode" - * variables are left alone and deleted later. * *---------------------------------------------------------------------- */ void -TclTeardownNamespace(nsPtr) - register Namespace *nsPtr; /* Points to the namespace to be dismantled +TclTeardownNamespace( + register Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; @@ -692,69 +1059,30 @@ TclTeardownNamespace(nsPtr) Tcl_HashSearch search; Tcl_Namespace *childNsPtr; Tcl_Command cmd; - Namespace *globalNsPtr = - (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); int i; /* - * Start by destroying the namespace's variable table, - * since variables might trigger traces. + * Start by destroying the namespace's variable table, since variables + * might trigger traces. Variable table should be cleared but not freed! + * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. */ - if (nsPtr == globalNsPtr) { - /* - * This is the global namespace. Tearing it down will destroy the - * ::errorInfo and ::errorCode variables. We save and restore them - * in case there are any errors in progress, so the error details - * they contain will not be lost. See test namespace-8.5 - */ - - Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo", - NULL, TCL_GLOBAL_ONLY); - Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode", - NULL, TCL_GLOBAL_ONLY); - - if (errorInfo) { - Tcl_IncrRefCount(errorInfo); - } - if (errorCode) { - Tcl_IncrRefCount(errorCode); - } - - TclDeleteNamespaceVars(nsPtr); - Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); - - if (errorInfo) { - Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL, - errorInfo, TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(errorInfo); - } - if (errorCode) { - Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL, - errorCode, TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(errorCode); - } - } else { - /* - * Variable table should be cleared but not freed! TclDeleteVars - * frees it, so we reinitialize it afterwards. - */ - - TclDeleteNamespaceVars(nsPtr); - Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); - } + TclDeleteNamespaceVars(nsPtr); + TclInitVarHashTable(&nsPtr->varTable, nsPtr); /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the * command table. + * + * Don't optimize to Tcl_NextHashEntry() because of traces. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { + cmd = Tcl_GetHashValue(entryPtr); + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); @@ -764,28 +1092,49 @@ TclTeardownNamespace(nsPtr) */ if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, - nsPtr->name); - if (entryPtr != NULL) { - Tcl_DeleteHashEntry(entryPtr); - } + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + nsPtr->name); + if (entryPtr != NULL) { + Tcl_DeleteHashEntry(entryPtr); + } } nsPtr->parentPtr = NULL; /* + * Delete the namespace path if one is installed. + */ + + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + nsPtr->commandPathLength = 0; + } + if (nsPtr->commandPathSourceList != NULL) { + NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + do { + if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) { + nsPathPtr->creatorNsPtr->cmdRefEpoch++; + } + nsPathPtr->nsPtr = NULL; + nsPathPtr = nsPathPtr->nextPtr; + } while (nsPathPtr != NULL); + nsPtr->commandPathSourceList = NULL; + } + + /* * Delete all the child namespaces. * - * BE CAREFUL: When each child is deleted, it will divorce - * itself from its parent. You can't traverse a hash table - * properly if its elements are being deleted. We use only - * the Tcl_FirstHashEntry function to be safe. + * BE CAREFUL: When each child is deleted, it will divorce itself from its + * parent. You can't traverse a hash table properly if its elements are + * being deleted. We use only the Tcl_FirstHashEntry function to be safe. + * + * Don't optimize to Tcl_NextHashEntry() because of traces. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { - childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + childNsPtr = Tcl_GetHashValue(entryPtr); + Tcl_DeleteNamespace(childNsPtr); } /* @@ -796,7 +1145,7 @@ TclTeardownNamespace(nsPtr) for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -807,15 +1156,15 @@ TclTeardownNamespace(nsPtr) */ if (nsPtr->deleteProc != NULL) { - (*nsPtr->deleteProc)(nsPtr->clientData); + (*nsPtr->deleteProc)(nsPtr->clientData); } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; /* - * Reset the namespace's id field to ensure that this namespace won't - * be interpreted as valid by, e.g., the cache validation code for - * cached command references in Tcl_GetCommandFromObj. + * Reset the namespace's id field to ensure that this namespace won't be + * interpreted as valid by, e.g., the cache validation code for cached + * command references in Tcl_GetCommandFromObj. */ nsPtr->nsId = 0; @@ -826,9 +1175,8 @@ TclTeardownNamespace(nsPtr) * * NamespaceFree -- * - * Called after a namespace has been deleted, when its - * reference count reaches 0. Frees the data structure - * representing the namespace. + * Called after a namespace has been deleted, when its reference count + * reaches 0. Frees the data structure representing the namespace. * * Results: * None. @@ -840,8 +1188,8 @@ TclTeardownNamespace(nsPtr) */ static void -NamespaceFree(nsPtr) - register Namespace *nsPtr; /* Points to the namespace to free. */ +NamespaceFree( + register Namespace *nsPtr) /* Points to the namespace to free. */ { /* * Most of the namespace's contents are freed when the namespace is @@ -854,7 +1202,6 @@ NamespaceFree(nsPtr) ckfree((char *) nsPtr); } - /* *---------------------------------------------------------------------- @@ -862,10 +1209,10 @@ NamespaceFree(nsPtr) * Tcl_Export -- * * Makes all the commands matching a pattern available to later be - * imported from the namespace specified by namespacePtr (or the - * current namespace if namespacePtr is NULL). The specified pattern is - * appended onto the namespace's export pattern list, which is - * optionally cleared beforehand. + * imported from the namespace specified by namespacePtr (or the current + * namespace if namespacePtr is NULL). The specified pattern is appended + * onto the namespace's export pattern list, which is optionally cleared + * beforehand. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error @@ -879,23 +1226,22 @@ NamespaceFree(nsPtr) */ int -Tcl_Export(interp, namespacePtr, pattern, resetListFirst) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace from which - * commands are to be exported. NULL for - * the current namespace. */ - CONST char *pattern; /* String pattern indicating which commands - * to export. This pattern may not include - * any namespace qualifiers; only commands - * in the specified namespace may be - * exported. */ - int resetListFirst; /* If nonzero, resets the namespace's - * export list before appending. */ -{ -#define INIT_EXPORT_PATTERNS 5 +Tcl_Export( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace from which commands + * are to be exported. NULL for the current + * namespace. */ + const char *pattern, /* String pattern indicating which commands to + * export. This pattern may not include any + * namespace qualifiers; only commands in the + * specified namespace may be exported. */ + int resetListFirst) /* If nonzero, resets the namespace's export + * list before appending. */ +{ +#define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - CONST char *simplePattern; + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + const char *simplePattern; char *patternCpy; int neededElems, len, i; @@ -904,9 +1250,9 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) currNsPtr; + nsPtr = (Namespace *) currNsPtr; } else { - nsPtr = (Namespace *) namespacePtr; + nsPtr = (Namespace *) namespacePtr; } /* @@ -921,6 +1267,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) } ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; + TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } @@ -935,49 +1282,39 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", - (char *) NULL); + Tcl_AppendResult(interp, "invalid export pattern \"", pattern, + "\": pattern can't specify a namespace", NULL); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array */ + if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { /* - * The pattern already exists in the list + * The pattern already exists in the list. */ + return TCL_OK; } } } /* - * Make sure there is room in the namespace's pattern array for the - * new pattern. + * Make sure there is room in the namespace's pattern array for the new + * pattern. */ neededElems = nsPtr->numExportPatterns + 1; - if (nsPtr->exportArrayPtr == NULL) { + if (neededElems > nsPtr->maxExportPatterns) { + nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? + 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; nsPtr->exportArrayPtr = (char **) - ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); - nsPtr->numExportPatterns = 0; - nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; - } else if (neededElems > nsPtr->maxExportPatterns) { - int numNewElems = 2 * nsPtr->maxExportPatterns; - size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); - size_t newBytes = numNewElems * sizeof(char *); - char **newPtr = (char **) ckalloc((unsigned) newBytes); - - memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, - currBytes); - ckfree((char *) nsPtr->exportArrayPtr); - nsPtr->exportArrayPtr = (char **) newPtr; - nsPtr->maxExportPatterns = numNewElems; + ckrealloc((char *) nsPtr->exportArrayPtr, + sizeof(char *) * nsPtr->maxExportPatterns); } /* @@ -985,11 +1322,20 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) */ len = strlen(pattern); - patternCpy = (char *) ckalloc((unsigned) (len + 1)); - strcpy(patternCpy, pattern); - + patternCpy = ckalloc((unsigned) (len + 1)); + memcpy(patternCpy, pattern, (unsigned) len + 1); + nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; + + /* + * The list of commands actually exported from the namespace might have + * changed (probably will have!) However, we do not need to recompute this + * just yet; next time we need the info will be soon enough. + */ + + TclInvalidateNsCmdLookup(nsPtr); + return TCL_OK; #undef INIT_EXPORT_PATTERNS } @@ -1005,24 +1351,24 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) * Results: * The return value is normally TCL_OK; in this case the object * referenced by objPtr has each export pattern appended to it. If an - * error occurs, TCL_ERROR is returned and the interpreter's result - * holds an error message. + * error occurs, TCL_ERROR is returned and the interpreter's result holds + * an error message. * * Side effects: - * If necessary, the object referenced by objPtr is converted into - * a list object. + * If necessary, the object referenced by objPtr is converted into a list + * object. * *---------------------------------------------------------------------- */ int -Tcl_AppendExportList(interp, namespacePtr, objPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace whose export - * pattern list is appended onto objPtr. - * NULL for the current namespace. */ - Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * export pattern list is appended. */ +Tcl_AppendExportList( + Tcl_Interp *interp, /* Interpreter used for error reporting. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace whose export + * pattern list is appended onto objPtr. NULL + * for the current namespace. */ + Tcl_Obj *objPtr) /* Points to the Tcl object onto which the + * export pattern list is appended. */ { Namespace *nsPtr; int i, result; @@ -1032,9 +1378,9 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr) */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { - nsPtr = (Namespace *) namespacePtr; + nsPtr = (Namespace *) namespacePtr; } /* @@ -1057,90 +1403,79 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr) * Tcl_Import -- * * Imports all of the commands matching a pattern into the namespace - * specified by namespacePtr (or the current namespace if contextNsPtr - * is NULL). This is done by creating a new command (the "imported - * command") that points to the real command in its original namespace. + * specified by namespacePtr (or the current namespace if contextNsPtr is + * NULL). This is done by creating a new command (the "imported command") + * that points to the real command in its original namespace. * - * If matching commands are on the autoload path but haven't been - * loaded yet, this command forces them to be loaded, then creates - * the links to them. + * If matching commands are on the autoload path but haven't been loaded + * yet, this command forces them to be loaded, then creates the links to + * them. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * * Side effects: - * Creates new commands in the importing namespace. These indirect - * calls back to the real command and are deleted if the real commands - * are deleted. + * Creates new commands in the importing namespace. These indirect calls + * back to the real command and are deleted if the real commands are + * deleted. * *---------------------------------------------------------------------- */ int -Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace into which the - * commands are to be imported. NULL for - * the current namespace. */ - CONST char *pattern; /* String pattern indicating which commands - * to import. This pattern should be - * qualified by the name of the namespace - * from which to import the command(s). */ - int allowOverwrite; /* If nonzero, allow existing commands to - * be overwritten by imported commands. - * If 0, return an error if an imported - * cmd conflicts with an existing one. */ +Tcl_Import( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace into which the + * commands are to be imported. NULL for the + * current namespace. */ + const char *pattern, /* String pattern indicating which commands to + * import. This pattern should be qualified by + * the name of the namespace from which to + * import the command(s). */ + int allowOverwrite) /* If nonzero, allow existing commands to be + * overwritten by imported commands. If 0, + * return an error if an imported cmd + * conflicts with an existing one. */ { - Interp *iPtr = (Interp *) interp; Namespace *nsPtr, *importNsPtr, *dummyPtr; - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - CONST char *simplePattern; - char *cmdName; + const char *simplePattern; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Command *cmdPtr; - ImportRef *refPtr; - Tcl_Command autoCmd, importedCmd; - ImportedCmdData *dataPtr; - int wasExported, i, result; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) currNsPtr; + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { - nsPtr = (Namespace *) namespacePtr; + nsPtr = (Namespace *) namespacePtr; } - + /* - * First, invoke the "auto_import" command with the pattern - * being imported. This command is part of the Tcl library. - * It looks for imported commands in autoloaded libraries and - * loads them in. That way, they will be found when we try - * to create links below. + * First, invoke the "auto_import" command with the pattern being + * imported. This command is part of the Tcl library. It looks for + * imported commands in autoloaded libraries and loads them in. That way, + * they will be found when we try to create links below. + * + * Note that we don't just call Tcl_EvalObjv() directly because we do not + * want absence of the command to be a failure case. */ - - autoCmd = Tcl_FindCommand(interp, "auto_import", - (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); - - if (autoCmd != NULL) { + + if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { Tcl_Obj *objv[2]; - - objv[0] = Tcl_NewStringObj("auto_import", -1); - Tcl_IncrRefCount(objv[0]); + int result; + + TclNewLiteralStringObj(objv[0], "auto_import"); objv[1] = Tcl_NewStringObj(pattern, -1); + + Tcl_IncrRefCount(objv[0]); Tcl_IncrRefCount(objv[1]); - - cmdPtr = (Command *) autoCmd; - result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, - 2, objv); - + result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(objv[0]); Tcl_DecrRefCount(objv[1]); - + if (result != TCL_OK) { return TCL_ERROR; } @@ -1148,38 +1483,35 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) } /* - * From the pattern, find the namespace from which we are importing - * and get the simple pattern (no namespace qualifiers or ::'s) at - * the end. + * From the pattern, find the namespace from which we are importing and + * get the simple pattern (no namespace qualifiers or ::'s) at the end. */ if (strlen(pattern) == 0) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - "empty import pattern", -1); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); + return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace in import pattern \"", - pattern, "\"", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "unknown namespace in import pattern \"", + pattern, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); + return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendResult(interp, "no namespace specified in import pattern \"", pattern, - "\"", (char *) NULL); + "\"", NULL); } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "import pattern \"", pattern, + Tcl_AppendResult(interp, "import pattern \"", pattern, "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", (char *) NULL); + importNsPtr->name, "\" into itself", NULL); } - return TCL_ERROR; + return TCL_ERROR; } /* @@ -1189,118 +1521,154 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * commands redirect their invocations to the "real" command. */ + if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) { + hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern); + if (hPtr == NULL) { + return TCL_OK; + } + return DoImport(interp, nsPtr, hPtr, simplePattern, pattern, + importNsPtr, allowOverwrite); + } for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); - (hPtr != NULL); - hPtr = Tcl_NextHashEntry(&search)) { - cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); - if (Tcl_StringMatch(cmdName, simplePattern)) { - /* - * The command cmdName in the source namespace matches the - * pattern. Check whether it was exported. If it wasn't, - * we ignore it. - */ - Tcl_HashEntry *found; + (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { + char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); + if (Tcl_StringMatch(cmdName, simplePattern) && + DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, + allowOverwrite) == TCL_ERROR) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DoImport -- + * + * Import a particular command from one namespace into another. Helper + * for Tcl_Import(). + * + * Results: + * Standard Tcl result code. If TCL_ERROR, appends an error message to + * the interpreter result. + * + * Side effects: + * A new command is created in the target namespace unless this is a + * reimport of exactly the same command as before. + * + *---------------------------------------------------------------------- + */ - wasExported = 0; - for (i = 0; i < importNsPtr->numExportPatterns; i++) { - if (Tcl_StringMatch(cmdName, - importNsPtr->exportArrayPtr[i])) { - wasExported = 1; - break; - } - } - if (!wasExported) { - continue; - } +static int +DoImport( + Tcl_Interp *interp, + Namespace *nsPtr, + Tcl_HashEntry *hPtr, + const char *cmdName, + const char *pattern, + Namespace *importNsPtr, + int allowOverwrite) +{ + int i = 0, exported = 0; + Tcl_HashEntry *found; - /* - * Unless there is a name clash, create an imported command - * in the current namespace that refers to cmdPtr. - */ + /* + * The command cmdName in the source namespace matches the pattern. Check + * whether it was exported. If it wasn't, we ignore it. + */ - found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); - if ((found == NULL) || allowOverwrite) { - /* - * Create the imported command and its client data. - * To create the new command in the current namespace, - * generate a fully qualified name for it. - */ + while (!exported && (i < importNsPtr->numExportPatterns)) { + exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); + } + if (!exported) { + return TCL_OK; + } - Tcl_DString ds; + /* + * Unless there is a name clash, create an imported command in the current + * namespace that refers to cmdPtr. + */ - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, "::", 2); - } - Tcl_DStringAppend(&ds, cmdName, -1); + found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); + if ((found == NULL) || allowOverwrite) { + /* + * Create the imported command and its client data. To create the new + * command in the current namespace, generate a fully qualified name + * for it. + */ - /* - * Check whether creating the new imported command in the - * current namespace would create a cycle of imported - * command references. - */ + Tcl_DString ds; + Tcl_Command importedCmd; + ImportedCmdData *dataPtr; + Command *cmdPtr; + ImportRef *refPtr; - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if ((found != NULL) - && cmdPtr->deleteProc == DeleteImportedCmd) { - - Command *overwrite = (Command *) Tcl_GetHashValue(found); - Command *link = cmdPtr; - while (link->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr; - - dataPtr = (ImportedCmdData *) link->objClientData; - link = dataPtr->realCmdPtr; - if (overwrite == link) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "import pattern \"", pattern, - "\" would create a loop containing ", - "command \"", Tcl_DStringValue(&ds), - "\"", (char *) NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - } + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != ((Interp *) interp)->globalNsPtr) { + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, cmdName, -1); + + /* + * Check whether creating the new imported command in the current + * namespace would create a cycle of imported command references. + */ + + cmdPtr = Tcl_GetHashValue(hPtr); + if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { + Command *overwrite = Tcl_GetHashValue(found); + Command *link = cmdPtr; + + while (link->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr = link->objClientData; + + link = dataPtr->realCmdPtr; + if (overwrite == link) { + Tcl_AppendResult(interp, "import pattern \"", pattern, + "\" would create a loop containing command \"", + Tcl_DStringValue(&ds), "\"", NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; } + } + } + + dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, dataPtr, DeleteImportedCmd); + dataPtr->realCmdPtr = cmdPtr; + dataPtr->selfPtr = (Command *) importedCmd; + dataPtr->selfPtr->compileProc = cmdPtr->compileProc; + Tcl_DStringFree(&ds); + + /* + * Create an ImportRef structure describing this new import command + * and add it to the import ref list in the "real" command. + */ + + refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr->importedCmdPtr = (Command *) importedCmd; + refPtr->nextPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = refPtr; + } else { + Command *overwrite = Tcl_GetHashValue(found); - dataPtr = (ImportedCmdData *) - ckalloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&ds), InvokeImportedCmd, - (ClientData) dataPtr, DeleteImportedCmd); - dataPtr->realCmdPtr = cmdPtr; - dataPtr->selfPtr = (Command *) importedCmd; - dataPtr->selfPtr->compileProc = cmdPtr->compileProc; - Tcl_DStringFree(&ds); + if (overwrite->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr = overwrite->objClientData; + if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { /* - * Create an ImportRef structure describing this new import - * command and add it to the import ref list in the "real" - * command. + * Repeated import of same command is acceptable. */ - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); - refPtr->importedCmdPtr = (Command *) importedCmd; - refPtr->nextPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = refPtr; - } else { - Command *overwrite = (Command *) Tcl_GetHashValue(found); - if (overwrite->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr = - (ImportedCmdData *) overwrite->objClientData; - if (dataPtr->realCmdPtr - == (Command *) Tcl_GetHashValue(hPtr)) { - /* Repeated import of same command -- acceptable */ - return TCL_OK; - } - } - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't import command \"", cmdName, - "\": already exists", (char *) NULL); - return TCL_ERROR; - } - } + return TCL_OK; + } + } + Tcl_AppendResult(interp, "can't import command \"", cmdName, + "\": already exists", NULL); + return TCL_ERROR; } return TCL_OK; } @@ -1310,40 +1678,39 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * * Tcl_ForgetImport -- * - * Deletes commands previously imported into the namespace indicated. The - * by namespacePtr, or the current namespace of interp, when - * namespacePtr is NULL. The pattern controls which imported commands - * are deleted. A simple pattern, one without namespace separators, - * matches the current command names of imported commands in the - * namespace. Matching imported commands are deleted. A qualified - * pattern is interpreted as deletion selection on the basis of where - * the command is imported from. The original command and "first link" - * command for each imported command are determined, and they are matched - * against the pattern. A match leads to deletion of the imported - * command. + * Deletes commands previously imported into the namespace indicated. + * The by namespacePtr, or the current namespace of interp, when + * namespacePtr is NULL. The pattern controls which imported commands are + * deleted. A simple pattern, one without namespace separators, matches + * the current command names of imported commands in the namespace. + * Matching imported commands are deleted. A qualified pattern is + * interpreted as deletion selection on the basis of where the command is + * imported from. The original command and "first link" command for each + * imported command are determined, and they are matched against the + * pattern. A match leads to deletion of the imported command. * * Results: - * Returns TCL_ERROR and records an error message in the interp - * result if a namespace qualified pattern refers to a namespace - * that does not exist. Otherwise, returns TCL_OK. + * Returns TCL_ERROR and records an error message in the interp result if + * a namespace qualified pattern refers to a namespace that does not + * exist. Otherwise, returns TCL_OK. * * Side effects: - * May delete commands. + * May delete commands. * *---------------------------------------------------------------------- */ int -Tcl_ForgetImport(interp, namespacePtr, pattern) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace from which - * previously imported commands should be - * removed. NULL for current namespace. */ - CONST char *pattern; /* String pattern indicating which imported - * commands to remove. */ +Tcl_ForgetImport( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace from which + * previously imported commands should be + * removed. NULL for current namespace. */ + const char *pattern) /* String pattern indicating which imported + * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; - CONST char *simplePattern; + const char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -1353,14 +1720,14 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { - nsPtr = (Namespace *) namespacePtr; + nsPtr = (Namespace *) namespacePtr; } /* - * Parse the pattern into its namespace-qualification (if any) - * and the simple pattern. + * Parse the pattern into its namespace-qualification (if any) and the + * simple pattern. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1368,22 +1735,33 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendResult(interp, "unknown namespace in namespace forget pattern \"", - pattern, "\"", (char *) NULL); - return TCL_ERROR; + pattern, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); + return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { /* - * The pattern is simple. - * Delete any imported commands that match it. + * The pattern is simple. Delete any imported commands that match it. */ + if (TclMatchIsTrivial(simplePattern)) { + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if ((hPtr != NULL) + && (cmdPtr = Tcl_GetHashValue(hPtr)) + && (cmdPtr->deleteProc == DeleteImportedCmd)) { + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + } + return TCL_OK; + } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - (hPtr != NULL); - hPtr = Tcl_NextHashEntry(&search)) { - Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { + Command *cmdPtr = Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } @@ -1395,26 +1773,29 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) return TCL_OK; } - /* The pattern was namespace-qualified */ + /* + * The pattern was namespace-qualified. + */ for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Tcl_CmdInfo info; - Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); + Tcl_Command token = Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { - continue; /* Not an imported command */ + continue; /* Not an imported command. */ } if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { /* - * Original not in namespace we're matching. - * Check the first link in the import chain. + * Original not in namespace we're matching. Check the first link + * in the import chain. */ + Command *cmdPtr = (Command *) token; - ImportedCmdData *dataPtr = - (ImportedCmdData *) cmdPtr->objClientData; + ImportedCmdData *dataPtr = cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; + if (firstToken == origin) { continue; } @@ -1438,15 +1819,15 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) * * An imported command is created in an namespace when a "real" command * is imported from another namespace. If the specified command is an - * imported command, this procedure returns the original command it - * refers to. + * imported command, this function returns the original command it refers + * to. * * Results: * If the command was imported into a sequence of namespaces a, b,...,n * where each successive namespace just imports the command from the - * previous namespace, this procedure returns the Tcl_Command token in - * the first namespace, a. Otherwise, if the specified command is not - * an imported command, the procedure returns NULL. + * previous namespace, this function returns the Tcl_Command token in the + * first namespace, a. Otherwise, if the specified command is not an + * imported command, the function returns NULL. * * Side effects: * None. @@ -1455,19 +1836,19 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) */ Tcl_Command -TclGetOriginalCommand(command) - Tcl_Command command; /* The imported command for which the - * original command should be returned. */ +TclGetOriginalCommand( + Tcl_Command command) /* The imported command for which the original + * command should be returned. */ { register Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { - return (Tcl_Command) NULL; + return NULL; } - + while (cmdPtr->deleteProc == DeleteImportedCmd) { - dataPtr = (ImportedCmdData *) cmdPtr->objClientData; + dataPtr = cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; @@ -1478,33 +1859,33 @@ TclGetOriginalCommand(command) * * InvokeImportedCmd -- * - * Invoked by Tcl whenever the user calls an imported command that - * was created by Tcl_Import. Finds the "real" command (in another + * Invoked by Tcl whenever the user calls an imported command that was + * created by Tcl_Import. Finds the "real" command (in another * namespace), and passes control to it. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result object is set to an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int -InvokeImportedCmd(clientData, interp, objc, objv) - ClientData clientData; /* Points to the imported command's +InvokeImportedCmd( + ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; + register ImportedCmdData *dataPtr = clientData; register Command *realCmdPtr = dataPtr->realCmdPtr; return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, - objc, objv); + objc, objv); } /* @@ -1513,11 +1894,11 @@ InvokeImportedCmd(clientData, interp, objc, objv) * DeleteImportedCmd -- * * Invoked by Tcl whenever an imported command is deleted. The "real" - * command keeps a list of all the imported commands that refer to it, - * so those imported commands can be deleted when the real command is - * deleted. This procedure removes the imported command reference from - * the real command's list, and frees up the memory associated with - * the imported command. + * command keeps a list of all the imported commands that refer to it, so + * those imported commands can be deleted when the real command is + * deleted. This function removes the imported command reference from the + * real command's list, and frees up the memory associated with the + * imported command. * * Results: * None. @@ -1529,25 +1910,25 @@ InvokeImportedCmd(clientData, interp, objc, objv) */ static void -DeleteImportedCmd(clientData) - ClientData clientData; /* Points to the imported command's +DeleteImportedCmd( + ClientData clientData) /* Points to the imported command's * ImportedCmdData structure. */ { - ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; + ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; register ImportRef *refPtr, *prevPtr; prevPtr = NULL; - for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; - refPtr = refPtr->nextPtr) { + for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; + refPtr = refPtr->nextPtr) { if (refPtr->importedCmdPtr == selfPtr) { /* * Remove *refPtr from real command's list of imported commands * that refer to it. */ - - if (prevPtr == NULL) { /* refPtr is first in list */ + + if (prevPtr == NULL) { /* refPtr is first in list. */ realCmdPtr->importRefPtr = refPtr->nextPtr; } else { prevPtr->nextPtr = refPtr->nextPtr; @@ -1558,8 +1939,8 @@ DeleteImportedCmd(clientData) } prevPtr = refPtr; } - - panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); + + Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); } /* @@ -1568,162 +1949,157 @@ DeleteImportedCmd(clientData) * TclGetNamespaceForQualName -- * * Given a qualified name specifying a command, variable, or namespace, - * and a namespace in which to resolve the name, this procedure returns - * a pointer to the namespace that contains the item. A qualified name - * consists of the "simple" name of an item qualified by the names of - * an arbitrary number of containing namespace separated by "::"s. If - * the qualified name starts with "::", it is interpreted absolutely - * from the global namespace. Otherwise, it is interpreted relative to - * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr - * is NULL, the name is interpreted relative to the current namespace. - * - * A relative name like "foo::bar::x" can be found starting in either - * the current namespace or in the global namespace. So each search - * usually follows two tracks, and two possible namespaces are - * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to - * NULL, then that path failed. + * and a namespace in which to resolve the name, this function returns a + * pointer to the namespace that contains the item. A qualified name + * consists of the "simple" name of an item qualified by the names of an + * arbitrary number of containing namespace separated by "::"s. If the + * qualified name starts with "::", it is interpreted absolutely from the + * global namespace. Otherwise, it is interpreted relative to the + * namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is + * NULL, the name is interpreted relative to the current namespace. + * + * A relative name like "foo::bar::x" can be found starting in either the + * current namespace or in the global namespace. So each search usually + * follows two tracks, and two possible namespaces are returned. If the + * function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path + * failed. * * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is - * sought only in the global :: namespace. The alternate search - * (also) starting from the global namespace is ignored and - * *altNsPtrPtr is set NULL. - * - * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified - * name is sought only in the namespace specified by cxtNsPtr. The - * alternate search starting from the global namespace is ignored and - * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and - * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and - * the search starts from the namespace specified by cxtNsPtr. - * - * If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace - * components of the qualified name that cannot be found are - * automatically created within their specified parent. This makes sure - * that functions like Tcl_CreateCommand always succeed. There is no - * alternate search path, so *altNsPtrPtr is set NULL. - * - * If "flags" contains FIND_ONLY_NS, the qualified name is treated as a - * reference to a namespace, and the entire qualified name is - * followed. If the name is relative, the namespace is looked up only - * in the current namespace. A pointer to the namespace is stored in - * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if - * FIND_ONLY_NS is not specified, only the leading components are - * treated as namespace names, and a pointer to the simple name of the - * final component is stored in *simpleNamePtr. + * sought only in the global :: namespace. The alternate search (also) + * starting from the global namespace is ignored and *altNsPtrPtr is set + * NULL. + * + * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is + * sought only in the namespace specified by cxtNsPtr. The alternate + * search starting from the global namespace is ignored and *altNsPtrPtr + * is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are + * specified, TCL_GLOBAL_ONLY is ignored and the search starts from the + * namespace specified by cxtNsPtr. + * + * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components + * of the qualified name that cannot be found are automatically created + * within their specified parent. This makes sure that functions like + * Tcl_CreateCommand always succeed. There is no alternate search path, + * so *altNsPtrPtr is set NULL. + * + * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as + * a reference to a namespace, and the entire qualified name is followed. + * If the name is relative, the namespace is looked up only in the + * current namespace. A pointer to the namespace is stored in *nsPtrPtr + * and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS + * is not specified, only the leading components are treated as namespace + * names, and a pointer to the simple name of the final component is + * stored in *simpleNamePtr. * * Results: * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible * namespaces which represent the last (containing) namespace in the - * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr - * to NULL, then the search along that path failed. The procedure also + * qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr + * to NULL, then the search along that path failed. The function also * stores a pointer to the simple name of the final component in * *simpleNamePtr. If the qualified name is "::" or was treated as a - * namespace reference (FIND_ONLY_NS), the procedure stores a pointer + * namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * - * If there is an error, this procedure returns TCL_ERROR. If "flags" + * If there is an error, this function returns TCL_ERROR. If "flags" * contains TCL_LEAVE_ERR_MSG, an error message is returned in the * interpreter's result object. Otherwise, the interpreter's result * object is left unchanged. * - * *actualCxtPtrPtr is set to the actual context namespace. It is - * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr - * is NULL, it is set to the current namespace context. + * *actualCxtPtrPtr is set to the actual context namespace. It is set to + * the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL, + * it is set to the current namespace context. * - * For backwards compatibility with the TclPro byte code loader, - * this function always returns TCL_OK. + * For backwards compatibility with the TclPro byte code loader, this + * function always returns TCL_OK. * * Side effects: - * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be + * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be * created. * *---------------------------------------------------------------------- */ int -TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, - nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) - Tcl_Interp *interp; /* Interpreter in which to find the - * namespace containing qualName. */ - CONST char *qualName; /* A namespace-qualified name of an - * command, variable, or namespace. */ - Namespace *cxtNsPtr; /* The namespace in which to start the - * search for qualName's namespace. If NULL - * start from the current namespace. - * Ignored if TCL_GLOBAL_ONLY is set. */ - int flags; /* Flags controlling the search: an OR'd - * combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, - * CREATE_NS_IF_UNKNOWN, and - * FIND_ONLY_NS. */ - Namespace **nsPtrPtr; /* Address where procedure stores a pointer - * to containing namespace if qualName is - * found starting from *cxtNsPtr or, if - * TCL_GLOBAL_ONLY is set, if qualName is - * found in the global :: namespace. NULL - * is stored otherwise. */ - Namespace **altNsPtrPtr; /* Address where procedure stores a pointer - * to containing namespace if qualName is - * found starting from the global :: - * namespace. NULL is stored if qualName - * isn't found starting from :: or if the - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag - * is set. */ - Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer - * to the actual namespace from which the - * search started. This is either cxtNsPtr, - * the :: namespace if TCL_GLOBAL_ONLY was - * specified, or the current namespace if - * cxtNsPtr was NULL. */ - CONST char **simpleNamePtr; /* Address where procedure stores the - * simple name at end of the qualName, or - * NULL if qualName is "::" or the flag - * FIND_ONLY_NS was specified. */ +TclGetNamespaceForQualName( + Tcl_Interp *interp, /* Interpreter in which to find the namespace + * containing qualName. */ + const char *qualName, /* A namespace-qualified name of an command, + * variable, or namespace. */ + Namespace *cxtNsPtr, /* The namespace in which to start the search + * for qualName's namespace. If NULL start + * from the current namespace. Ignored if + * TCL_GLOBAL_ONLY is set. */ + int flags, /* Flags controlling the search: an OR'd + * combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and + * TCL_CREATE_NS_IF_UNKNOWN. */ + Namespace **nsPtrPtr, /* Address where function stores a pointer to + * containing namespace if qualName is found + * starting from *cxtNsPtr or, if + * TCL_GLOBAL_ONLY is set, if qualName is + * found in the global :: namespace. NULL is + * stored otherwise. */ + Namespace **altNsPtrPtr, /* Address where function stores a pointer to + * containing namespace if qualName is found + * starting from the global :: namespace. + * NULL is stored if qualName isn't found + * starting from :: or if the TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, + * TCL_CREATE_NS_IF_UNKNOWN flag is set. */ + Namespace **actualCxtPtrPtr,/* Address where function stores a pointer to + * the actual namespace from which the search + * started. This is either cxtNsPtr, the :: + * namespace if TCL_GLOBAL_ONLY was specified, + * or the current namespace if cxtNsPtr was + * NULL. */ + const char **simpleNamePtr) /* Address where function stores the simple + * name at end of the qualName, or NULL if + * qualName is "::" or the flag + * TCL_FIND_ONLY_NS was specified. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr = cxtNsPtr; Namespace *altNsPtr; Namespace *globalNsPtr = iPtr->globalNsPtr; - CONST char *start, *end; - CONST char *nsName; + const char *start, *end; + const char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; int len; /* * Determine the context namespace nsPtr in which to start the primary - * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY - * was specified, search from the global namespace. Otherwise, use the + * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was + * specified, search from the global namespace. Otherwise, use the * namespace given in cxtNsPtr, or if that is NULL, use the current - * namespace context. Note that we always treat two or more - * adjacent ":"s as a namespace separator. + * namespace context. Note that we always treat two or more adjacent ":"s + * as a namespace separator. */ if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { - if (iPtr->varFramePtr != NULL) { - nsPtr = iPtr->varFramePtr->nsPtr; - } else { - nsPtr = iPtr->globalNsPtr; - } + nsPtr = iPtr->varFramePtr->nsPtr; } - start = qualName; /* pts to start of qualifying namespace */ + start = qualName; /* Points to start of qualifying + * namespace. */ if ((*qualName == ':') && (*(qualName+1) == ':')) { - start = qualName+2; /* skip over the initial :: */ + start = qualName+2; /* Skip over the initial :: */ while (*start == ':') { - start++; /* skip over a subsequent : */ + start++; /* Skip over a subsequent : */ } - nsPtr = globalNsPtr; - if (*start == '\0') { /* qualName is just two or more ":"s */ - *nsPtrPtr = globalNsPtr; - *altNsPtrPtr = NULL; + nsPtr = globalNsPtr; + if (*start == '\0') { /* qualName is just two or more + * ":"s. */ + *nsPtrPtr = globalNsPtr; + *altNsPtrPtr = NULL; *actualCxtPtrPtr = globalNsPtr; - *simpleNamePtr = start; /* points to empty string */ - return TCL_OK; - } + *simpleNamePtr = start; /* Points to empty string. */ + return TCL_OK; + } } *actualCxtPtrPtr = nsPtr; @@ -1736,8 +2112,8 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, altNsPtr = globalNsPtr; if ((nsPtr == globalNsPtr) - || (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) { - altNsPtr = NULL; + || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) { + altNsPtr = NULL; } /* @@ -1747,38 +2123,37 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, Tcl_DStringInit(&buffer); end = start; while (*start != '\0') { - /* - * Find the next namespace qualifier (i.e., a name ending in "::") - * or the end of the qualified name (i.e., a name ending in "\0"). - * Set len to the number of characters, starting from start, - * in the name; set end to point after the "::"s or at the "\0". - */ + /* + * Find the next namespace qualifier (i.e., a name ending in "::") or + * the end of the qualified name (i.e., a name ending in "\0"). Set + * len to the number of characters, starting from start, in the name; + * set end to point after the "::"s or at the "\0". + */ len = 0; - for (end = start; *end != '\0'; end++) { + for (end = start; *end != '\0'; end++) { if ((*end == ':') && (*(end+1) == ':')) { - end += 2; /* skip over the initial :: */ + end += 2; /* Skip over the initial :: */ while (*end == ':') { - end++; /* skip over the subsequent : */ + end++; /* Skip over the subsequent : */ } - break; /* exit for loop; end is after ::'s */ + break; /* Exit for loop; end is after ::'s */ } - len++; + len++; } - if ((*end == '\0') - && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) { + if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) { /* - * qualName ended with a simple name at start. If FIND_ONLY_NS - * was specified, look this up as a namespace. Otherwise, - * start is the name of a cmd or var and we are done. + * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS + * was specified, look this up as a namespace. Otherwise, start is + * the name of a cmd or var and we are done. */ - - if (flags & FIND_ONLY_NS) { + + if (flags & TCL_FIND_ONLY_NS) { nsName = start; } else { - *nsPtrPtr = nsPtr; - *altNsPtrPtr = altNsPtr; + *nsPtrPtr = nsPtr; + *altNsPtrPtr = altNsPtr; *simpleNamePtr = start; Tcl_DStringFree(&buffer); return TCL_OK; @@ -1787,69 +2162,70 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, /* * start points to the beginning of a namespace qualifier ending * in "::". end points to the start of a name in that namespace - * that might be empty. Copy the namespace qualifier to a - * buffer so it can be null terminated. We can't modify the - * incoming qualName since it may be a string constant. + * that might be empty. Copy the namespace qualifier to a buffer + * so it can be null terminated. We can't modify the incoming + * qualName since it may be a string constant. */ Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, start, len); - nsName = Tcl_DStringValue(&buffer); - } + Tcl_DStringAppend(&buffer, start, len); + nsName = Tcl_DStringValue(&buffer); + } - /* + /* * Look up the namespace qualifier nsName in the current namespace - * context. If it isn't found but CREATE_NS_IF_UNKNOWN is set, - * create that qualifying namespace. This is needed for procedures - * like Tcl_CreateCommand that cannot fail. + * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set, + * create that qualifying namespace. This is needed for functions like + * Tcl_CreateCommand that cannot fail. + */ + + if (nsPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); + if (entryPtr != NULL) { + nsPtr = Tcl_GetHashValue(entryPtr); + } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { + Tcl_CallFrame *framePtr; + + (void) TclPushStackFrame(interp, &framePtr, + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); + + nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, + NULL, NULL); + TclPopStackFrame(interp); + + if (nsPtr == NULL) { + Tcl_Panic("Could not create namespace '%s'", nsName); + } + } else { /* Namespace not found and was not + * created. */ + nsPtr = NULL; + } + } + + /* + * Look up the namespace qualifier in the alternate search path too. */ - if (nsPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); - if (entryPtr != NULL) { - nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); - } else if (flags & CREATE_NS_IF_UNKNOWN) { - Tcl_CallFrame frame; - - (void) Tcl_PushCallFrame(interp, &frame, - (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); - - nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, - (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); - Tcl_PopCallFrame(interp); - - if (nsPtr == NULL) { - panic("Could not create namespace '%s'", nsName); - } - } else { /* namespace not found and wasn't created */ - nsPtr = NULL; - } - } - - /* - * Look up the namespace qualifier in the alternate search path too. - */ - - if (altNsPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); - if (entryPtr != NULL) { - altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); - } else { - altNsPtr = NULL; - } - } - - /* - * If both search paths have failed, return NULL results. - */ - - if ((nsPtr == NULL) && (altNsPtr == NULL)) { - *nsPtrPtr = NULL; - *altNsPtrPtr = NULL; - *simpleNamePtr = NULL; - Tcl_DStringFree(&buffer); - return TCL_OK; - } + if (altNsPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); + if (entryPtr != NULL) { + altNsPtr = Tcl_GetHashValue(entryPtr); + } else { + altNsPtr = NULL; + } + } + + /* + * If both search paths have failed, return NULL results. + */ + + if ((nsPtr == NULL) && (altNsPtr == NULL)) { + *nsPtrPtr = NULL; + *altNsPtrPtr = NULL; + *simpleNamePtr = NULL; + Tcl_DStringFree(&buffer); + return TCL_OK; + } start = end; } @@ -1859,26 +2235,26 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, * variable name, trailing "::"s refer to the cmd or var named {}. */ - if ((flags & FIND_ONLY_NS) - || ((end > start ) && (*(end-1) != ':'))) { - *simpleNamePtr = NULL; /* found namespace name */ + if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { + *simpleNamePtr = NULL; /* Found namespace name. */ } else { - *simpleNamePtr = end; /* found cmd/var: points to empty string */ + *simpleNamePtr = end; /* Found cmd/var: points to empty + * string. */ } /* - * As a special case, if we are looking for a namespace and qualName - * is "" and the current active namespace (nsPtr) is not the global - * namespace, return NULL (no namespace was found). This is because - * namespaces can not have empty names except for the global namespace. + * As a special case, if we are looking for a namespace and qualName is "" + * and the current active namespace (nsPtr) is not the global namespace, + * return NULL (no namespace was found). This is because namespaces can + * not have empty names except for the global namespace. */ - if ((flags & FIND_ONLY_NS) && (*qualName == '\0') + if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0') && (nsPtr != globalNsPtr)) { nsPtr = NULL; } - *nsPtrPtr = nsPtr; + *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); return TCL_OK; @@ -1892,9 +2268,9 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, * Searches for a namespace. * * Results: - * Returns a pointer to the namespace if it is found. Otherwise, - * returns NULL and leaves an error message in the interpreter's - * result object if "flags" contains TCL_LEAVE_ERR_MSG. + * Returns a pointer to the namespace if it is found. Otherwise, returns + * NULL and leaves an error message in the interpreter's result object if + * "flags" contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. @@ -1903,41 +2279,41 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, */ Tcl_Namespace * -Tcl_FindNamespace(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * namespace. */ - CONST char *name; /* Namespace name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set - * or if the name starts with "::". - * Otherwise, points to namespace in which - * to resolve name; if NULL, look up name - * in the current namespace. */ - register int flags; /* Flags controlling namespace lookup: an - * OR'd combination of TCL_GLOBAL_ONLY and - * TCL_LEAVE_ERR_MSG flags. */ +Tcl_FindNamespace( + Tcl_Interp *interp, /* The interpreter in which to find the + * namespace. */ + const char *name, /* Namespace name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or + * if the name starts with "::". Otherwise, + * points to namespace in which to resolve + * name; if NULL, look up name in the current + * namespace. */ + register int flags) /* Flags controlling namespace lookup: an OR'd + * combination of TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - CONST char *dummy; + const char *dummy; /* - * Find the namespace(s) that contain the specified namespace name. - * Add the FIND_ONLY_NS flag to resolve the name all the way down - * to its last component, a namespace. + * Find the namespace(s) that contain the specified namespace name. Add + * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its + * last component, a namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - + flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (nsPtr != NULL) { - return (Tcl_Namespace *) nsPtr; + return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", name, "\"", (char *) NULL); + Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; } @@ -1950,10 +2326,10 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) * Searches for a command. * * Results: - * Returns a token for the command if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL and leaves an - * error message in the interpreter's result object if "flags" - * contains TCL_LEAVE_ERR_MSG. + * Returns a token for the command if it is found. Otherwise, if it can't + * be found or there is an error, returns NULL and leaves an error + * message in the interpreter's result object if "flags" contains + * TCL_LEAVE_ERR_MSG. * * Side effects: * None. @@ -1962,244 +2338,171 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) */ Tcl_Command -Tcl_FindCommand(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * command and to report errors. */ - CONST char *name; /* Command's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which - * to resolve name. If NULL, look up name - * in the current namespace. */ - int flags; /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY - * (look up only in contextNsPtr, or the - * current namespace if contextNsPtr is - * NULL), and TCL_LEAVE_ERR_MSG. If both - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY - * are given, TCL_GLOBAL_ONLY is - * ignored. */ -{ - Interp *iPtr = (Interp*)interp; - - ResolverScheme *resPtr; - Namespace *nsPtr[2], *cxtNsPtr; - CONST char *simpleName; +Tcl_FindCommand( + Tcl_Interp *interp, /* The interpreter in which to find the + * command and to report errors. */ + const char *name, /* Command's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags) /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ +{ + Interp *iPtr = (Interp *) interp; + Namespace *cxtNsPtr; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; - register int search; + const char *simpleName; int result; - Tcl_Command cmd; /* - * If this namespace has a command resolver, then give it first - * crack at the command resolution. If the interpreter has any - * command resolvers, consult them next. The command resolver - * procedures may return a Tcl_Command value, they may signal - * to continue onward, or they may signal an error. + * If this namespace has a command resolver, then give it first crack at + * the command resolution. If the interpreter has any command resolvers, + * consult them next. The command resolver functions may return a + * Tcl_Command value, they may signal to continue onward, or they may + * signal an error. */ - if ((flags & TCL_GLOBAL_ONLY) != 0) { - cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - } - else if (contextNsPtr != NULL) { - cxtNsPtr = (Namespace *) contextNsPtr; - } - else { - cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + + if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) { + cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + } else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } else { + cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { - resPtr = iPtr->resolverPtr; + ResolverScheme *resPtr = iPtr->resolverPtr; + Tcl_Command cmd; - if (cxtNsPtr->cmdResProc) { - result = (*cxtNsPtr->cmdResProc)(interp, name, - (Tcl_Namespace *) cxtNsPtr, flags, &cmd); - } else { - result = TCL_CONTINUE; - } + if (cxtNsPtr->cmdResProc) { + result = (*cxtNsPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } else { + result = TCL_CONTINUE; + } - while (result == TCL_CONTINUE && resPtr) { - if (resPtr->cmdResProc) { - result = (*resPtr->cmdResProc)(interp, name, - (Tcl_Namespace *) cxtNsPtr, flags, &cmd); - } - resPtr = resPtr->nextPtr; - } + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->cmdResProc) { + result = (*resPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } + resPtr = resPtr->nextPtr; + } - if (result == TCL_OK) { - return cmd; - } - else if (result != TCL_CONTINUE) { - return (Tcl_Command) NULL; - } + if (result == TCL_OK) { + return cmd; + } else if (result != TCL_CONTINUE) { + return NULL; + } } /* * Find the namespace(s) that contain the command. */ - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - - /* - * Look for the command in the command table of its namespace. - * Be sure to check both possible search paths: from the specified - * namespace context and from the global namespace. - */ - cmdPtr = NULL; - for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, - simpleName); - if (entryPtr != NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2) + && !(flags & TCL_NAMESPACE_ONLY)) { + int i; + Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; + + (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, + TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if ((realNsPtr != NULL) && (simpleName != NULL)) { + if ((cxtNsPtr == realNsPtr) + || !(realNsPtr->flags & NS_DYING)) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + } } } - } - - if (cmdPtr != NULL) { - return (Tcl_Command) cmdPtr; - } else if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown command \"", name, "\"", (char *) NULL); - } - return (Tcl_Command) NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FindNamespaceVar -- - * - * Searches for a namespace variable, a variable not local to a - * procedure. The variable can be either a scalar or an array, but - * may not be an element of an array. - * - * Results: - * Returns a token for the variable if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL and leaves an - * error message in the interpreter's result object if "flags" - * contains TCL_LEAVE_ERR_MSG. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* + * Next, check along the path. + */ -Tcl_Var -Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * variable. */ - CONST char *name; /* Variable's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which - * to resolve name. If NULL, look up name - * in the current namespace. */ - int flags; /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY - * (look up only in contextNsPtr, or the - * current namespace if contextNsPtr is - * NULL), and TCL_LEAVE_ERR_MSG. If both - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY - * are given, TCL_GLOBAL_ONLY is - * ignored. */ -{ - Interp *iPtr = (Interp*)interp; - ResolverScheme *resPtr; - Namespace *nsPtr[2], *cxtNsPtr; - CONST char *simpleName; - Tcl_HashEntry *entryPtr; - Var *varPtr; - register int search; - int result; - Tcl_Var var; + for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) { + pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; + if (pathNsPtr == NULL) { + continue; + } + (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, + TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if ((realNsPtr != NULL) && (simpleName != NULL) + && !(realNsPtr->flags & NS_DYING)) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + } + } + } - /* - * If this namespace has a variable resolver, then give it first - * crack at the variable resolution. It may return a Tcl_Var - * value, it may signal to continue onward, or it may signal - * an error. - */ - if ((flags & TCL_GLOBAL_ONLY) != 0) { - cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - } - else if (contextNsPtr != NULL) { - cxtNsPtr = (Namespace *) contextNsPtr; - } - else { - cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - } + /* + * If we've still not found the command, look in the global namespace + * as a last resort. + */ - if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { - resPtr = iPtr->resolverPtr; + if (cmdPtr == NULL) { + (void) TclGetNamespaceForQualName(interp, name, NULL, + TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if ((realNsPtr != NULL) && (simpleName != NULL) + && !(realNsPtr->flags & NS_DYING)) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + } + } + } + } else { + Namespace *nsPtr[2]; + register int search; - if (cxtNsPtr->varResProc) { - result = (*cxtNsPtr->varResProc)(interp, name, - (Tcl_Namespace *) cxtNsPtr, flags, &var); - } else { - result = TCL_CONTINUE; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - while (result == TCL_CONTINUE && resPtr) { - if (resPtr->varResProc) { - result = (*resPtr->varResProc)(interp, name, - (Tcl_Namespace *) cxtNsPtr, flags, &var); - } - resPtr = resPtr->nextPtr; - } + /* + * Look for the command in the command table of its namespace. Be sure + * to check both possible search paths: from the specified namespace + * context and from the global namespace. + */ - if (result == TCL_OK) { - return var; - } - else if (result != TCL_CONTINUE) { - return (Tcl_Var) NULL; - } + for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL)) { + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, + simpleName); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + } + } + } } - /* - * Find the namespace(s) that contain the variable. - */ - - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - - /* - * Look for the variable in the variable table of its namespace. - * Be sure to check both possible search paths: from the specified - * namespace context and from the global namespace. - */ - - varPtr = NULL; - for (search = 0; (search < 2) && (varPtr == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, - simpleName); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - } - } + if (cmdPtr != NULL) { + return (Tcl_Command) cmdPtr; } - if (varPtr != NULL) { - return (Tcl_Var) varPtr; - } else if (flags & TCL_LEAVE_ERR_MSG) { + + if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown variable \"", name, "\"", (char *) NULL); + Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } - return (Tcl_Var) NULL; + return NULL; } /* @@ -2211,56 +2514,49 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) * command references that the new command may invalidate. Consider the * following cases that could happen when you add a command "foo" to a * namespace "b": - * 1. It could shadow a command named "foo" at the global scope. - * If it does, all command references in the namespace "b" are + * 1. It could shadow a command named "foo" at the global scope. If + * it does, all command references in the namespace "b" are * suspect. - * 2. Suppose the namespace "b" resides in a namespace "a". - * Then to "a" the new command "b::foo" could shadow another - * command "b::foo" in the global namespace. If so, then all - * command references in "a" are suspect. - * The same checks are applied to all parent namespaces, until we - * reach the global :: namespace. + * 2. Suppose the namespace "b" resides in a namespace "a". Then to + * "a" the new command "b::foo" could shadow another command + * "b::foo" in the global namespace. If so, then all command + * references in "a" * are suspect. + * The same checks are applied to all parent namespaces, until we reach + * the global :: namespace. * * Results: * None. * * Side effects: * If the new command shadows an existing command, the cmdRefEpoch - * counter is incremented in each namespace that sees the shadow. - * This invalidates all command references that were previously cached - * in that namespace. The next time the commands are used, they are - * resolved from scratch. + * counter is incremented in each namespace that sees the shadow. This + * invalidates all command references that were previously cached in that + * namespace. The next time the commands are used, they are resolved from + * scratch. * *---------------------------------------------------------------------- */ void -TclResetShadowedCmdRefs(interp, newCmdPtr) - Tcl_Interp *interp; /* Interpreter containing the new command. */ - Command *newCmdPtr; /* Points to the new command. */ +TclResetShadowedCmdRefs( + Tcl_Interp *interp, /* Interpreter containing the new command. */ + Command *newCmdPtr) /* Points to the new command. */ { char *cmdName; Tcl_HashEntry *hPtr; register Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; - - /* - * This procedure generates an array used to hold the trail list. This - * starts out with stack-allocated space but uses dynamically-allocated - * storage if needed. - */ - - Namespace *(trailStorage[NUM_TRAIL_ELEMS]); - Namespace **trailPtr = trailStorage; int trailFront = -1; - int trailSize = NUM_TRAIL_ELEMS; + int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ + Namespace **trailPtr = (Namespace **) + TclStackAlloc(interp, trailSize * sizeof(Namespace *)); /* - * Start at the namespace containing the new command, and work up - * through the list of parents. Stop just before the global namespace, - * since the global namespace can't "shadow" its own entries. + * Start at the namespace containing the new command, and work up through + * the list of parents. Stop just before the global namespace, since the + * global namespace can't "shadow" its own entries. * * The namespace "trail" list we build consists of the names of each * namespace that encloses the new command, in order from outermost to @@ -2268,200 +2564,164 @@ TclResetShadowedCmdRefs(interp, newCmdPtr) * eventually extends the trail upwards by one namespace, nsPtr. We use * this trail list to see if nsPtr (e.g. "a" in 2. above) could have * now-invalid cached command references. This will happen if nsPtr - * (e.g. "a") contains a sequence of child namespaces (e.g. "b") - * such that there is a identically-named sequence of child namespaces - * starting from :: (e.g. "::b") whose tail namespace contains a command - * also named cmdName. + * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that + * there is a identically-named sequence of child namespaces starting from + * :: (e.g. "::b") whose tail namespace contains a command also named + * cmdName. */ cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); - for (nsPtr = newCmdPtr->nsPtr; - (nsPtr != NULL) && (nsPtr != globalNsPtr); - nsPtr = nsPtr->parentPtr) { - /* + for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ; + nsPtr=nsPtr->parentPtr) { + /* * Find the maximal sequence of child namespaces contained in nsPtr - * such that there is a identically-named sequence of child - * namespaces starting from ::. shadowNsPtr will be the tail of this - * sequence, or the deepest namespace under :: that might contain a - * command now shadowed by cmdName. We check below if shadowNsPtr - * actually contains a command cmdName. + * such that there is a identically-named sequence of child namespaces + * starting from ::. shadowNsPtr will be the tail of this sequence, or + * the deepest namespace under :: that might contain a command now + * shadowed by cmdName. We check below if shadowNsPtr actually + * contains a command cmdName. */ - found = 1; - shadowNsPtr = globalNsPtr; + found = 1; + shadowNsPtr = globalNsPtr; - for (i = trailFront; i >= 0; i--) { - trailNsPtr = trailPtr[i]; - hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, + for (i = trailFront; i >= 0; i--) { + trailNsPtr = trailPtr[i]; + hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, trailNsPtr->name); - if (hPtr != NULL) { - shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); - } else { - found = 0; - break; - } - } - - /* - * If shadowNsPtr contains a command named cmdName, we invalidate - * all of the command refs cached in nsPtr. As a boundary case, + if (hPtr != NULL) { + shadowNsPtr = Tcl_GetHashValue(hPtr); + } else { + found = 0; + break; + } + } + + /* + * If shadowNsPtr contains a command named cmdName, we invalidate all + * of the command refs cached in nsPtr. As a boundary case, * shadowNsPtr is initially :: and we check for case 1. above. */ - if (found) { - hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); - if (hPtr != NULL) { - nsPtr->cmdRefEpoch++; + if (found) { + hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); + if (hPtr != NULL) { + nsPtr->cmdRefEpoch++; + TclInvalidateNsPath(nsPtr); - /* + /* * If the shadowed command was compiled to bytecodes, we * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ - if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) { + if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) { nsPtr->resolverEpoch++; } - } - } + } + } - /* - * Insert nsPtr at the front of the trail list: i.e., at the end - * of the trailPtr array. + /* + * Insert nsPtr at the front of the trail list: i.e., at the end of + * the trailPtr array. */ trailFront++; if (trailFront == trailSize) { - size_t currBytes = trailSize * sizeof(Namespace *); - int newSize = 2*trailSize; - size_t newBytes = newSize * sizeof(Namespace *); - Namespace **newPtr = - (Namespace **) ckalloc((unsigned) newBytes); - - memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); - if (trailPtr != trailStorage) { - ckfree((char *) trailPtr); - } - trailPtr = newPtr; + int newSize = 2 * trailSize; + trailPtr = (Namespace **) TclStackRealloc(interp, + trailPtr, newSize * sizeof(Namespace *)); trailSize = newSize; } trailPtr[trailFront] = nsPtr; } - - /* - * Free any allocated storage. - */ - - if (trailPtr != trailStorage) { - ckfree((char *) trailPtr); - } + TclStackFree(interp, trailPtr); } /* *---------------------------------------------------------------------- * - * GetNamespaceFromObj -- + * TclGetNamespaceFromObj, GetNamespaceFromObj -- * * Gets the namespace specified by the name in a Tcl_Obj. * * Results: - * Returns TCL_OK if the namespace was resolved successfully, and - * stores a pointer to the namespace in the location specified by - * nsPtrPtr. If the namespace can't be found, the procedure stores - * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, - * this procedure returns TCL_ERROR. + * Returns TCL_OK if the namespace was resolved successfully, and stores + * a pointer to the namespace in the location specified by nsPtrPtr. If + * the namespace can't be found, or anything else goes wrong, this + * function returns TCL_ERROR and writes an error message to interp, + * if non-NULL. * * Side effects: * May update the internal representation for the object, caching the - * namespace reference. The next time this procedure is called, the + * namespace reference. The next time this function is called, the * namespace value can be found quickly. * - * If anything goes wrong, an error message is left in the - * interpreter's result object. - * *---------------------------------------------------------------------- */ -static int -GetNamespaceFromObj(interp, objPtr, nsPtrPtr) - Tcl_Interp *interp; /* The current interpreter. */ - Tcl_Obj *objPtr; /* The object to be resolved as the name - * of a namespace. */ - Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ +int +TclGetNamespaceFromObj( + Tcl_Interp *interp, /* The current interpreter. */ + Tcl_Obj *objPtr, /* The object to be resolved as the name of a + * namespace. */ + Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { - Interp *iPtr = (Interp *) interp; - register ResolvedNsName *resNamePtr; - register Namespace *nsPtr; - Namespace *currNsPtr; - CallFrame *savedFramePtr; - int result = TCL_OK; - char *name; + if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) { + const char *name = TclGetString(objPtr); - /* - * If the namespace name is fully qualified, do as if the lookup were - * done from the global namespace; this helps avoid repeated lookups - * of fully qualified names. - */ + if ((name[0] == ':') && (name[1] == ':')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found", name)); + } else { + /* + * Get the current namespace name. + */ - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = NULL; + NamespaceCurrentCmd(NULL, interp, 2, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found in \"%s\"", name, + Tcl_GetStringResult(interp))); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + return TCL_ERROR; } + return TCL_OK; +} - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - - /* - * Get the internal representation, converting to a namespace type if - * needed. The internal representation is a ResolvedNsName that points - * to the actual namespace. - */ - - if (objPtr->typePtr != &tclNsNameType) { - result = tclNsNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; - } - } - resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; +static int +GetNamespaceFromObj( + Tcl_Interp *interp, /* The current interpreter. */ + Tcl_Obj *objPtr, /* The object to be resolved as the name of a + * namespace. */ + Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ +{ + ResolvedNsName *resNamePtr; + Namespace *nsPtr, *refNsPtr; - /* - * Check the context namespace of the resolved symbol to make sure that - * it is fresh. If not, then force another conversion to the namespace - * type, to discard the old rep and create a new one. Note that we - * verify that the namespace id of the cached namespace is the same as - * the id when we cached it; this insures that the namespace wasn't - * deleted and a new one created at the same address. - */ + if (objPtr->typePtr == &nsNameType) { + /* + * Check that the ResolvedNsName is still valid; avoid letting the ref + * cross interps. + */ - nsPtr = NULL; - if ((resNamePtr != NULL) - && (resNamePtr->refNsPtr == currNsPtr) - && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; - } - } - if (nsPtr == NULL) { /* try again */ - result = tclNsNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; - } - resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - if (resNamePtr != NULL) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; - } - } - } - *nsPtrPtr = (Tcl_Namespace *) nsPtr; - - done: - iPtr->varFramePtr = savedFramePtr; - return result; + resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + nsPtr = resNamePtr->nsPtr; + refNsPtr = resNamePtr->refNsPtr; + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && + (!refNsPtr || ((interp == refNsPtr->interp) && + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) { + *nsPtrPtr = (Tcl_Namespace *) nsPtr; + return TCL_OK; + } + } + if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { + resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; + return TCL_OK; + } + return TCL_ERROR; } /* @@ -2469,13 +2729,14 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) * * Tcl_NamespaceObjCmd -- * - * Invoked to implement the "namespace" command that creates, deletes, - * or manipulates Tcl namespaces. Handles the following syntax: + * Invoked to implement the "namespace" command that creates, deletes, or + * manipulates Tcl namespaces. Handles the following syntax: * * namespace children ?name? ?pattern? * namespace code arg * namespace current * namespace delete ?name name...? + * namespace ensemble subcommand ?arg...? * namespace eval name arg ?arg...? * namespace exists name * namespace export ?-clear? ?pattern pattern...? @@ -2493,41 +2754,40 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) * anything goes wrong. * * Side effects: - * Based on the subcommand name (e.g., "import"), this procedure - * dispatches to a corresponding procedure NamespaceXXXCmd defined - * statically in this file. This procedure's side effects depend on - * whatever that subcommand procedure does. If there is an error, this - * procedure returns an error message in the interpreter's result - * object. Otherwise it may return a result in the interpreter's result - * object. + * Based on the subcommand name (e.g., "import"), this function + * dispatches to a corresponding function NamespaceXXXCmd defined + * statically in this file. This function's side effects depend on + * whatever that subcommand function does. If there is an error, this + * function returns an error message in the interpreter's result object. + * Otherwise it may return a result in the interpreter's result object. * *---------------------------------------------------------------------- */ int -Tcl_NamespaceObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp; /* Current interpreter. */ - register int objc; /* Number of arguments. */ - register Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - static CONST char *subCmds[] = { - "children", "code", "current", "delete", +Tcl_NamespaceObjCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *subCmds[] = { + "children", "code", "current", "delete", "ensemble", "eval", "exists", "export", "forget", "import", - "inscope", "origin", "parent", "qualifiers", - "tail", "which", (char *) NULL + "inscope", "origin", "parent", "path", "qualifiers", + "tail", "unknown", "upvar", "which", NULL }; enum NSSubCmdIdx { - NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, + NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, - NSTailIdx, NSWhichIdx + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, + NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx }; int index, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; } /* @@ -2539,53 +2799,65 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) if (result != TCL_OK) { return result; } - + switch (index) { - case NSChildrenIdx: - result = NamespaceChildrenCmd(clientData, interp, objc, objv); - break; - case NSCodeIdx: - result = NamespaceCodeCmd(clientData, interp, objc, objv); - break; - case NSCurrentIdx: - result = NamespaceCurrentCmd(clientData, interp, objc, objv); - break; - case NSDeleteIdx: - result = NamespaceDeleteCmd(clientData, interp, objc, objv); - break; - case NSEvalIdx: - result = NamespaceEvalCmd(clientData, interp, objc, objv); - break; - case NSExistsIdx: - result = NamespaceExistsCmd(clientData, interp, objc, objv); - break; - case NSExportIdx: - result = NamespaceExportCmd(clientData, interp, objc, objv); - break; - case NSForgetIdx: - result = NamespaceForgetCmd(clientData, interp, objc, objv); - break; - case NSImportIdx: - result = NamespaceImportCmd(clientData, interp, objc, objv); - break; - case NSInscopeIdx: - result = NamespaceInscopeCmd(clientData, interp, objc, objv); - break; - case NSOriginIdx: - result = NamespaceOriginCmd(clientData, interp, objc, objv); - break; - case NSParentIdx: - result = NamespaceParentCmd(clientData, interp, objc, objv); - break; - case NSQualifiersIdx: - result = NamespaceQualifiersCmd(clientData, interp, objc, objv); - break; - case NSTailIdx: - result = NamespaceTailCmd(clientData, interp, objc, objv); - break; - case NSWhichIdx: - result = NamespaceWhichCmd(clientData, interp, objc, objv); - break; + case NSChildrenIdx: + result = NamespaceChildrenCmd(clientData, interp, objc, objv); + break; + case NSCodeIdx: + result = NamespaceCodeCmd(clientData, interp, objc, objv); + break; + case NSCurrentIdx: + result = NamespaceCurrentCmd(clientData, interp, objc, objv); + break; + case NSDeleteIdx: + result = NamespaceDeleteCmd(clientData, interp, objc, objv); + break; + case NSEnsembleIdx: + result = NamespaceEnsembleCmd(clientData, interp, objc, objv); + break; + case NSEvalIdx: + result = NamespaceEvalCmd(clientData, interp, objc, objv); + break; + case NSExistsIdx: + result = NamespaceExistsCmd(clientData, interp, objc, objv); + break; + case NSExportIdx: + result = NamespaceExportCmd(clientData, interp, objc, objv); + break; + case NSForgetIdx: + result = NamespaceForgetCmd(clientData, interp, objc, objv); + break; + case NSImportIdx: + result = NamespaceImportCmd(clientData, interp, objc, objv); + break; + case NSInscopeIdx: + result = NamespaceInscopeCmd(clientData, interp, objc, objv); + break; + case NSOriginIdx: + result = NamespaceOriginCmd(clientData, interp, objc, objv); + break; + case NSParentIdx: + result = NamespaceParentCmd(clientData, interp, objc, objv); + break; + case NSPathIdx: + result = NamespacePathCmd(clientData, interp, objc, objv); + break; + case NSQualifiersIdx: + result = NamespaceQualifiersCmd(clientData, interp, objc, objv); + break; + case NSTailIdx: + result = NamespaceTailCmd(clientData, interp, objc, objv); + break; + case NSUpvarIdx: + result = NamespaceUpvarCmd(clientData, interp, objc, objv); + break; + case NSUnknownIdx: + result = NamespaceUnknownCmd(clientData, interp, objc, objv); + break; + case NSWhichIdx: + result = NamespaceWhichCmd(clientData, interp, objc, objv); + break; } return result; } @@ -2596,8 +2868,8 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) * NamespaceChildrenCmd -- * * Invoked to implement the "namespace children" command that returns a - * list containing the fully-qualified names of the child namespaces of - * a given namespace. Handles the following syntax: + * list containing the fully-qualified names of the child namespaces of a + * given namespace. Handles the following syntax: * * namespace children ?name? ?pattern? * @@ -2605,22 +2877,22 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceChildrenCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceChildrenCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); char *pattern = NULL; Tcl_DString buffer; register Tcl_HashEntry *entryPtr; @@ -2632,21 +2904,15 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) */ if (objc == 2) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { - if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { - return TCL_ERROR; - } - if (namespacePtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", Tcl_GetString(objv[2]), - "\" in namespace children command", (char *) NULL); - return TCL_ERROR; - } - nsPtr = (Namespace *) namespacePtr; + if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + return TCL_ERROR; + } + nsPtr = (Namespace *) namespacePtr; } else { Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); - return TCL_ERROR; + return TCL_ERROR; } /* @@ -2655,37 +2921,50 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) Tcl_DStringInit(&buffer); if (objc == 4) { - char *name = Tcl_GetString(objv[3]); - - if ((*name == ':') && (*(name+1) == ':')) { - pattern = name; - } else { - Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); - if (nsPtr != globalNsPtr) { - Tcl_DStringAppend(&buffer, "::", 2); - } - Tcl_DStringAppend(&buffer, name, -1); - pattern = Tcl_DStringValue(&buffer); - } + char *name = TclGetString(objv[3]); + + if ((*name == ':') && (*(name+1) == ':')) { + pattern = name; + } else { + Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); + if (nsPtr != globalNsPtr) { + Tcl_DStringAppend(&buffer, "::", 2); + } + Tcl_DStringAppend(&buffer, name, -1); + pattern = Tcl_DStringValue(&buffer); + } } /* - * Create a list containing the full names of all child namespaces - * whose names match the specified pattern, if any. + * Create a list containing the full names of all child namespaces whose + * names match the specified pattern, if any. */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + listPtr = Tcl_NewListObj(0, NULL); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + unsigned int length = strlen(nsPtr->fullName); + + if (strncmp(pattern, nsPtr->fullName, length) != 0) { + goto searchDone; + } + if (Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern, -1)); + } + goto searchDone; + } entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { - childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); - if ((pattern == NULL) - || Tcl_StringMatch(childNsPtr->fullName, pattern)) { - elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); - Tcl_ListObjAppendElement(interp, listPtr, elemPtr); - } - entryPtr = Tcl_NextHashEntry(&search); + childNsPtr = Tcl_GetHashValue(entryPtr); + if ((pattern == NULL) + || Tcl_StringMatch(childNsPtr->fullName, pattern)) { + elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); + Tcl_ListObjAppendElement(interp, listPtr, elemPtr); + } + entryPtr = Tcl_NextHashEntry(&search); } + searchDone: Tcl_SetObjResult(interp, listPtr); Tcl_DStringFree(&buffer); return TCL_OK; @@ -2706,25 +2985,25 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) * * list ::namespace inscope [namespace current] $arg * - * However, if "arg" is itself a scoped value starting with - * "::namespace inscope", then the result is just "arg". + * However, if "arg" is itself a scoped value starting with "::namespace + * inscope", then the result is just "arg". * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error - * message as the result in the interpreter's result object. + * If anything goes wrong, this function returns an error message as the + * result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceCodeCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceCodeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; @@ -2733,25 +3012,23 @@ NamespaceCodeCmd(dummy, interp, objc, objv) if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg"); - return TCL_ERROR; + return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. */ - arg = Tcl_GetStringFromObj(objv[2], &length); - while (*arg == ':') { - arg++; - length--; - } - if ((*arg == 'n') && (length > 17) - && (strncmp(arg, "namespace", 9) == 0)) { - for (p = (arg + 9); (*p == ' '); p++) { - /* empty body: skip over spaces */ + arg = TclGetStringFromObj(objv[2], &length); + while (*arg == ':') { + arg++; + length--; + } + if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { + for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { + /* empty body: skip over whitespace */ } - if ((*p == 'i') && ((p + 7) <= (arg + length)) - && (strncmp(p, "inscope", 7) == 0)) { + if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { Tcl_SetObjResult(interp, objv[2]); return TCL_OK; } @@ -2759,26 +3036,26 @@ NamespaceCodeCmd(dummy, interp, objc, objv) /* * Otherwise, construct a scoped command by building a list with - * "namespace inscope", the full name of the current namespace, and - * the argument "arg". By constructing a list, we ensure that scoped - * commands are interpreted properly when they are executed later, - * by the "namespace inscope" command. + * "namespace inscope", the full name of the current namespace, and the + * argument "arg". By constructing a list, we ensure that scoped commands + * are interpreted properly when they are executed later, by the + * "namespace inscope" command. */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj("::namespace", -1)); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj("inscope", -1)); + TclNewObj(listPtr); + TclNewLiteralStringObj(objPtr, "::namespace"); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + TclNewLiteralStringObj(objPtr, "inscope"); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { - objPtr = Tcl_NewStringObj("::", -1); + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + TclNewLiteralStringObj(objPtr, "::"); } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - + Tcl_ListObjAppendElement(interp, listPtr, objv[2]); Tcl_SetObjResult(interp, listPtr); @@ -2790,9 +3067,9 @@ NamespaceCodeCmd(dummy, interp, objc, objv) * * NamespaceCurrentCmd -- * - * Invoked to implement the "namespace current" command which returns - * the fully-qualified name of the current namespace. Handles the - * following syntax: + * Invoked to implement the "namespace current" command which returns the + * fully-qualified name of the current namespace. Handles the following + * syntax: * * namespace current * @@ -2800,40 +3077,40 @@ NamespaceCodeCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceCurrentCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceCurrentCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Namespace *currNsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + return TCL_ERROR; } /* - * The "real" name of the global namespace ("::") is the null string, - * but we return "::" for it as a convenience to programmers. Note that - * "" and "::" are treated as synonyms by the namespace code so that it - * is still easy to do things like: + * The "real" name of the global namespace ("::") is the null string, but + * we return "::" for it as a convenience to programmers. Note that "" and + * "::" are treated as synonyms by the namespace code so that it is still + * easy to do things like: * * namespace [namespace current]::bar { ... } */ - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1); + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1); + Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); } return TCL_OK; } @@ -2851,57 +3128,58 @@ NamespaceCurrentCmd(dummy, interp, objc, objv) * Each name identifies a namespace. It may include a sequence of * namespace qualifiers separated by "::"s. If a namespace is found, it * is deleted: all variables and procedures contained in that namespace - * are deleted. If that namespace is being used on the call stack, it - * is kept alive (but logically deleted) until it is removed from the - * call stack: that is, it can no longer be referenced by name but any + * are deleted. If that namespace is being used on the call stack, it is + * kept alive (but logically deleted) until it is removed from the call + * stack: that is, it can no longer be referenced by name but any * currently executing procedure that refers to it is allowed to do so * until the procedure returns. If the namespace can't be found, this - * procedure returns an error. If no namespaces are specified, this + * function returns an error. If no namespaces are specified, this * command does nothing. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Deletes the specified namespaces. If anything goes wrong, this - * procedure returns an error message in the interpreter's - * result object. + * function returns an error message in the interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceDeleteCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceDeleteCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; char *name; register int i; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); + return TCL_ERROR; } /* - * Destroying one namespace may cause another to be destroyed. Break - * this into two passes: first check to make sure that all namespaces on - * the command line are valid, and report any errors. + * Destroying one namespace may cause another to be destroyed. Break this + * into two passes: first check to make sure that all namespaces on the + * command line are valid, and report any errors. */ for (i = 2; i < objc; i++) { - name = Tcl_GetString(objv[i]); - namespacePtr = Tcl_FindNamespace(interp, name, - (Tcl_Namespace *) NULL, /*flags*/ 0); - if (namespacePtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", Tcl_GetString(objv[i]), - "\" in namespace delete command", (char *) NULL); - return TCL_ERROR; - } + name = TclGetString(objv[i]); + namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); + if ((namespacePtr == NULL) + || (((Namespace *)namespacePtr)->flags & NS_KILLED)) { + Tcl_AppendResult(interp, "unknown namespace \"", + TclGetString(objv[i]), + "\" in namespace delete command", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", + TclGetString(objv[i]), NULL); + return TCL_ERROR; + } } /* @@ -2909,12 +3187,11 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) */ for (i = 2; i < objc; i++) { - name = Tcl_GetString(objv[i]); - namespacePtr = Tcl_FindNamespace(interp, name, - (Tcl_Namespace *) NULL, /* flags */ 0); + name = TclGetString(objv[i]); + namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); if (namespacePtr) { - Tcl_DeleteNamespace(namespacePtr); - } + Tcl_DeleteNamespace(namespacePtr); + } } return TCL_OK; } @@ -2924,44 +3201,43 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) * * NamespaceEvalCmd -- * - * Invoked to implement the "namespace eval" command. Executes - * commands in a namespace. If the namespace does not already exist, - * it is created. Handles the following syntax: + * Invoked to implement the "namespace eval" command. Executes commands + * in a namespace. If the namespace does not already exist, it is + * created. Handles the following syntax: * * namespace eval name arg ?arg...? * * If more than one arg argument is specified, the command that is - * executed is the result of concatenating the arguments together with - * a space between each argument. + * executed is the result of concatenating the arguments together with a + * space between each argument. * * Results: - * Returns TCL_OK if the namespace is found and the commands are - * executed successfully. Returns TCL_ERROR if anything goes wrong. + * Returns TCL_OK if the namespace is found and the commands are executed + * successfully. Returns TCL_ERROR if anything goes wrong. * * Side effects: - * Returns the result of the command in the interpreter's result - * object. If anything goes wrong, this procedure returns an error - * message as the result. + * Returns the result of the command in the interpreter's result object. + * If anything goes wrong, this function returns an error message as the + * result. * *---------------------------------------------------------------------- */ static int -NamespaceEvalCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceEvalCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - CallFrame frame; + CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; - char *name; - int length, result; + int result; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + return TCL_ERROR; } /* @@ -2970,74 +3246,79 @@ NamespaceEvalCmd(dummy, interp, objc, objv) */ result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); - if (result != TCL_OK) { - return result; - } /* * If the namespace wasn't found, try to create it. */ - - if (namespacePtr == NULL) { - name = Tcl_GetStringFromObj(objv[2], &length); - namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL); + + if (result == TCL_ERROR) { + char *name = TclGetString(objv[2]); + + namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); if (namespacePtr == NULL) { return TCL_ERROR; } } /* - * Make the specified namespace the current namespace and evaluate - * the command(s). + * Make the specified namespace the current namespace and evaluate the + * command(s). */ - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, - namespacePtr, /*isProcCallFrame*/ 0); + /* This is needed to satisfy GCC 3.3's strict aliasing rules */ + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - frame.objc = objc; - frame.objv = objv; /* ref counts do not need to be incremented here */ + + framePtr->objc = objc; + framePtr->objv = objv; if (objc == 4) { -#ifndef TCL_TIP280 - result = Tcl_EvalObjEx(interp, objv[3], 0); -#else - /* TIP #280 : Make actual argument location available to eval'd script */ - Interp* iPtr = (Interp*) interp; + /* + * TIP #280: Make actual argument location available to eval'd script. + */ + + Interp *iPtr = (Interp *) interp; CmdFrame* invoker = iPtr->cmdFramePtr; int word = 3; + TclArgumentGet (interp, objv[3], &invoker, &word); - result = TclEvalObjEx(interp, objv[3], 0, invoker, word); -#endif + result = TclEvalObjEx(interp, objv[3], 0, invoker, word); } else { /* * More than one argument: 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. + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. + */ + + objPtr = Tcl_ConcatObj(objc-3, objv+3); + + /* + * TIP #280: Make invoking context available to eval'd script. */ - objPtr = Tcl_ConcatObj(objc-3, objv+3); -#ifndef TCL_TIP280 - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); -#else - /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); -#endif } + if (result == TCL_ERROR) { - char msg[256 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", - namespacePtr->fullName, interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace eval \"%.*s%s\" script line %d)", + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine)); } /* * Restore the previous "current" namespace. */ - - Tcl_PopCallFrame(interp); + + TclPopStackFrame(interp); return result; } @@ -3046,9 +3327,9 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * * NamespaceExistsCmd -- * - * Invoked to implement the "namespace exists" command that returns - * true if the given namespace currently exists, and false otherwise. - * Handles the following syntax: + * Invoked to implement the "namespace exists" command that returns true + * if the given namespace currently exists, and false otherwise. Handles + * the following syntax: * * namespace exists name * @@ -3056,35 +3337,28 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceExistsCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceExistsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; - } - - /* - * Check whether the given namespace exists - */ - - if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); return TCL_OK; } @@ -3095,18 +3369,18 @@ NamespaceExistsCmd(dummy, interp, objc, objv) * * Invoked to implement the "namespace export" command that specifies * which commands are exported from a namespace. The exported commands - * are those that can be imported into another namespace using - * "namespace import". Both commands defined in a namespace and - * commands the namespace has imported can be exported by a - * namespace. This command has the following syntax: + * are those that can be imported into another namespace using "namespace + * import". Both commands defined in a namespace and commands the + * namespace has imported can be exported by a namespace. This command + * has the following syntax: * * namespace export ?-clear? ?pattern pattern...? * - * Each pattern may contain "string match"-style pattern matching - * special characters, but the pattern may not include any namespace - * qualifiers: that is, the pattern must specify commands in the - * current (exporting) namespace. The specified patterns are appended - * onto the namespace's list of export patterns. + * Each pattern may contain "string match"-style pattern matching special + * characters, but the pattern may not include any namespace qualifiers: + * that is, the pattern must specify commands in the current (exporting) + * namespace. The specified patterns are appended onto the namespace's + * list of export patterns. * * To reset the namespace's export pattern list, specify the "-clear" * flag. @@ -3118,28 +3392,27 @@ NamespaceExistsCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceExportCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceExportCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); char *pattern, *string; int resetListFirst = 0; int firstArg, patternCt, i, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-clear? ?pattern pattern...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); + return TCL_ERROR; } /* @@ -3148,7 +3421,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) firstArg = 2; if (firstArg < objc) { - string = Tcl_GetString(objv[firstArg]); + string = TclGetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; @@ -3156,18 +3429,22 @@ NamespaceExportCmd(dummy, interp, objc, objv) } /* - * If no pattern arguments are given, and "-clear" isn't specified, - * return the namespace's current export pattern list. + * If no pattern arguments are given, and "-clear" isn't specified, return + * the namespace's current export pattern list. */ patternCt = (objc - firstArg); if (patternCt == 0) { if (firstArg > 2) { return TCL_OK; - } else { /* create list with export patterns */ - Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - result = Tcl_AppendExportList(interp, - (Tcl_Namespace *) currNsPtr, listPtr); + } else { + /* + * Create list with export patterns. + */ + + Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); + result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, + listPtr); if (result != TCL_OK) { return result; } @@ -3179,14 +3456,14 @@ NamespaceExportCmd(dummy, interp, objc, objv) /* * Add each pattern to the namespace's export pattern list. */ - + for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetString(objv[i]); + pattern = TclGetString(objv[i]); result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, ((i == firstArg)? resetListFirst : 0)); - if (result != TCL_OK) { - return result; - } + if (result != TCL_OK) { + return result; + } } return TCL_OK; } @@ -3196,52 +3473,52 @@ NamespaceExportCmd(dummy, interp, objc, objv) * * NamespaceForgetCmd -- * - * Invoked to implement the "namespace forget" command to remove - * imported commands from a namespace. Handles the following syntax: + * Invoked to implement the "namespace forget" command to remove imported + * commands from a namespace. Handles the following syntax: * * namespace forget ?pattern pattern...? * * Each pattern is a name like "foo::*" or "a::b::x*". That is, the - * pattern may include the special pattern matching characters - * recognized by the "string match" command, but only in the command - * name at the end of the qualified name; the special pattern - * characters may not appear in a namespace name. All of the commands - * that match that pattern are checked to see if they have an imported - * command in the current namespace that refers to the matched - * command. If there is an alias, it is removed. - * + * pattern may include the special pattern matching characters recognized + * by the "string match" command, but only in the command name at the end + * of the qualified name; the special pattern characters may not appear + * in a namespace name. All of the commands that match that pattern are + * checked to see if they have an imported command in the current + * namespace that refers to the matched command. If there is an alias, it + * is removed. + * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Imported commands are removed from the current namespace. If - * anything goes wrong, this procedure returns an error message in the + * Imported commands are removed from the current namespace. If anything + * goes wrong, this function returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceForgetCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceForgetCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { char *pattern; register int i, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); + return TCL_ERROR; } for (i = 2; i < objc; i++) { - pattern = Tcl_GetString(objv[i]); - result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); - if (result != TCL_OK) { - return result; - } + pattern = TclGetString(objv[i]); + result = Tcl_ForgetImport(interp, NULL, pattern); + if (result != TCL_OK) { + return result; + } } return TCL_OK; } @@ -3256,39 +3533,42 @@ NamespaceForgetCmd(dummy, interp, objc, objv) * * namespace import ?-force? ?pattern pattern...? * - * Each pattern is a namespace-qualified name like "foo::*", - * "a::b::x*", or "bar::p". That is, the pattern may include the - * special pattern matching characters recognized by the "string match" - * command, but only in the command name at the end of the qualified - * name; the special pattern characters may not appear in a namespace - * name. All of the commands that match the pattern and which are - * exported from their namespace are made accessible from the current - * namespace context. This is done by creating a new "imported command" - * in the current namespace that points to the real command in its - * original namespace; when the imported command is called, it invokes - * the real command. + * Each pattern is a namespace-qualified name like "foo::*", "a::b::x*", + * or "bar::p". That is, the pattern may include the special pattern + * matching characters recognized by the "string match" command, but only + * in the command name at the end of the qualified name; the special + * pattern characters may not appear in a namespace name. All of the + * commands that match the pattern and which are exported from their + * namespace are made accessible from the current namespace context. This + * is done by creating a new "imported command" in the current namespace + * that points to the real command in its original namespace; when the + * imported command is called, it invokes the real command. * * If an imported command conflicts with an existing command, it is * treated as an error. But if the "-force" option is included, then * existing commands are overwritten by the imported commands. - * + * + * If there are no pattern arguments and the "-force" flag isn't given, + * this command returns the list of commands currently imported in + * the current namespace. + * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Adds imported commands to the current namespace. If anything goes - * wrong, this procedure returns an error message in the interpreter's + * wrong, this function returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int -NamespaceImportCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceImportCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int allowOverwrite = 0; char *string, *pattern; @@ -3296,9 +3576,8 @@ NamespaceImportCmd(dummy, interp, objc, objv) int firstArg; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-force? ?pattern pattern...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); + return TCL_ERROR; } /* @@ -3307,11 +3586,34 @@ NamespaceImportCmd(dummy, interp, objc, objv) firstArg = 2; if (firstArg < objc) { - string = Tcl_GetString(objv[firstArg]); + string = TclGetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { allowOverwrite = 1; firstArg++; } + } else { + /* + * When objc == 2, command is just [namespace import]. Introspection + * form to return list of imported commands. + */ + + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Tcl_Obj *listPtr; + + TclNewObj(listPtr); + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Command *cmdPtr = Tcl_GetHashValue(hPtr); + + if (cmdPtr->deleteProc == DeleteImportedCmd) { + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( + Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* @@ -3319,12 +3621,11 @@ NamespaceImportCmd(dummy, interp, objc, objv) */ for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetString(objv[i]); - result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, - allowOverwrite); - if (result != TCL_OK) { - return result; - } + pattern = TclGetString(objv[i]); + result = Tcl_Import(interp, NULL, pattern, allowOverwrite); + if (result != TCL_OK) { + return result; + } } return TCL_OK; } @@ -3336,30 +3637,29 @@ NamespaceImportCmd(dummy, interp, objc, objv) * * Invoked to implement the "namespace inscope" command that executes a * script in the context of a particular namespace. This command is not - * expected to be used directly by programmers; calls to it are - * generated implicitly when programs use "namespace code" commands - * to register callback scripts. Handles the following syntax: + * expected to be used directly by programmers; calls to it are generated + * implicitly when programs use "namespace code" commands to register + * callback scripts. Handles the following syntax: * * namespace inscope name arg ?arg...? * * The "namespace inscope" command is much like the "namespace eval" * command except that it has lappend semantics and the namespace must - * already exist. It treats the first argument as a list, and appends - * any arguments after the first onto the end as proper list elements. - * For example, + * already exist. It treats the first argument as a list, and appends any + * arguments after the first onto the end as proper list elements. For + * example, * - * namespace inscope ::foo a b c d + * namespace inscope ::foo {a b} c d e * * is equivalent to * - * namespace eval ::foo [concat a [list b c d]] + * namespace eval ::foo [concat {a b} [list c d e]] * - * This lappend semantics is important because many callback scripts - * are actually prefixes. + * This lappend semantics is important because many callback scripts are + * actually prefixes. * * Results: - * Returns TCL_OK to indicate success, or TCL_ERROR to indicate - * failure. + * Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure. * * Side effects: * Returns a result in the Tcl interpreter's result object. @@ -3368,88 +3668,88 @@ NamespaceImportCmd(dummy, interp, objc, objv) */ static int -NamespaceInscopeCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceInscopeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; + CallFrame *framePtr, **framePtrPtr; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); - return TCL_ERROR; + return TCL_ERROR; } /* * Resolve the namespace reference. */ - result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); - if (result != TCL_OK) { - return result; - } - if (namespacePtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", Tcl_GetString(objv[2]), - "\" in inscope namespace command", (char *) NULL); - return TCL_ERROR; + if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, - /*isProcCallFrame*/ 0); + framePtrPtr = &framePtr; /* This is needed to satisfy GCC's + * strict aliasing rules. */ + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { - return result; + return result; } + framePtr->objc = objc; + framePtr->objv = objv; + /* - * Execute the command. If there is just one argument, just treat it as - * a script and evaluate it. Otherwise, create a list from the arguments + * Execute the command. If there is just one argument, just treat it as a + * script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. */ if (objc == 4) { - result = Tcl_EvalObjEx(interp, objv[3], 0); + result = Tcl_EvalObjEx(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr, *cmdObjPtr; - - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (i = 4; i < objc; i++) { - result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); - if (result != TCL_OK) { - Tcl_DecrRefCount(listPtr); /* free unneeded obj */ - return result; - } - } + + listPtr = Tcl_NewListObj(0, NULL); + for (i = 4; i < objc; i++) { + if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK) { + Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ + return TCL_ERROR; + } + } concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); - result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); - Tcl_DecrRefCount(listPtr); /* we're done with the list object */ + result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ } + if (result == TCL_ERROR) { - char msg[256 + TCL_INTEGER_SPACE]; - - sprintf(msg, - "\n (in namespace inscope \"%.200s\" script line %d)", - namespacePtr->fullName, interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace inscope \"%.*s%s\" script line %d)", + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine)); } /* * Restore the previous "current" namespace. */ - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } @@ -3472,49 +3772,53 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) * command returns the fully-qualified name of the original command in * the first namespace, a. If "name" does not refer to an alias, its * fully-qualified name is returned. The returned name is stored in the - * interpreter's result object. This procedure returns TCL_OK if + * interpreter's result object. This function returns TCL_OK if * successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error message in - * the interpreter's result object. + * If anything goes wrong, this function returns an error message in the + * interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceOriginCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceOriginCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Command command, origCommand; + Tcl_Obj *resultPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; } command = Tcl_GetCommandFromObj(interp, objv[2]); - if (command == (Tcl_Command) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", Tcl_GetString(objv[2]), - "\"", (char *) NULL); + if (command == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(objv[2]), NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); - if (origCommand == (Tcl_Command) NULL) { + TclNewObj(resultPtr); + if (origCommand == NULL) { /* * The specified command isn't an imported command. Return the - * command's name qualified by the full name of the namespace it - * was defined in. + * command's name qualified by the full name of the namespace it was + * defined in. */ - - Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp)); + + Tcl_GetCommandFullName(interp, command, resultPtr); } else { - Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp)); + Tcl_GetCommandFullName(interp, origCommand, resultPtr); } + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -3533,38 +3837,30 @@ NamespaceOriginCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceParentCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceParentCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *nsPtr; - int result; if (objc == 2) { - nsPtr = Tcl_GetCurrentNamespace(interp); + nsPtr = TclGetCurrentNamespace(interp); } else if (objc == 3) { - result = GetNamespaceFromObj(interp, objv[2], &nsPtr); - if (result != TCL_OK) { - return result; - } - if (nsPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", Tcl_GetString(objv[2]), - "\" in namespace parent command", (char *) NULL); - return TCL_ERROR; - } + if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { + return TCL_ERROR; + } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; } /* @@ -3572,8 +3868,8 @@ NamespaceParentCmd(dummy, interp, objc, objv) */ if (nsPtr->parentPtr != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - nsPtr->parentPtr->fullName, -1); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + nsPtr->parentPtr->fullName, -1)); } return TCL_OK; } @@ -3581,66 +3877,479 @@ NamespaceParentCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * NamespacePathCmd -- + * + * Invoked to implement the "namespace path" command that reads and + * writes the current namespace's command resolution path. Has one + * optional argument: if present, it is a list of named namespaces to set + * the path to, and if absent, the current path should be returned. + * Handles the following syntax: + * + * namespace path ?nsList? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong + * (most notably if the namespace list contains the name of something + * other than a namespace). In the successful-exit case, may set the + * interpreter result to the list of names of the namespaces on the + * current namespace's path. + * + * Side effects: + * May update the namespace path (triggering a recomputing of all command + * names that depend on the namespace for resolution). + * + *---------------------------------------------------------------------- + */ + +static int +NamespacePathCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + int i, nsObjc, result = TCL_ERROR; + Tcl_Obj **nsObjv; + Tcl_Namespace **namespaceList = NULL; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); + return TCL_ERROR; + } + + /* + * If no path is given, return the current path. + */ + + if (objc == 2) { + /* + * Not a very fast way to compute this, but easy to get right. + */ + + for (i=0 ; i<nsPtr->commandPathLength ; i++) { + if (nsPtr->commandPathArray[i].nsPtr != NULL) { + Tcl_AppendElement(interp, + nsPtr->commandPathArray[i].nsPtr->fullName); + } + } + return TCL_OK; + } + + /* + * There is a path given, so parse it into an array of namespace pointers. + */ + + if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { + goto badNamespace; + } + if (nsObjc != 0) { + namespaceList = (Tcl_Namespace **) + TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); + + for (i=0 ; i<nsObjc ; i++) { + if (TclGetNamespaceFromObj(interp, nsObjv[i], + &namespaceList[i]) != TCL_OK) { + goto badNamespace; + } + } + } + + /* + * Now we have the list of valid namespaces, install it as the path. + */ + + TclSetNsPath(nsPtr, nsObjc, namespaceList); + + result = TCL_OK; + badNamespace: + if (namespaceList != NULL) { + TclStackFree(interp, namespaceList); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetNsPath -- + * + * Sets the namespace command name resolution path to the given list of + * namespaces. If the list is empty (of zero length) the path is set to + * empty and the default old-style behaviour of command name resolution + * is used. + * + * Results: + * nothing + * + * Side effects: + * Invalidates the command name resolution caches for any command + * resolved in the given namespace. + * + *---------------------------------------------------------------------- + */ + +void +TclSetNsPath( + Namespace *nsPtr, /* Namespace whose path is to be set. */ + int pathLength, /* Length of pathAry. */ + Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ +{ + if (pathLength != 0) { + NamespacePathEntry *tmpPathArray = (NamespacePathEntry *) + ckalloc(sizeof(NamespacePathEntry) * pathLength); + int i; + + for (i=0 ; i<pathLength ; i++) { + tmpPathArray[i].nsPtr = (Namespace *) pathAry[i]; + tmpPathArray[i].creatorNsPtr = nsPtr; + tmpPathArray[i].prevPtr = NULL; + tmpPathArray[i].nextPtr = + tmpPathArray[i].nsPtr->commandPathSourceList; + if (tmpPathArray[i].nextPtr != NULL) { + tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i]; + } + tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i]; + } + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + } + nsPtr->commandPathArray = tmpPathArray; + } else { + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + } + } + + nsPtr->commandPathLength = pathLength; + nsPtr->cmdRefEpoch++; + nsPtr->resolverEpoch++; +} + +/* + *---------------------------------------------------------------------- + * + * UnlinkNsPath -- + * + * Delete the given namespace's command name resolution path. Only call + * if the path is non-empty. Caller must reset the counter containing the + * path size. + * + * Results: + * nothing + * + * Side effects: + * Deletes the array of path entries and unlinks those path entries from + * the target namespace's list of interested namespaces. + * + *---------------------------------------------------------------------- + */ + +static void +UnlinkNsPath( + Namespace *nsPtr) +{ + int i; + for (i=0 ; i<nsPtr->commandPathLength ; i++) { + NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; + if (nsPathPtr->prevPtr != NULL) { + nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; + } + if (nsPathPtr->nextPtr != NULL) { + nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr; + } + if (nsPathPtr->nsPtr != NULL) { + if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { + nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; + } + } + } + ckfree((char *) nsPtr->commandPathArray); +} + +/* + *---------------------------------------------------------------------- + * + * TclInvalidateNsPath -- + * + * Invalidate the name resolution caches for all names looked up in + * namespaces whose name path includes the given namespace. + * + * Results: + * nothing + * + * Side effects: + * Increments the command reference epoch in each namespace whose path + * includes the given namespace. This causes any cached resolved names + * whose root cacheing context starts at that namespace to be recomputed + * the next time they are used. + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateNsPath( + Namespace *nsPtr) +{ + NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + while (nsPathPtr != NULL) { + if (nsPathPtr->nsPtr != NULL) { + nsPathPtr->creatorNsPtr->cmdRefEpoch++; + } + nsPathPtr = nsPathPtr->nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * * NamespaceQualifiersCmd -- * * Invoked to implement the "namespace qualifiers" command that returns * any leading namespace qualifiers in a string. These qualifiers are * namespace names separated by "::"s. For example, for "::foo::p" this - * command returns "::foo", and for "::" it returns "". This command - * is the complement of the "namespace tail" command. Note that this - * command does not check whether the "namespace" names are, in fact, - * the names of currently defined namespaces. Handles the following - * syntax: + * command returns "::foo", and for "::" it returns "". This command is + * the complement of the "namespace tail" command. Note that this command + * does not check whether the "namespace" names are, in fact, the names + * of currently defined namespaces. Handles the following syntax: * * namespace qualifiers string * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceQualifiersCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceQualifiersCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register char *name, *p; int length; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; + return TCL_ERROR; } /* - * Find the end of the string, then work backward and find - * the start of the last "::" qualifier. + * Find the end of the string, then work backward and find the start of + * the last "::" qualifier. */ - name = Tcl_GetString(objv[2]); + name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { - if ((*p == ':') && (p > name) && (*(p-1) == ':')) { - p -= 2; /* back up over the :: */ + if ((*p == ':') && (p > name) && (*(p-1) == ':')) { + p -= 2; /* Back up over the :: */ while ((p >= name) && (*p == ':')) { - p--; /* back up over the preceeding : */ + p--; /* Back up over the preceeding : */ } break; - } + } } if (p >= name) { - length = p-name+1; - Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length); + length = p-name+1; + Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceUnknownCmd -- + * + * Invoked to implement the "namespace unknown" command (TIP 181) that + * sets or queries a per-namespace unknown command handler. This handler + * is called when command lookup fails (current and global ns). The + * default handler for the global namespace is ::unknown. The default + * handler for other namespaces is to call the global namespace unknown + * handler. Passing an empty list results in resetting the handler to its + * default. + * + * namespace unknown ?handler? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If no handler is specified, returns a result in the interpreter's + * result object, otherwise it sets the unknown handler pointer in the + * current namespace to the script fragment provided. If anything goes + * wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceUnknownCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Namespace *currNsPtr; + Tcl_Obj *resultPtr; + int rc; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?script?"); + return TCL_ERROR; + } + + currNsPtr = TclGetCurrentNamespace(interp); + + if (objc == 2) { + /* + * Introspection - return the current namespace handler. + */ + + resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr); + if (resultPtr == NULL) { + TclNewObj(resultPtr); + } + Tcl_SetObjResult(interp, resultPtr); + } else { + rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]); + if (rc == TCL_OK) { + Tcl_SetObjResult(interp, objv[2]); + } + return rc; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNamespaceUnknownHandler -- + * + * Returns the unknown command handler registered for the given + * namespace. + * + * Results: + * Returns the current unknown command handler, or NULL if none exists + * for the namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_GetNamespaceUnknownHandler( + Tcl_Interp *interp, /* The interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr) /* The namespace. */ +{ + Namespace *currNsPtr = (Namespace *)nsPtr; + + if (currNsPtr->unknownHandlerPtr == NULL && + currNsPtr == ((Interp *)interp)->globalNsPtr) { + /* + * Default handler for global namespace is "::unknown". For all other + * namespaces, it is NULL (which falls back on the global unknown + * handler). + */ + + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + return currNsPtr->unknownHandlerPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetNamespaceUnknownHandler -- + * + * Sets the unknown command handler for the given namespace to the + * command prefix passed. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Sets the namespace unknown command handler. If the passed in handler + * is NULL or an empty list, then the handler is reset to its default. If + * an error occurs, then an error message is left in the interpreter + * result. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetNamespaceUnknownHandler( + Tcl_Interp *interp, /* Interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ + Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ +{ + int lstlen = 0; + Namespace *currNsPtr = (Namespace *)nsPtr; + + /* + * Ensure that we check for errors *first* before we change anything. + */ + + if (handlerPtr != NULL) { + if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { + /* + * Not a list. + */ + + return TCL_ERROR; + } + if (lstlen > 0) { + /* + * We are going to be saving this handler. Increment the reference + * count before decrementing the refcount on the previous handler, + * so that nothing strange can happen if we are told to set the + * handler to the previous value. + */ + + Tcl_IncrRefCount(handlerPtr); + } + } + + /* + * Remove old handler next. + */ + + if (currNsPtr->unknownHandlerPtr != NULL) { + Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr); + } + + /* + * Install the new handler. + */ + + if (lstlen > 0) { + /* + * Just store the handler. It already has the correct reference count. + */ + + currNsPtr->unknownHandlerPtr = handlerPtr; + } else { + /* + * If NULL or an empty list is passed, this resets to the default + * handler. + */ + + currNsPtr->unknownHandlerPtr = NULL; } return TCL_OK; } @@ -3651,13 +4360,13 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) * NamespaceTailCmd -- * * Invoked to implement the "namespace tail" command that returns the - * trailing name at the end of a string with "::" namespace - * qualifiers. These qualifiers are namespace names separated by - * "::"s. For example, for "::foo::p" this command returns "p", and for - * "::" it returns "". This command is the complement of the "namespace - * qualifiers" command. Note that this command does not check whether - * the "namespace" names are, in fact, the names of currently defined - * namespaces. Handles the following syntax: + * trailing name at the end of a string with "::" namespace qualifiers. + * These qualifiers are namespace names separated by "::"s. For example, + * for "::foo::p" this command returns "p", and for "::" it returns "". + * This command is the complement of the "namespace qualifiers" command. + * Note that this command does not check whether the "namespace" names + * are, in fact, the names of currently defined namespaces. Handles the + * following syntax: * * namespace tail string * @@ -3665,45 +4374,120 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceTailCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceTailCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register char *name, *p; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; + return TCL_ERROR; } /* - * Find the end of the string, then work backward and find the - * last "::" qualifier. + * Find the end of the string, then work backward and find the last "::" + * qualifier. */ - name = Tcl_GetString(objv[2]); + name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p > name) { - if ((*p == ':') && (*(p-1) == ':')) { - p++; /* just after the last "::" */ - break; - } + if ((*p == ':') && (*(p-1) == ':')) { + p++; /* Just after the last "::" */ + break; + } } - + if (p >= name) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1); + Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceUpvarCmd -- + * + * Invoked to implement the "namespace upvar" command, that creates + * variables in the current scope linked to variables in another + * namespace. Handles the following syntax: + * + * namespace upvar ns otherVar myVar ?otherVar myVar ...? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Creates new variables in the current scope, linked to the + * corresponding variables in the stipulated nmamespace. If anything goes + * wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceUpvarCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *nsPtr, *savedNsPtr; + Var *otherPtr, *arrayPtr; + char *myName; + + if (objc < 5 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, + "ns otherVar myVar ?otherVar myVar ...?"); + return TCL_ERROR; + } + + if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { + return TCL_ERROR; + } + + objc -= 3; + objv += 3; + + for (; objc>0 ; objc-=2, objv+=2) { + /* + * Locate the other variable + */ + + savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; + otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; + if (otherPtr == NULL) { + return TCL_ERROR; + } + + /* + * Create the new variable and link it to otherPtr. + */ + + myName = TclGetString(objv[1]); + if (TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1) != TCL_OK) { + return TCL_ERROR; + } } + return TCL_OK; } @@ -3723,70 +4507,66 @@ NamespaceTailCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceWhichCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +NamespaceWhichCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - register char *arg; - Tcl_Command cmd; - Tcl_Var variable; - int argIndex, lookup; + static const char *opts[] = { + "-command", "-variable", NULL + }; + int lookupType = 0; + Tcl_Obj *resultPtr; - if (objc < 3) { - badArgs: - Tcl_WrongNumArgs(interp, 2, objv, - "?-command? ?-variable? name"); - return TCL_ERROR; - } + if (objc < 3 || objc > 4) { + badArgs: + Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); + return TCL_ERROR; + } else if (objc == 4) { + /* + * Look for a flag controlling the lookup. + */ - /* - * Look for a flag controlling the lookup. - */ + if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, + &lookupType) != TCL_OK) { + /* + * Preserve old style of error message! + */ - argIndex = 2; - lookup = 0; /* assume command lookup by default */ - arg = Tcl_GetString(objv[2]); - if (*arg == '-') { - if (strncmp(arg, "-command", 8) == 0) { - lookup = 0; - } else if (strncmp(arg, "-variable", 9) == 0) { - lookup = 1; - } else { + Tcl_ResetResult(interp); goto badArgs; } - argIndex = 3; - } - if (objc != (argIndex + 1)) { - goto badArgs; } - switch (lookup) { - case 0: /* -command */ - cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]); - if (cmd == (Tcl_Command) NULL) { - return TCL_OK; /* cmd not found, just return (no error) */ - } - Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp)); - break; + TclNewObj(resultPtr); + switch (lookupType) { + case 0: { /* -command */ + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); + + if (cmd != NULL) { + Tcl_GetCommandFullName(interp, cmd, resultPtr); + } + break; + } + case 1: { /* -variable */ + Tcl_Var var = Tcl_FindNamespaceVar(interp, + TclGetString(objv[objc-1]), NULL, /*flags*/ 0); - case 1: /* -variable */ - arg = Tcl_GetString(objv[argIndex]); - variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, - /*flags*/ 0); - if (variable != (Tcl_Var) NULL) { - Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); - } - break; + if (var != NULL) { + Tcl_GetVariableFullName(interp, var, resultPtr); + } + break; + } } + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -3802,44 +4582,42 @@ NamespaceWhichCmd(dummy, interp, objc, objv) * None. * * Side effects: - * Decrements the ref count of any Namespace structure pointed - * to by the nsName's internal representation. If there are no more - * references to the namespace, it's structure will be freed. + * Decrements the ref count of any Namespace structure pointed to by the + * nsName's internal representation. If there are no more references to + * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void -FreeNsNameInternalRep(objPtr) - register Tcl_Obj *objPtr; /* nsName object with internal - * representation to free */ +FreeNsNameInternalRep( + register Tcl_Obj *objPtr) /* nsName object with internal representation + * to free. */ { - register ResolvedNsName *resNamePtr = - (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + register ResolvedNsName *resNamePtr = (ResolvedNsName *) + objPtr->internalRep.twoPtrValue.ptr1; Namespace *nsPtr; /* - * Decrement the reference count of the namespace. If there are no - * more references, free it up. + * Decrement the reference count of the namespace. If there are no more + * references, free it up. */ - if (resNamePtr != NULL) { - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { + resNamePtr->refCount--; + if (resNamePtr->refCount == 0) { - /* - * Decrement the reference count for the cached namespace. If - * the namespace is dead, and there are no more references to - * it, free it. - */ + /* + * Decrement the reference count for the cached namespace. If the + * namespace is dead, and there are no more references to it, free + * it. + */ - nsPtr = resNamePtr->nsPtr; - nsPtr->refCount--; - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { - NamespaceFree(nsPtr); - } - ckfree((char *) resNamePtr); - } + nsPtr = resNamePtr->nsPtr; + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); + } + ckfree((char *) resNamePtr); } } @@ -3856,25 +4634,23 @@ FreeNsNameInternalRep(objPtr) * * Side effects: * copyPtr's internal rep is set to refer to the same namespace - * referenced by srcPtr's internal rep. Increments the ref count of - * the ResolvedNsName structure used to hold the namespace reference. + * referenced by srcPtr's internal rep. Increments the ref count of the + * ResolvedNsName structure used to hold the namespace reference. * *---------------------------------------------------------------------- */ static void -DupNsNameInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +DupNsNameInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedNsName *resNamePtr = - (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; + register ResolvedNsName *resNamePtr = (ResolvedNsName *) + srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; - if (resNamePtr != NULL) { - resNamePtr->refCount++; - } - copyPtr->typePtr = &tclNsNameType; + copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + resNamePtr->refCount++; + copyPtr->typePtr = &nsNameType; } /* @@ -3882,142 +4658,2344 @@ DupNsNameInternalRep(srcPtr, copyPtr) * * SetNsNameFromAny -- * - * Attempt to generate a nsName internal representation for a - * Tcl object. + * Attempt to generate a nsName internal representation for a Tcl object. * * Results: - * Returns TCL_OK if the value could be converted to a proper - * namespace reference. Otherwise, it returns TCL_ERROR, along - * with an error message in the interpreter's result object. + * Returns TCL_OK if the value could be converted to a proper namespace + * reference. Otherwise, it returns TCL_ERROR, along with an error + * message in the interpreter's result object. * * Side effects: - * If successful, the object is made a nsName object. Its internal rep - * is set to point to a ResolvedNsName, which contains a cached pointer - * to the Namespace. Reference counts are kept on both the - * ResolvedNsName and the Namespace, so we can keep track of their - * usage and free them when appropriate. + * If successful, the object is made a nsName object. Its internal rep is + * set to point to a ResolvedNsName, which contains a cached pointer to + * the Namespace. Reference counts are kept on both the ResolvedNsName + * and the Namespace, so we can keep track of their usage and free them + * when appropriate. * *---------------------------------------------------------------------- */ static int -SetNsNameFromAny(interp, objPtr) - Tcl_Interp *interp; /* Points to the namespace in which to - * resolve name. Also used for error - * reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ +SetNsNameFromAny( + Tcl_Interp *interp, /* Points to the namespace in which to resolve + * name. Also used for error reporting if not + * NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *name; - CONST char *dummy; + const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; + const char *name = TclGetString(objPtr); + + TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, + &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* - * Get the string representation. Make it up-to-date if necessary. + * If we found a namespace, then create a new ResolvedNsName structure + * that holds a reference to it. */ - name = objPtr->bytes; - if (name == NULL) { - name = Tcl_GetString(objPtr); + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + /* + * Our failed lookup proves any previously cached nsName intrep is no + * longer valid. Get rid of it so we no longer waste memory storing + * it, nor time determining its invalidity again and again. + */ + + if (objPtr->typePtr == &nsNameType) { + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; + } + return TCL_ERROR; + } + + nsPtr->refCount++; + resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); + resNamePtr->nsPtr = nsPtr; + if ((name[0] == ':') && (name[1] == ':')) { + resNamePtr->refNsPtr = NULL; + } else { + resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + resNamePtr->refCount = 1; + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + objPtr->typePtr = &nsNameType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceEnsembleCmd -- + * + * Invoked to implement the "namespace ensemble" command that creates and + * manipulates ensembles built on top of namespaces. Handles the + * following syntax: + * + * namespace ensemble name ?dictionary? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Creates the ensemble for the namespace if one did not previously + * exist. Alternatively, alters the way that the ensemble's subcommand => + * implementation prefix is configured. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceEnsembleCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Namespace *nsPtr; + Tcl_Command token; + static const char *subcommands[] = { + "configure", "create", "exists", NULL + }; + enum EnsSubcmds { + ENS_CONFIG, ENS_CREATE, ENS_EXISTS + }; + static const char *createOptions[] = { + "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL + }; + enum EnsCreateOpts { + CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN + }; + static const char *configOptions[] = { + "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL + }; + enum EnsConfigOpts { + CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN + }; + int index; + + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (nsPtr == NULL || nsPtr->flags & NS_DYING) { + if (!Tcl_InterpDeleted(interp)) { + Tcl_AppendResult(interp, + "tried to manipulate ensemble of deleted namespace", NULL); + } + return TCL_ERROR; + } + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum EnsSubcmds) index) { + case ENS_CREATE: { + char *name; + Tcl_DictSearch search; + Tcl_Obj *listObj; + int done, len, allocatedMapFlag = 0; + /* + * Defaults + */ + Tcl_Obj *subcmdObj = NULL; + Tcl_Obj *mapObj = NULL; + int permitPrefix = 1; + Tcl_Obj *unknownObj = NULL; + + objv += 3; + objc -= 3; + + /* + * Work out what name to use for the command to create. If supplied, + * it is either fully specified or relative to the current namespace. + * If not supplied, it is exactly the name of the current namespace. + */ + + name = nsPtr->fullName; + + /* + * Parse the option list, applying type checks as we go. Note that we + * are not incrementing any reference counts in the objects at this + * stage, so the presence of an option multiple times won't cause any + * memory leaks. + */ + + for (; objc>1 ; objc-=2,objv+=2 ) { + if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", + 0, &index) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + switch ((enum EnsCreateOpts) index) { + case CRT_CMD: + name = TclGetString(objv[1]); + continue; + case CRT_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CRT_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdObj; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdObj, &listObj, &done) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (done) { + mapObj = NULL; + continue; + } + do { + Tcl_Obj **listv; + char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (len < 1) { + Tcl_SetResult(interp, + "ensemble subcommand implementations " + "must be non-empty lists", TCL_STATIC); + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_NewListObj(len, listv); + Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); + + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); + } + Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); + } while (!done); + + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; + } + case CRT_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + continue; + case CRT_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + /* + * Create the ensemble. Note that this might delete another ensemble + * linked to the same namespace, so we must be careful. However, we + * should be OK because we only link the namespace into the list once + * we've created it (and after any deletions have occurred.) + */ + + token = Tcl_CreateEnsemble(interp, name, NULL, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + + /* + * Tricky! Must ensure that the result is not shared (command delete + * traces could have corrupted the pristine object that we started + * with). [Snit test rename-1.5] + */ + + Tcl_ResetResult(interp); + Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); + return TCL_OK; + } + + case ENS_EXISTS: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); + return TCL_OK; + + case ENS_CONFIG: + if (objc < 4 || (objc != 5 && objc & 1)) { + Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); + return TCL_ERROR; + } + token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); + if (token == NULL) { + return TCL_ERROR; + } + + if (objc == 5) { + Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + + if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum EnsConfigOpts) index) { + case CONF_SUBCMDS: + Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_MAP: + Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_NAMESPACE: { + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName, + TCL_VOLATILE); + break; + } + case CONF_PREFIX: { + int flags = 0; /* silence gcc 4 warning */ + + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + break; + } + case CONF_UNKNOWN: + Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + } + return TCL_OK; + + } else if (objc == 4) { + /* + * Produce list of all information. + */ + + Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + int flags = 0; /* silence gcc 4 warning */ + + TclNewObj(resultObj); + + /* -map option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_MAP], -1)); + Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -namespace option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, + -1)); + + /* -prefix option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + + /* -subcommands option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); + Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -unknown option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); + Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } else { + Tcl_DictSearch search; + Tcl_Obj *listObj; + int done, len, allocatedMapFlag = 0; + Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, + *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ + int permitPrefix, flags = 0; /* silence gcc 4 warning */ + + Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); + Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); + Tcl_GetEnsembleFlags(NULL, token, &flags); + permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; + + objv += 4; + objc -= 4; + + /* + * Parse the option list, applying type checks as we go. Note that + * we are not incrementing any reference counts in the objects at + * this stage, so the presence of an option multiple times won't + * cause any memory leaks. + */ + + for (; objc>0 ; objc-=2,objv+=2 ) { + if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, + "option", 0, &index) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + switch ((enum EnsConfigOpts) index) { + case CONF_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CONF_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdObj; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdObj, &listObj, &done) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (done) { + mapObj = NULL; + continue; + } + do { + Tcl_Obj **listv; + char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (len < 1) { + Tcl_SetResult(interp, + "ensemble subcommand implementations " + "must be non-empty lists", TCL_STATIC); + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_NewListObj(len, listv); + Tcl_Obj *newCmd = + Tcl_NewStringObj(nsPtr->fullName, -1); + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdObj, + newList); + } + Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); + } while (!done); + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; + } + case CONF_NAMESPACE: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + Tcl_AppendResult(interp, "option -namespace is read-only", + NULL); + return TCL_ERROR; + case CONF_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + continue; + case CONF_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + /* + * Update the namespace now that we've finished the parsing stage. + */ + + flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX + : flags&~TCL_ENSEMBLE_PREFIX); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleFlags(interp, token, flags); + return TCL_OK; + } + + default: + Tcl_Panic("unexpected ensemble command"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEnsemble -- + * + * Create a simple ensemble attached to the given namespace. + * + * Results: + * The token for the command created. + * + * Side effects: + * The ensemble is created and marked for compilation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + EnsembleConfig *ensemblePtr = (EnsembleConfig *) + ckalloc(sizeof(EnsembleConfig)); + Tcl_Obj *nameObj = NULL; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } /* - * Look for the namespace "name" in the current namespace. If there is - * an error parsing the (possibly qualified) name, return an error. - * If the namespace isn't found, we convert the object to an nsName - * object with a NULL ResolvedNsName* internal rep. + * Make the name of the ensemble into a fully qualified name. This might + * allocate a temporary object. */ - TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (!(name[0] == ':' && name[1] == ':')) { + nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); + if (nsPtr->parentPtr == NULL) { + Tcl_AppendStringsToObj(nameObj, name, NULL); + } else { + Tcl_AppendStringsToObj(nameObj, "::", name, NULL); + } + Tcl_IncrRefCount(nameObj); + name = TclGetString(nameObj); + } + + ensemblePtr->nsPtr = nsPtr; + ensemblePtr->epoch = 0; + Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); + ensemblePtr->subcommandArrayPtr = NULL; + ensemblePtr->subcmdList = NULL; + ensemblePtr->subcommandDict = NULL; + ensemblePtr->flags = flags; + ensemblePtr->unknownHandler = NULL; + ensemblePtr->token = Tcl_CreateObjCommand(interp, name, + NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; /* - * If we found a namespace, then create a new ResolvedNsName structure - * that holds a reference to it. + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! */ - if (nsPtr != NULL) { - Namespace *currNsPtr = - (Namespace *) Tcl_GetCurrentNamespace(interp); - - nsPtr->refCount++; - resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); - resNamePtr->nsPtr = nsPtr; - resNamePtr->nsId = nsPtr->nsId; - resNamePtr->refNsPtr = currNsPtr; - resNamePtr->refCount = 1; - } else { - resNamePtr = NULL; + nsPtr->exportLookupEpoch++; + + if (flags & ENSEMBLE_COMPILE) { + ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; + } + + if (nameObj != NULL) { + TclDecrRefCount(nameObj); + } + return ensemblePtr->token; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleSubcommandList -- + * + * Set the subcommand list for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the subcommand list - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleSubcommandList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *subcmdList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (subcmdList != NULL) { + int length; + + if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + subcmdList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->subcmdList; + ensemblePtr->subcmdList = subcmdList; + if (subcmdList != NULL) { + Tcl_IncrRefCount(subcmdList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); } /* - * Free the old internalRep before setting the new one. - * We do this as late as possible to allow the conversion code - * (in particular, Tcl_GetStringFromObj) to use that old internalRep. + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! */ - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; } - objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; - objPtr->typePtr = &tclNsNameType; return TCL_OK; } /* *---------------------------------------------------------------------- * - * UpdateStringOfNsName -- + * Tcl_SetEnsembleMappingDict -- * - * Updates the string representation for a nsName object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Set the mapping dictionary for a particular ensemble. * * Results: - * None. + * Tcl result code (error if command token does not indicate an ensemble + * or the mapping - if non-NULL - is not a dict). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleMappingDict( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *mapDict) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldDict; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (mapDict != NULL) { + int size, done; + Tcl_DictSearch search; + Tcl_Obj *valuePtr; + + if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { + return TCL_ERROR; + } + + for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done); + !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { + Tcl_Obj *cmdPtr; + const char *bytes; + + if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdPtr) != TCL_OK) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + bytes = TclGetString(cmdPtr); + if (bytes[0] != ':' || bytes[1] != ':') { + Tcl_AppendResult(interp, + "ensemble target is not a fully-qualified command", + NULL); + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + + if (size < 1) { + mapDict = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldDict = ensemblePtr->subcommandDict; + ensemblePtr->subcommandDict = mapDict; + if (mapDict != NULL) { + Tcl_IncrRefCount(mapDict); + } + if (oldDict != NULL) { + TclDecrRefCount(oldDict); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleUnknownHandler -- + * + * Set the unknown handler for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the unknown handler - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleUnknownHandler( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *unknownList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (unknownList != NULL) { + int length; + + if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + unknownList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->unknownHandler; + ensemblePtr->unknownHandler = unknownList; + if (unknownList != NULL) { + Tcl_IncrRefCount(unknownList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleFlags -- + * + * Set the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleFlags( + Tcl_Interp *interp, + Tcl_Command token, + int flags) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + int wasCompiled; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; + + /* + * This API refuses to set the ENS_DEAD flag... + */ + + ensemblePtr->flags &= ENS_DEAD; + ensemblePtr->flags |= flags & ~ENS_DEAD; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * If the ENSEMBLE_COMPILE flag status was changed, install or remove the + * compiler function and bump the interpreter's compilation epoch so that + * bytecode gets regenerated. + */ + + if (flags & ENSEMBLE_COMPILE) { + if (!wasCompiled) { + ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; + ((Interp *) interp)->compileEpoch++; + } + } else { + if (wasCompiled) { + ((Command*) ensemblePtr->token)->compileProc = NULL; + ((Interp *) interp)->compileEpoch++; + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleSubcommandList -- + * + * Get the list of subcommands associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The list of subcommands is returned by updating the + * variable pointed to by the last parameter (NULL if this is to be + * derived from the mapping dictionary or the associated namespace's + * exported commands). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleSubcommandList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **subcmdListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *subcmdListPtr = ensemblePtr->subcmdList; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleMappingDict -- + * + * Get the command mapping dictionary associated with a particular + * ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The mapping dict is returned by updating the variable + * pointed to by the last parameter (NULL if none is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleMappingDict( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **mapDictPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *mapDictPtr = ensemblePtr->subcommandDict; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleUnknownHandler -- + * + * Get the unknown handler associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The unknown handler is returned by updating the variable + * pointed to by the last parameter (NULL if no handler is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleUnknownHandler( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **unknownListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *unknownListPtr = ensemblePtr->unknownHandler; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleFlags -- + * + * Get the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The flags are returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleFlags( + Tcl_Interp *interp, + Tcl_Command token, + int *flagsPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *flagsPtr = ensemblePtr->flags; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleNamespace -- + * + * Get the namespace associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). Namespace is returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleNamespace( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Namespace **namespacePtrPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindEnsemble -- + * + * Given a command name, get the ensemble token for it, allowing for + * [namespace import]s. [Bug 1017022] + * + * Results: + * The token for the ensemble command with the given name, or NULL if the + * command either does not exist or is not an ensemble (when an error + * message will be written into the interp if thats non-NULL). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_FindEnsemble( + Tcl_Interp *interp, /* Where to do the lookup, and where to write + * the errors if TCL_LEAVE_ERR_MSG is set in + * the flags. */ + Tcl_Obj *cmdNameObj, /* Name of command to look up. */ + int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags + * are probably not useful. */ +{ + Command *cmdPtr; + + cmdPtr = (Command *) + Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); + if (cmdPtr == NULL) { + return NULL; + } + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + /* + * Reuse existing infrastructure for following import link chains + * rather than duplicating it. + */ + + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), + "\" is not an ensemble command", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + TclGetString(cmdNameObj), NULL); + } + return NULL; + } + } + + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsEnsemble -- + * + * Simple test for ensemble-hood that takes into account imported + * ensemble commands as well. + * + * Results: + * Boolean value + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsEnsemble( + Tcl_Command token) +{ + Command *cmdPtr = (Command *) token; + if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + return 1; + } + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclMakeEnsemble -- + * + * Create an ensemble from a table of implementation commands. The + * ensemble will be subject to (limited) compilation if any of the + * implementation commands are compilable. + * + * Results: + * Handle for the ensemble, or NULL if creation of it fails. + * + * Side effects: + * May advance bytecode compilation epoch. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclMakeEnsemble( + Tcl_Interp *interp, + const char *name, + const EnsembleImplMap map[]) +{ + Tcl_Command ensemble; /* The overall ensemble. */ + Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */ + Tcl_DString buf; + + tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (tclNsPtr == NULL) { + Tcl_Panic("unable to find or create ::tcl namespace!"); + } + Tcl_DStringInit(&buf); + Tcl_DStringAppend(&buf, "::tcl::", -1); + Tcl_DStringAppend(&buf, name, -1); + tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (tclNsPtr == NULL) { + Tcl_Panic("unable to find or create %s namespace!", + Tcl_DStringValue(&buf)); + } + ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr, + TCL_ENSEMBLE_PREFIX); + Tcl_DStringAppend(&buf, "::", -1); + if (ensemble != NULL) { + Tcl_Obj *mapDict; + int i, compile = 0; + + TclNewObj(mapDict); + for (i=0 ; map[i].name != NULL ; i++) { + Tcl_Obj *fromObj, *toObj; + Command *cmdPtr; + + fromObj = Tcl_NewStringObj(map[i].name, -1); + TclNewStringObj(toObj, Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf)); + Tcl_AppendToObj(toObj, map[i].name, -1); + Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, + TclGetString(toObj), map[i].proc, NULL, NULL); + cmdPtr->compileProc = map[i].compileProc; + compile |= (map[i].compileProc != NULL); + } + Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); + if (compile) { + Tcl_SetEnsembleFlags(interp, ensemble, + TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE); + } + } + Tcl_DStringFree(&buf); + + return ensemble; +} + +/* + *---------------------------------------------------------------------- + * + * NsEnsembleImplementationCmd -- + * + * Implements an ensemble of commands (being those exported by a + * namespace other than the global namespace) as a command with the same + * (short) name as the namespace in the parent namespace. + * + * Results: + * A standard Tcl result code. Will be TCL_ERROR if the command is not an + * unambiguous prefix of any command exported by the ensemble's + * namespace. + * + * Side effects: + * Depends on the command within the namespace that gets executed. If the + * ensemble itself returns TCL_ERROR, a descriptive error message will be + * placed in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +static int +NsEnsembleImplementationCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + EnsembleConfig *ensemblePtr = clientData; + /* The ensemble itself. */ + Tcl_Obj **tempObjv; /* Space used to construct the list of + * arguments to pass to the command that + * implements the ensemble subcommand. */ + int result; /* The result of the subcommand execution. */ + Tcl_Obj *prefixObj; /* An object containing the prefix words of + * the command that implements the + * subcommand. */ + Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully + * specified but not yet cached command + * names. */ + Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the + * target command prefix. */ + int prefixObjc; /* Size of prefixObjv of course! */ + int reparseCount = 0; /* Number of reparses. */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); + return TCL_ERROR; + } + + restartEnsembleParse: + if (ensemblePtr->nsPtr->flags & NS_DYING) { + /* + * Don't know how we got here, but make things give up quickly. + */ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_AppendResult(interp, + "ensemble activated for deleted namespace", NULL); + } + return TCL_ERROR; + } + + /* + * Determine if the table of subcommands is right. If so, we can just look + * up in there and go straight to dispatch. + */ + + if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { + /* + * Table of subcommands is still valid; therefore there might be a + * valid cache of discovered information which we can reuse. Do the + * check here, and if we're still valid, we can jump straight to the + * part where we do the invocation of the subcommand. + */ + + if (objv[1]->typePtr == &tclEnsembleCmdType) { + EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.otherValuePtr; + + if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && + ensembleCmd->epoch == ensemblePtr->epoch && + ensembleCmd->token == ensemblePtr->token) { + prefixObj = ensembleCmd->realPrefixObj; + Tcl_IncrRefCount(prefixObj); + goto runResultingSubcommand; + } + } + } else { + BuildEnsembleConfig(ensemblePtr); + ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; + } + + /* + * Look in the hashtable for the subcommand name; this is the fastest way + * of all. + */ + + hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, + TclGetString(objv[1])); + if (hPtr != NULL) { + char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); + + prefixObj = Tcl_GetHashValue(hPtr); + + /* + * Cache for later in the subcommand object. + */ + + MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { + /* + * Could not map, no prefixing, go to unknown/error handling. + */ + + goto unknownOrAmbiguousSubcommand; + } else { + /* + * If we've not already confirmed the command with the hash as part of + * building our export table, we need to scan the sorted array for + * matches. + */ + + char *subcmdName; /* Name of the subcommand, or unique prefix of + * it (will be an error for a non-unique + * prefix). */ + char *fullName = NULL; /* Full name of the subcommand. */ + int stringLength, i; + int tableLength = ensemblePtr->subcommandTable.numEntries; + + subcmdName = TclGetString(objv[1]); + stringLength = objv[1]->length; + for (i=0 ; i<tableLength ; i++) { + register int cmp = strncmp(subcmdName, + ensemblePtr->subcommandArrayPtr[i], + (unsigned) stringLength); + + if (cmp == 0) { + if (fullName != NULL) { + /* + * Since there's never the exact-match case to worry about + * (hash search filters this), getting here indicates that + * our subcommand is an ambiguous prefix of (at least) two + * exported subcommands, which is an error case. + */ + + goto unknownOrAmbiguousSubcommand; + } + fullName = ensemblePtr->subcommandArrayPtr[i]; + } else if (cmp < 0) { + /* + * Because we are searching a sorted table, we can now stop + * searching because we have gone past anything that could + * possibly match. + */ + + break; + } + } + if (fullName == NULL) { + /* + * The subcommand is not a prefix of anything, so bail out! + */ + + goto unknownOrAmbiguousSubcommand; + } + hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); + if (hPtr == NULL) { + Tcl_Panic("full name %s not found in supposedly synchronized hash", + fullName); + } + prefixObj = Tcl_GetHashValue(hPtr); + + /* + * Cache for later in the subcommand object. + */ + + MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + } + + Tcl_IncrRefCount(prefixObj); + runResultingSubcommand: + + /* + * Do the real work of execution of the subcommand by building an array of + * objects (note that this is potentially not the same length as the + * number of arguments to this ensemble command), populating it and then + * feeding it back through the main command-lookup engine. In theory, we + * could look up the command in the namespace ourselves, as we already + * have the namespace in which it is guaranteed to exist, but we don't do + * that (the cacheing of the command object used should help with that.) + */ + + { + Interp *iPtr = (Interp *) interp; + int isRootEnsemble; + Tcl_Obj *copyObj; + + /* + * Get the prefix that we're rewriting to. To do this we need to + * ensure that the internal representation of the list does not change + * so that we can safely keep the internal representations of the + * elements in the list. + */ + + copyObj = TclListObjCopy(NULL, prefixObj); + TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + + /* + * Record what arguments the script sent in so that things like + * Tcl_WrongNumArgs can give the correct error message. + */ + + isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; + } else { + int ni = iPtr->ensembleRewrite.numInsertedObjs; + + if (ni < 2) { + iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; + } else { + iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; + } + } + + /* + * Allocate a workspace and build the list of arguments to pass to the + * target command in it. + */ + + tempObjv = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc)); + memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); + memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + + /* + * Hand off to the target command. + */ + + result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, + TCL_EVAL_INVOKE); + + /* + * Clean up. + */ + + TclStackFree(interp, tempObjv); + Tcl_DecrRefCount(copyObj); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + } + Tcl_DecrRefCount(prefixObj); + return result; + + unknownOrAmbiguousSubcommand: + /* + * Have not been able to match the subcommand asked for with a real + * subcommand that we export. See whether a handler has been registered + * for dealing with this situation. Will only call (at most) once for any + * particular ensemble invocation. + */ + + if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { + int paramc, i; + Tcl_Obj **paramv, *unknownCmd, *ensObj; + + unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); + TclNewObj(ensObj); + Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); + Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); + for (i=1 ; i<objc ; i++) { + Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); + } + TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); + Tcl_Preserve(ensemblePtr); + Tcl_IncrRefCount(unknownCmd); + result = Tcl_EvalObjv(interp, paramc, paramv, 0); + if (result == TCL_OK) { + prefixObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(prefixObj); + Tcl_DecrRefCount(unknownCmd); + Tcl_Release(ensemblePtr); + Tcl_ResetResult(interp); + if (ensemblePtr->flags & ENS_DEAD) { + Tcl_DecrRefCount(prefixObj); + Tcl_SetResult(interp, + "unknown subcommand handler deleted its ensemble", + TCL_STATIC); + return TCL_ERROR; + } + + /* + * Namespace is still there. Check if the result is a valid list. + * If it is, and it is non-empty, that list is what we are using + * as our replacement. + */ + + if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { + Tcl_DecrRefCount(prefixObj); + Tcl_AddErrorInfo(interp, "\n while parsing result of " + "ensemble unknown subcommand handler"); + return TCL_ERROR; + } + if (prefixObjc > 0) { + goto runResultingSubcommand; + } + + /* + * Namespace alive & empty result => reparse. + */ + + Tcl_DecrRefCount(prefixObj); + goto restartEnsembleParse; + } + if (!Tcl_InterpDeleted(interp)) { + if (result != TCL_ERROR) { + char buf[TCL_INTEGER_SPACE]; + + Tcl_ResetResult(interp); + Tcl_SetResult(interp, + "unknown subcommand handler returned bad code: ", + TCL_STATIC); + switch (result) { + case TCL_RETURN: + Tcl_AppendResult(interp, "return", NULL); + break; + case TCL_BREAK: + Tcl_AppendResult(interp, "break", NULL); + break; + case TCL_CONTINUE: + Tcl_AppendResult(interp, "continue", NULL); + break; + default: + sprintf(buf, "%d", result); + Tcl_AppendResult(interp, buf, NULL); + } + Tcl_AddErrorInfo(interp, "\n result of " + "ensemble unknown subcommand handler: "); + Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + } else { + Tcl_AddErrorInfo(interp, + "\n (ensemble unknown subcommand handler)"); + } + } + Tcl_DecrRefCount(unknownCmd); + Tcl_Release(ensemblePtr); + return TCL_ERROR; + } + + /* + * We cannot determine what subcommand to hand off to, so generate a + * (standard) failure message. Note the one odd case compared with + * standard ensemble-like command, which is where a namespace has no + * exported commands at all... + */ + + Tcl_ResetResult(interp); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + TclGetString(objv[1]), NULL); + if (ensemblePtr->subcommandTable.numEntries == 0) { + Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), + "\": namespace ", ensemblePtr->nsPtr->fullName, + " does not export any commands", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, "unknown ", + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), + "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); + if (ensemblePtr->subcommandTable.numEntries == 1) { + Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); + } else { + int i; + + for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { + Tcl_AppendResult(interp, + ensemblePtr->subcommandArrayPtr[i], ", ", NULL); + } + Tcl_AppendResult(interp, "or ", + ensemblePtr->subcommandArrayPtr[i], NULL); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", + TclGetString(objv[1]), NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeCachedEnsembleCommand -- + * + * Cache what we've computed so far; it's not nice to repeatedly copy + * strings about. Note that to do this, we start by deleting any old + * representation that there was (though if it was an out of date + * ensemble rep, we can skip some of the deallocation process.) + * + * Results: + * None * * Side effects: - * The object's string is set to a copy of the fully qualified - * namespace name. + * Alters the internal representation of the first object parameter. * *---------------------------------------------------------------------- */ static void -UpdateStringOfNsName(objPtr) - register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ +MakeCachedEnsembleCommand( + Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, + const char *subcommandName, + Tcl_Obj *prefixObjPtr) { - ResolvedNsName *resNamePtr = - (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - register Namespace *nsPtr; - char *name = ""; + register EnsembleCmdRep *ensembleCmd; int length; - if ((resNamePtr != NULL) - && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; - } - if (nsPtr != NULL) { - name = nsPtr->fullName; - } + if (objPtr->typePtr == &tclEnsembleCmdType) { + ensembleCmd = objPtr->internalRep.otherValuePtr; + Tcl_DecrRefCount(ensembleCmd->realPrefixObj); + ensembleCmd->nsPtr->refCount--; + if ((ensembleCmd->nsPtr->refCount == 0) + && (ensembleCmd->nsPtr->flags & NS_DEAD)) { + NamespaceFree(ensembleCmd->nsPtr); + } + ckfree(ensembleCmd->fullSubcmdName); + } else { + /* + * Kill the old internal rep, and replace it with a brand new one of + * our own. + */ + + TclFreeIntRep(objPtr); + ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); + objPtr->internalRep.otherValuePtr = ensembleCmd; + objPtr->typePtr = &tclEnsembleCmdType; } /* - * The following sets the string rep to an empty string on the heap - * if the internal rep is NULL. + * Populate the internal rep. */ - length = strlen(name); - if (length == 0) { - objPtr->bytes = tclEmptyStringRep; + ensembleCmd->nsPtr = ensemblePtr->nsPtr; + ensembleCmd->epoch = ensemblePtr->epoch; + ensembleCmd->token = ensemblePtr->token; + ensemblePtr->nsPtr->refCount++; + ensembleCmd->realPrefixObj = prefixObjPtr; + length = strlen(subcommandName)+1; + ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); + memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); + Tcl_IncrRefCount(ensembleCmd->realPrefixObj); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsembleConfig -- + * + * Destroys the data structure used to represent an ensemble. This is + * called when the ensemble's command is deleted (which happens + * automatically if the ensemble's namespace is deleted.) Maintainers + * should note that ensembles should be deleted by deleting their + * commands. + * + * Results: + * None. + * + * Side effects: + * Memory is (eventually) deallocated. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteEnsembleConfig( + ClientData clientData) +{ + EnsembleConfig *ensemblePtr = clientData; + Namespace *nsPtr = ensemblePtr->nsPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hEnt; + + /* + * Unlink from the ensemble chain if it has not been marked as having been + * done already. + */ + + if (ensemblePtr->next != ensemblePtr) { + EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; + if (ensPtr == ensemblePtr) { + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; + } else { + while (ensPtr != NULL) { + if (ensPtr->next == ensemblePtr) { + ensPtr->next = ensemblePtr->next; + break; + } + ensPtr = ensPtr->next; + } + } + } + + /* + * Mark the namespace as dead so code that uses Tcl_Preserve() can tell + * whether disaster happened anyway. + */ + + ensemblePtr->flags |= ENS_DEAD; + + /* + * Kill the pointer-containing fields. + */ + + if (ensemblePtr->subcommandTable.numEntries != 0) { + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); + while (hEnt != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt); + + Tcl_DecrRefCount(prefixObj); + hEnt = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); + if (ensemblePtr->subcmdList != NULL) { + Tcl_DecrRefCount(ensemblePtr->subcmdList); + } + if (ensemblePtr->subcommandDict != NULL) { + Tcl_DecrRefCount(ensemblePtr->subcommandDict); + } + if (ensemblePtr->unknownHandler != NULL) { + Tcl_DecrRefCount(ensemblePtr->unknownHandler); + } + + /* + * Arrange for the structure to be reclaimed. Note that this is complex + * because we have to make sure that we can react sensibly when an + * ensemble is deleted during the process of initialising the ensemble + * (especially the unknown callback.) + */ + + Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * BuildEnsembleConfig -- + * + * Create the internal data structures that describe how an ensemble + * looks, being a hash mapping from the full command name to the Tcl list + * that describes the implementation prefix words, and a sorted array of + * all the full command names to allow for reasonably efficient + * unambiguous prefix handling. + * + * Results: + * None. + * + * Side effects: + * Reallocates and rebuilds the hash table and array stored at the + * ensemblePtr argument. For large ensembles or large namespaces, this is + * a potentially expensive operation. + * + *---------------------------------------------------------------------- + */ + +static void +BuildEnsembleConfig( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashSearch search; /* Used for scanning the set of commands in + * the namespace that backs up this + * ensemble. */ + int i, j, isNew; + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + Tcl_HashEntry *hPtr; + + if (hash->numEntries != 0) { + /* + * Remove pre-existing table. + */ + + Tcl_HashSearch search; + + ckfree((char *) ensemblePtr->subcommandArrayPtr); + hPtr = Tcl_FirstHashEntry(hash, &search); + while (hPtr != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(hash); + Tcl_InitHashTable(hash, TCL_STRING_KEYS); + } + + /* + * See if we've got an export list. If so, we will only export exactly + * those commands, which may be either implemented by the prefix in the + * subcommandDict or mapped directly onto the namespace's commands. + */ + + if (ensemblePtr->subcmdList != NULL) { + Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; + int subcmdc; + + TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, + &subcmdv); + for (i=0 ; i<subcmdc ; i++) { + char *name = TclGetString(subcmdv[i]); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + + /* + * Skip non-unique cases. + */ + + if (!isNew) { + continue; + } + + /* + * Look in our dictionary (if present) for the command. + */ + + if (ensemblePtr->subcommandDict != NULL) { + Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], + &target); + if (target != NULL) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * Not there, so map onto the namespace. Note in this case that we + * do not guarantee that the command is actually there; that is + * the programmer's responsibility (or [::unknown] of course). + */ + + cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + if (ensemblePtr->nsPtr->parentPtr != NULL) { + Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); + } else { + Tcl_AppendStringsToObj(cmdObj, name, NULL); + } + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } else if (ensemblePtr->subcommandDict != NULL) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } } else { - objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); - memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); - objPtr->bytes[length] = '\0'; + /* + * Discover what commands are actually exported by the namespace. + * What we have is an array of patterns and a hash table whose keys + * are the command names exported by the namespace (the contents do + * not matter here.) We must find out what commands are actually + * exported by filtering each command in the namespace against each of + * the patterns in the export list. Note that we use an intermediate + * hash table to make memory management easier, and because that makes + * exact matching far easier too. + * + * Suggestion for future enhancement: compute the unique prefixes and + * place them in the hash too, which should make for even faster + * matching. + */ + + hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); + for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { + char *nsCmdName = /* Name of command in namespace. */ + Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); + + for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { + if (Tcl_StringMatch(nsCmdName, + ensemblePtr->nsPtr->exportArrayPtr[i])) { + hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); + + /* + * Remember, hash entries have a full reference to the + * substituted part of the command (as a list) as their + * content! + */ + + if (isNew) { + Tcl_Obj *cmdObj, *cmdPrefixObj; + + TclNewObj(cmdObj); + Tcl_AppendStringsToObj(cmdObj, + ensemblePtr->nsPtr->fullName, + (ensemblePtr->nsPtr->parentPtr ? "::" : ""), + nsCmdName, NULL); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + break; + } + } + } + } + + if (hash->numEntries == 0) { + ensemblePtr->subcommandArrayPtr = NULL; + return; + } + + /* + * Create a sorted array of all subcommands in the ensemble; hash tables + * are all very well for a quick look for an exact match, but they can't + * determine things like whether a string is a prefix of another (not + * without lots of preparation anyway) and they're no good for when we're + * generating the error message either. + * + * We do this by filling an array with the names (we use the hash keys + * directly to save a copy, since any time we change the array we change + * the hash too, and vice versa) and running quicksort over the array. + */ + + ensemblePtr->subcommandArrayPtr = (char **) + ckalloc(sizeof(char *) * hash->numEntries); + + /* + * Fill array from both ends as this makes us less likely to end up with + * performance problems in qsort(), which is good. Note that doing this + * makes this code much more opaque, but the naive alternatve: + * + * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; + * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { + * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); + * } + * + * can produce long runs of precisely ordered table entries when the + * commands in the namespace are declared in a sorted fashion (an ordering + * some people like) and the hashing functions (or the command names + * themselves) are fairly unfortunate. By filling from both ends, it + * requires active malice (and probably a debugger) to get qsort() to have + * awful runtime behaviour. + */ + + i = 0; + j = hash->numEntries; + hPtr = Tcl_FirstHashEntry(hash, &search); + while (hPtr != NULL) { + ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); + hPtr = Tcl_NextHashEntry(&search); + if (hPtr == NULL) { + break; + } + ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); + hPtr = Tcl_NextHashEntry(&search); + } + if (hash->numEntries > 1) { + qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries, + sizeof(char *), NsEnsembleStringOrder); } +} + +/* + *---------------------------------------------------------------------- + * + * NsEnsembleStringOrder -- + * + * Helper function to compare two pointers to two strings for use with + * qsort(). + * + * Results: + * -1 if the first string is smaller, 1 if the second string is smaller, + * and 0 if they are equal. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NsEnsembleStringOrder( + const void *strPtr1, + const void *strPtr2) +{ + return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); +} + +/* + *---------------------------------------------------------------------- + * + * FreeEnsembleCmdRep -- + * + * Destroys the internal representation of a Tcl_Obj that has been + * holding information about a command in an ensemble. + * + * Results: + * None. + * + * Side effects: + * Memory is deallocated. If this held the last reference to a + * namespace's main structure, that main structure will also be + * destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeEnsembleCmdRep( + Tcl_Obj *objPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + + Tcl_DecrRefCount(ensembleCmd->realPrefixObj); + ckfree(ensembleCmd->fullSubcmdName); + ensembleCmd->nsPtr->refCount--; + if ((ensembleCmd->nsPtr->refCount == 0) + && (ensembleCmd->nsPtr->flags & NS_DEAD)) { + NamespaceFree(ensembleCmd->nsPtr); + } + ckfree((char *) ensembleCmd); +} + +/* + *---------------------------------------------------------------------- + * + * DupEnsembleCmdRep -- + * + * Makes one Tcl_Obj into a copy of another that is a subcommand of an + * ensemble. + * + * Results: + * None. + * + * Side effects: + * Memory is allocated, and the namespace that the ensemble is built on + * top of gains another reference. + * + *---------------------------------------------------------------------- + */ + +static void +DupEnsembleCmdRep( + Tcl_Obj *objPtr, + Tcl_Obj *copyPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) + ckalloc(sizeof(EnsembleCmdRep)); + int length = strlen(ensembleCmd->fullSubcmdName); + + copyPtr->typePtr = &tclEnsembleCmdType; + copyPtr->internalRep.otherValuePtr = ensembleCopy; + ensembleCopy->nsPtr = ensembleCmd->nsPtr; + ensembleCopy->epoch = ensembleCmd->epoch; + ensembleCopy->token = ensembleCmd->token; + ensembleCopy->nsPtr->refCount++; + ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; + Tcl_IncrRefCount(ensembleCopy->realPrefixObj); + ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); + memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, + (unsigned) length+1); +} + +/* + *---------------------------------------------------------------------- + * + * StringOfEnsembleCmdRep -- + * + * Creates a string representation of a Tcl_Obj that holds a subcommand + * of an ensemble. + * + * Results: + * None. + * + * Side effects: + * The object gains a string (UTF-8) representation. + * + *---------------------------------------------------------------------- + */ + +static void +StringOfEnsembleCmdRep( + Tcl_Obj *objPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + int length = strlen(ensembleCmd->fullSubcmdName); + objPtr->length = length; + objPtr->bytes = ckalloc((unsigned) length+1); + memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo field to describe the command that + * was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo and the line + * number stored internally in the interpreter is set. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_LogCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to log information. */ + const char *script, /* First character in script containing + * command (must be <= command). */ + const char *command, /* First character in command that generated + * the error. */ + int length) /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ +{ + register const char *p; + Interp *iPtr = (Interp *) interp; + int overflow, limit = 150; + Var *varPtr, *arrayPtr; + + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this command; + * we shouldn't add anything more. + */ + + return; + } + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + if (length < 0) { + length = strlen(command); + } + overflow = (length > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) + ? "while executing" : "invoked from within"), + (overflow ? limit : length), command, (overflow ? "..." : ""))); + + varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, + NULL, 0, 0, &arrayPtr); + if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { + /* + * Should not happen. + */ + + return; + } else { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, + (char *) varPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + + if (tracePtr->traceProc != EstablishErrorInfoTraces) { + /* + * The most recent trace set on ::errorInfo is not the one the + * core itself puts on last. This means some other code is tracing + * the variable, and the additional trace(s) might be write traces + * that expect the timing of writes to ::errorInfo that existed + * Tcl releases before 8.5. To satisfy that compatibility need, we + * write the current -errorinfo value to the ::errorInfo variable. + */ + + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + TCL_GLOBAL_ONLY); + } + } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |