diff options
Diffstat (limited to 'generic/tclNamesp.c')
| -rw-r--r-- | generic/tclNamesp.c | 6976 |
1 files changed, 2000 insertions, 4976 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 5dbffc6..77352a1 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1,264 +1,164 @@ /* * 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. Also includes the - * TIP#112 ensemble machinery. + * 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. * * 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" /* - * Thread-local storage used to avoid having a global lock on data that is not - * limited to a single interpreter. + * 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. */ -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; +#define FIND_ONLY_NS 0x1000 /* - * 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. + * Initial size of stack allocated space for tail list - used when resetting + * shadowed command references in the functin: TclResetShadowedCmdRefs. */ -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; +#define NUM_TRAIL_ELEMS 5 /* - * 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. + * Count of the number of namespaces created. This value is used as a + * unique id for each namespace. */ -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. */ +static long numNsCreated = 0; +TCL_DECLARE_MUTEX(nsMutex) /* - * Declarations for functions local to this file: + * 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. */ -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); +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; /* - * 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 = { + * 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 = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ + UpdateStringOfNsName, /* 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 function is called to initialize all the structures that are used - * by namespaces on a per-process basis. + * This procedure is called to initialize all the structures that + * are used by namespaces on a per-process basis. * * Results: * None. @@ -270,7 +170,7 @@ Tcl_ObjType tclEnsembleCmdType = { */ void -TclInitNamespaceSubsystem(void) +TclInitNamespaceSubsystem() { /* * Does nothing for now. @@ -294,11 +194,19 @@ TclInitNamespaceSubsystem(void) */ Tcl_Namespace * -Tcl_GetCurrentNamespace( - register Tcl_Interp *interp)/* Interpreter whose current namespace is - * being queried. */ +Tcl_GetCurrentNamespace(interp) + register Tcl_Interp *interp; /* Interpreter whose current namespace is + * being queried. */ { - return TclGetCurrentNamespace(interp); + register Interp *iPtr = (Interp *) interp; + register Namespace *nsPtr; + + if (iPtr->varFramePtr != NULL) { + nsPtr = iPtr->varFramePtr->nsPtr; + } else { + nsPtr = iPtr->globalNsPtr; + } + return (Tcl_Namespace *) nsPtr; } /* @@ -318,11 +226,13 @@ Tcl_GetCurrentNamespace( */ Tcl_Namespace * -Tcl_GetGlobalNamespace( - register Tcl_Interp *interp)/* Interpreter whose global namespace should - * be returned. */ +Tcl_GetGlobalNamespace(interp) + register Tcl_Interp *interp; /* Interpreter whose global namespace + * should be returned. */ { - return TclGetGlobalNamespace(interp); + register Interp *iPtr = (Interp *) interp; + + return (Tcl_Namespace *) iPtr->globalNsPtr; } /* @@ -330,9 +240,9 @@ Tcl_GetGlobalNamespace( * * 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 @@ -345,53 +255,45 @@ Tcl_GetGlobalNamespace( */ int -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. */ +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. */ { Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; if (namespacePtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { - 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"); + nsPtr = (Namespace *) namespacePtr; + if (nsPtr->flags & NS_DEAD) { + panic("Trying to push call frame for dead namespace"); /*NOTREACHED*/ - } + } } nsPtr->activationCount++; @@ -402,20 +304,18 @@ Tcl_PushCallFrame( 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 = 0; + framePtr->level = 1; } - 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; @@ -436,57 +336,51 @@ Tcl_PushCallFrame( * * 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( - Tcl_Interp *interp) /* Interpreter with call frame to pop. */ +Tcl_PopCallFrame(interp) + 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. */ - if (framePtr->callerPtr) { - iPtr->framePtr = framePtr->callerPtr; - iPtr->varFramePtr = framePtr->callerVarPtr; - } else { - /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ - } + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; 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); - if (--framePtr->localCachePtr->refCount == 0) { - TclFreeLocalCache(interp, framePtr->localCachePtr); - } - framePtr->localCachePtr = NULL; + TclDeleteCompiledLocalVars(iPtr, framePtr); } /* - * 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 - (nsPtr == iPtr->globalNsPtr) == 0)) { - Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); + && (nsPtr->activationCount == 0)) { + Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; } @@ -494,346 +388,137 @@ Tcl_PopCallFrame( /* *---------------------------------------------------------------------- * - * 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( - 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. */ +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. */ { 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; - Tcl_DString *namePtr, *buffPtr; - int newEntry, nameLen; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int newEntry; /* - * 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_ResetResult(interp); - Tcl_AppendResult(interp, "can't create namespace \"\": " - "only global namespace can have empty name", NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); return NULL; } else { /* * Find the parent for the new namespace. */ - TclGetNamespaceForQualName(interp, name, NULL, - /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + /*flags*/ (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_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); - return NULL; - } + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create namespace \"", name, + "\": already exists", (char *) 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 = ckalloc((unsigned) (strlen(simpleName)+1)); + nsPtr->name = (char *) 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); - nsPtr->nsId = ++(tsdPtr->numNsCreated); - nsPtr->interp = interp; - nsPtr->flags = 0; + Tcl_MutexLock(&nsMutex); + numNsCreated++; + nsPtr->nsId = numNsCreated; + Tcl_MutexUnlock(&nsMutex); + nsPtr->interp = interp; + nsPtr->flags = 0; nsPtr->activationCount = 0; - nsPtr->refCount = 0; + nsPtr->refCount = 0; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); - TclInitVarHashTable(&nsPtr->varTable, nsPtr); - nsPtr->exportArrayPtr = NULL; + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); + 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, 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); + entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, + &newEntry); + Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } /* @@ -842,41 +527,22 @@ Tcl_CreateNamespace( Tcl_DStringInit(&buffer1); Tcl_DStringInit(&buffer2); - namePtr = &buffer1; - buffPtr = &buffer2; - for (ancestorPtr = nsPtr; ancestorPtr != NULL; + for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { - 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). - */ + if (ancestorPtr != globalNsPtr) { + Tcl_DStringAppend(&buffer1, "::", 2); + Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); + } + Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); - 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. - */ - - namePtr = buffPtr; - buffPtr = tempPtr; - } + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); + Tcl_DStringSetLength(&buffer1, 0); } - - name = Tcl_DStringValue(namePtr); - nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = ckalloc((unsigned) (nameLen+1)); - memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); + + name = Tcl_DStringValue(&buffer2); + nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); + strcpy(nsPtr->fullName, name); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); @@ -900,79 +566,50 @@ Tcl_CreateNamespace( * 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( - Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ +Tcl_DeleteNamespace(namespacePtr) + Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; - Namespace *globalNsPtr = (Namespace *) - TclGetGlobalNamespace((Tcl_Interp *) iPtr); + Namespace *globalNsPtr = + (Namespace *) Tcl_GetGlobalNamespace((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 - * 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, + * (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, 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 @@ -983,46 +620,38 @@ Tcl_DeleteNamespace( */ nsPtr->flags |= (NS_DYING|NS_KILLED); + + TclTeardownNamespace(nsPtr); - TclTeardownNamespace(nsPtr); - - if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { - /* + 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. - */ - - 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 { - /* - * Restore the ::errorInfo and ::errorCode traces. + * "errorInfo" and "errorCode" variables for errors that + * occurred while it was being torn down. Try to clear the + * variable list one last time. */ - EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); - EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); - + 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 { /* - * 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); } } } @@ -1037,7 +666,9 @@ Tcl_DeleteNamespace( * commands, variables, and child namespaces. * * This is kept separate from Tcl_DeleteNamespace so that the global - * namespace can be handled specially. + * 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. * * Results: * None. @@ -1045,13 +676,15 @@ Tcl_DeleteNamespace( * 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( - register Namespace *nsPtr) /* Points to the namespace to be dismantled +TclTeardownNamespace(nsPtr) + register Namespace *nsPtr; /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; @@ -1059,30 +692,69 @@ TclTeardownNamespace( 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. Variable table should be cleared but not freed! - * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. + * Start by destroying the namespace's variable table, + * since variables might trigger traces. */ - TclDeleteNamespaceVars(nsPtr); - TclInitVarHashTable(&nsPtr->varTable, nsPtr); + 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); + } /* * 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_GetHashValue(entryPtr); - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); @@ -1092,49 +764,28 @@ TclTeardownNamespace( */ 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. - * - * Don't optimize to Tcl_NextHashEntry() because of traces. + * 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. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { - childNsPtr = Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); + Tcl_DeleteNamespace(childNsPtr); } /* @@ -1145,7 +796,7 @@ TclTeardownNamespace( 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; @@ -1156,15 +807,15 @@ TclTeardownNamespace( */ 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; @@ -1175,8 +826,9 @@ TclTeardownNamespace( * * 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. @@ -1188,8 +840,8 @@ TclTeardownNamespace( */ static void -NamespaceFree( - register Namespace *nsPtr) /* Points to the namespace to free. */ +NamespaceFree(nsPtr) + register Namespace *nsPtr; /* Points to the namespace to free. */ { /* * Most of the namespace's contents are freed when the namespace is @@ -1202,6 +854,7 @@ NamespaceFree( ckfree((char *) nsPtr); } + /* *---------------------------------------------------------------------- @@ -1209,10 +862,10 @@ NamespaceFree( * 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 @@ -1226,22 +879,23 @@ NamespaceFree( */ int -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 +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 Namespace *nsPtr, *exportNsPtr, *dummyPtr; - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - const char *simplePattern; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + CONST char *simplePattern; char *patternCpy; int neededElems, len, i; @@ -1250,9 +904,9 @@ Tcl_Export( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) currNsPtr; + nsPtr = (Namespace *) currNsPtr; } else { - nsPtr = (Namespace *) namespacePtr; + nsPtr = (Namespace *) namespacePtr; } /* @@ -1267,7 +921,6 @@ Tcl_Export( } ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; - TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } @@ -1282,39 +935,49 @@ Tcl_Export( &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendResult(interp, "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid export pattern \"", pattern, + "\": pattern can't specify a namespace", + (char *) 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 (neededElems > nsPtr->maxExportPatterns) { - nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? - 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; + if (nsPtr->exportArrayPtr == NULL) { nsPtr->exportArrayPtr = (char **) - ckrealloc((char *) nsPtr->exportArrayPtr, - sizeof(char *) * nsPtr->maxExportPatterns); + 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; } /* @@ -1322,20 +985,11 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = ckalloc((unsigned) (len + 1)); - memcpy(patternCpy, pattern, (unsigned) len + 1); - + patternCpy = (char *) ckalloc((unsigned) (len + 1)); + strcpy(patternCpy, pattern); + 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 } @@ -1351,24 +1005,24 @@ Tcl_Export( * 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( - 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(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. */ { Namespace *nsPtr; int i, result; @@ -1378,9 +1032,9 @@ Tcl_AppendExportList( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); } else { - nsPtr = (Namespace *) namespacePtr; + nsPtr = (Namespace *) namespacePtr; } /* @@ -1403,79 +1057,90 @@ Tcl_AppendExportList( * 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( - 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(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. */ { + Interp *iPtr = (Interp *) interp; Namespace *nsPtr, *importNsPtr, *dummyPtr; - const char *simplePattern; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + CONST char *simplePattern; + char *cmdName; 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 *) TclGetCurrentNamespace(interp); + nsPtr = (Namespace *) currNsPtr; } 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. - * - * Note that we don't just call Tcl_EvalObjv() directly because we do not - * want absence of the command to be a failure case. + * 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. */ - - if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { + + autoCmd = Tcl_FindCommand(interp, "auto_import", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + + if (autoCmd != NULL) { Tcl_Obj *objv[2]; - int result; - - TclNewLiteralStringObj(objv[0], "auto_import"); - objv[1] = Tcl_NewStringObj(pattern, -1); - + + objv[0] = Tcl_NewStringObj("auto_import", -1); Tcl_IncrRefCount(objv[0]); + objv[1] = Tcl_NewStringObj(pattern, -1); Tcl_IncrRefCount(objv[1]); - result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY); + + cmdPtr = (Command *) autoCmd; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + 2, objv); + Tcl_DecrRefCount(objv[0]); Tcl_DecrRefCount(objv[1]); - + if (result != TCL_OK) { return TCL_ERROR; } @@ -1483,35 +1148,38 @@ Tcl_Import( } /* - * 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_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); - return TCL_ERROR; + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "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_AppendResult(interp, "unknown namespace in import pattern \"", - pattern, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace in import pattern \"", + pattern, "\"", (char *) NULL); + return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendResult(interp, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no namespace specified in import pattern \"", pattern, - "\"", NULL); + "\"", (char *) NULL); } else { - Tcl_AppendResult(interp, "import pattern \"", pattern, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "import pattern \"", pattern, "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", NULL); + importNsPtr->name, "\" into itself", (char *) NULL); } - return TCL_ERROR; + return TCL_ERROR; } /* @@ -1521,154 +1189,118 @@ Tcl_Import( * 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)) { - 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. - * - *---------------------------------------------------------------------- - */ - -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; - - /* - * The command cmdName in the source namespace matches the pattern. Check - * whether it was exported. If it wasn't, we ignore it. - */ - - while (!exported && (i < importNsPtr->numExportPatterns)) { - exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); - } - if (!exported) { - return TCL_OK; - } - - /* - * Unless there is a name clash, create an imported command in the current - * namespace that refers to cmdPtr. - */ + (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; - 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. - */ + wasExported = 0; + for (i = 0; i < importNsPtr->numExportPatterns; i++) { + if (Tcl_StringMatch(cmdName, + importNsPtr->exportArrayPtr[i])) { + wasExported = 1; + break; + } + } + if (!wasExported) { + continue; + } - Tcl_DString ds; - Tcl_Command importedCmd; - ImportedCmdData *dataPtr; - Command *cmdPtr; - ImportRef *refPtr; + /* + * 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 != ((Interp *) interp)->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; - 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; + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, "::", 2); } - } - } + Tcl_DStringAppend(&ds, cmdName, -1); - 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. - */ + /* + * Check whether creating the new imported command in the + * current namespace would create a cycle of imported + * command references. + */ - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); - refPtr->importedCmdPtr = (Command *) importedCmd; - refPtr->nextPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = refPtr; - } else { - Command *overwrite = Tcl_GetHashValue(found); + 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; + } + } + } - if (overwrite->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr = overwrite->objClientData; + 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 (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { /* - * Repeated import of same command is acceptable. + * Create an ImportRef structure describing this new import + * command and add it to the import ref list in the "real" + * command. */ - return TCL_OK; - } - } - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", NULL); - return TCL_ERROR; + 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; } @@ -1678,39 +1310,40 @@ DoImport( * * 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( - 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(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. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; - const char *simplePattern; + CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -1720,14 +1353,14 @@ Tcl_ForgetImport( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(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, @@ -1735,33 +1368,22 @@ Tcl_ForgetImport( &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendResult(interp, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in namespace forget pattern \"", - pattern, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); - return TCL_ERROR; + pattern, "\"", (char *) 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 = Tcl_GetHashValue(hPtr); - + (hPtr != NULL); + hPtr = Tcl_NextHashEntry(&search)) { + Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } @@ -1773,29 +1395,26 @@ Tcl_ForgetImport( 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_GetHashValue(hPtr); + Tcl_Command token = (Tcl_Command) 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 = cmdPtr->objClientData; + ImportedCmdData *dataPtr = + (ImportedCmdData *) cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; - if (firstToken == origin) { continue; } @@ -1819,15 +1438,15 @@ Tcl_ForgetImport( * * 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 function returns the original command it refers - * to. + * imported command, this procedure 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 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. + * 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. * * Side effects: * None. @@ -1836,19 +1455,19 @@ Tcl_ForgetImport( */ Tcl_Command -TclGetOriginalCommand( - Tcl_Command command) /* The imported command for which the original - * command should be returned. */ +TclGetOriginalCommand(command) + 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 NULL; + return (Tcl_Command) NULL; } - + while (cmdPtr->deleteProc == DeleteImportedCmd) { - dataPtr = cmdPtr->objClientData; + dataPtr = (ImportedCmdData *) cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; @@ -1859,33 +1478,33 @@ TclGetOriginalCommand( * * 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 clientData, /* Points to the imported command's +InvokeImportedCmd(clientData, interp, objc, objv) + 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 = clientData; + register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; register Command *realCmdPtr = dataPtr->realCmdPtr; return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, - objc, objv); + objc, objv); } /* @@ -1894,11 +1513,11 @@ InvokeImportedCmd( * 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 function 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 procedure removes the imported command reference from + * the real command's list, and frees up the memory associated with + * the imported command. * * Results: * None. @@ -1910,25 +1529,25 @@ InvokeImportedCmd( */ static void -DeleteImportedCmd( - ClientData clientData) /* Points to the imported command's +DeleteImportedCmd(clientData) + ClientData clientData; /* Points to the imported command's * ImportedCmdData structure. */ { - ImportedCmdData *dataPtr = clientData; + ImportedCmdData *dataPtr = (ImportedCmdData *) 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; @@ -1939,8 +1558,8 @@ DeleteImportedCmd( } prevPtr = refPtr; } - - Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); + + panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); } /* @@ -1949,157 +1568,162 @@ DeleteImportedCmd( * TclGetNamespaceForQualName -- * * Given a qualified name specifying a command, variable, or namespace, - * 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. + * 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. * * 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 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. + * 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. * * 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 function sets either *nsPtrPtr or *altNsPtrPtr - * to NULL, then the search along that path failed. The function also + * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr + * to NULL, then the search along that path failed. The procedure 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 (TCL_FIND_ONLY_NS), the function stores a pointer + * namespace reference (FIND_ONLY_NS), the procedure 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 function returns TCL_ERROR. If "flags" + * If there is an error, this procedure 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 TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be + * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be * created. * *---------------------------------------------------------------------- */ int -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. */ +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. */ { 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) { - nsPtr = iPtr->varFramePtr->nsPtr; + if (iPtr->varFramePtr != NULL) { + nsPtr = iPtr->varFramePtr->nsPtr; + } else { + nsPtr = iPtr->globalNsPtr; + } } - start = qualName; /* Points to start of qualifying - * namespace. */ + start = qualName; /* pts 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; @@ -2112,8 +1736,8 @@ TclGetNamespaceForQualName( altNsPtr = globalNsPtr; if ((nsPtr == globalNsPtr) - || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) { - altNsPtr = NULL; + || (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) { + altNsPtr = NULL; } /* @@ -2123,37 +1747,38 @@ TclGetNamespaceForQualName( 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 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. + * 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. */ - - if (flags & TCL_FIND_ONLY_NS) { + + if (flags & FIND_ONLY_NS) { nsName = start; } else { - *nsPtrPtr = nsPtr; - *altNsPtrPtr = altNsPtr; + *nsPtrPtr = nsPtr; + *altNsPtrPtr = altNsPtr; *simpleNamePtr = start; Tcl_DStringFree(&buffer); return TCL_OK; @@ -2162,70 +1787,69 @@ TclGetNamespaceForQualName( /* * 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 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. + * 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. */ - 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; - } + 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; + } start = end; } @@ -2235,26 +1859,26 @@ TclGetNamespaceForQualName( * variable name, trailing "::"s refer to the cmd or var named {}. */ - if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { - *simpleNamePtr = NULL; /* Found namespace name. */ + if ((flags & 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 & TCL_FIND_ONLY_NS) && (*qualName == '\0') + if ((flags & FIND_ONLY_NS) && (*qualName == '\0') && (nsPtr != globalNsPtr)) { nsPtr = NULL; } - *nsPtrPtr = nsPtr; + *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); return TCL_OK; @@ -2268,9 +1892,9 @@ TclGetNamespaceForQualName( * 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. @@ -2279,41 +1903,41 @@ TclGetNamespaceForQualName( */ Tcl_Namespace * -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. */ +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. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - const char *dummy; + CONST char *dummy; /* - * 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. + * 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. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - + (flags | 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_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace \"", name, "\"", (char *) NULL); } return NULL; } @@ -2326,10 +1950,10 @@ Tcl_FindNamespace( * 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. @@ -2338,171 +1962,244 @@ Tcl_FindNamespace( */ Tcl_Command -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; +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; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; - const char *simpleName; + register int search; 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 functions 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 + * procedures may return a Tcl_Command value, they may signal + * to continue onward, or they may signal an error. */ - - 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 ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { - ResolverScheme *resPtr = iPtr->resolverPtr; - Tcl_Command cmd; + resPtr = iPtr->resolverPtr; - 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 NULL; - } + if (result == TCL_OK) { + return cmd; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Command) 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; - 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); - } + 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); } } + } - /* - * Next, check along the path. - */ + 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); + } - 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); - } - } - } + 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. + * + *---------------------------------------------------------------------- + */ - /* - * If we've still not found the command, look in the global namespace - * as a last resort. - */ +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; - 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 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); + } - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; - /* - * 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 (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } - 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); - } - } - } - } + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } - if (cmdPtr != NULL) { - return (Tcl_Command) cmdPtr; + if (result == TCL_OK) { + return var; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Var) NULL; + } } - if (flags & TCL_LEAVE_ERR_MSG) { + /* + * 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 (varPtr != NULL) { + return (Tcl_Var) varPtr; + } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown variable \"", name, "\"", (char *) NULL); } - return NULL; + return (Tcl_Var) NULL; } /* @@ -2514,49 +2211,56 @@ Tcl_FindCommand( * 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( - Tcl_Interp *interp, /* Interpreter containing the new command. */ - Command *newCmdPtr) /* Points to the new command. */ +TclResetShadowedCmdRefs(interp, newCmdPtr) + 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 *) TclGetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(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 = 5; /* Formerly NUM_TRAIL_ELEMS. */ - Namespace **trailPtr = (Namespace **) - TclStackAlloc(interp, trailSize * sizeof(Namespace *)); + int trailSize = NUM_TRAIL_ELEMS; /* - * 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 @@ -2564,164 +2268,200 @@ TclResetShadowedCmdRefs( * 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 = 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 = (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, * shadowNsPtr is initially :: and we check for case 1. above. */ - if (found) { - hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); - if (hPtr != NULL) { - nsPtr->cmdRefEpoch++; - TclInvalidateNsPath(nsPtr); + if (found) { + hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); + if (hPtr != NULL) { + nsPtr->cmdRefEpoch++; - /* + /* * 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) { - int newSize = 2 * trailSize; - trailPtr = (Namespace **) TclStackRealloc(interp, - trailPtr, newSize * sizeof(Namespace *)); + 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; trailSize = newSize; } trailPtr[trailFront] = nsPtr; } - TclStackFree(interp, trailPtr); + + /* + * Free any allocated storage. + */ + + if (trailPtr != trailStorage) { + ckfree((char *) trailPtr); + } } /* *---------------------------------------------------------------------- * - * TclGetNamespaceFromObj, GetNamespaceFromObj -- + * 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, or anything else goes wrong, this - * function returns TCL_ERROR and writes an error message to interp, - * if non-NULL. + * 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. * * Side effects: * May update the internal representation for the object, caching the - * namespace reference. The next time this function is called, the + * namespace reference. The next time this procedure is called, the * namespace value can be found quickly. * + * If anything goes wrong, an error message is left in the + * interpreter's result object. + * *---------------------------------------------------------------------- */ -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. */ +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. */ { - if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) { - const char *name = TclGetString(objPtr); + Interp *iPtr = (Interp *) interp; + register ResolvedNsName *resNamePtr; + register Namespace *nsPtr; + Namespace *currNsPtr; + CallFrame *savedFramePtr; + int result = TCL_OK; + char *name; - if ((name[0] == ':') && (name[1] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "namespace \"%s\" not found", name)); - } else { - /* - * Get the current namespace name. - */ + /* + * 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. + */ - 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; + savedFramePtr = iPtr->varFramePtr; + name = Tcl_GetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + iPtr->varFramePtr = NULL; } - return TCL_OK; -} - -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; - if (objPtr->typePtr == &nsNameType) { - /* - * Check that the ResolvedNsName is still valid; avoid letting the ref - * cross interps. - */ + 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. + */ - 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 (objPtr->typePtr != &tclNsNameType) { + result = tclNsNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + goto done; + } } - if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; - *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; - return TCL_OK; - } - return TCL_ERROR; + resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + + /* + * 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. + */ + + 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; } /* @@ -2729,14 +2469,13 @@ GetNamespaceFromObj( * * 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...? @@ -2754,40 +2493,41 @@ GetNamespaceFromObj( * anything goes wrong. * * Side effects: - * 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. + * 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. * *---------------------------------------------------------------------- */ int -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", +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", "eval", "exists", "export", "forget", "import", - "inscope", "origin", "parent", "path", "qualifiers", - "tail", "unknown", "upvar", "which", NULL + "inscope", "origin", "parent", "qualifiers", + "tail", "which", (char *) NULL }; enum NSSubCmdIdx { - NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, + NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, - NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, + NSTailIdx, 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; } /* @@ -2799,65 +2539,53 @@ Tcl_NamespaceObjCmd( 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 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; + 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; } return result; } @@ -2868,8 +2596,8 @@ Tcl_NamespaceObjCmd( * 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? * @@ -2877,22 +2605,22 @@ Tcl_NamespaceObjCmd( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; - Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); char *pattern = NULL; Tcl_DString buffer; register Tcl_HashEntry *entryPtr; @@ -2904,15 +2632,21 @@ NamespaceChildrenCmd( */ if (objc == 2) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { - return TCL_ERROR; - } - nsPtr = (Namespace *) namespacePtr; + 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; } else { Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); - return TCL_ERROR; + return TCL_ERROR; } /* @@ -2921,50 +2655,37 @@ NamespaceChildrenCmd( Tcl_DStringInit(&buffer); if (objc == 4) { - 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); - } + 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); + } } /* - * 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, 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; - } + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { - 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); + 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); } - searchDone: Tcl_SetObjResult(interp, listPtr); Tcl_DStringFree(&buffer); return TCL_OK; @@ -2985,73 +2706,79 @@ NamespaceChildrenCmd( * * 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 function returns an error message as the - * result in the interpreter's result object. + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceCodeCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register char *arg; + register char *arg, *p; int length; 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. - * Take care to only check for scoping in precisely the style that - * [::namespace code] generates it. Anything more forgiving can have - * the effect of failing in namespaces that contain their own custom - " "namespace" command. [Bug 3202171]. */ - arg = TclGetStringFromObj(objv[2], &length); - if (*arg==':' && length > 20 - && strncmp(arg, "::namespace inscope ", 20) == 0) { - Tcl_SetObjResult(interp, objv[2]); - return TCL_OK; + 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 */ + } + if ((*p == 'i') && ((p + 7) <= (arg + length)) + && (strncmp(p, "inscope", 7) == 0)) { + Tcl_SetObjResult(interp, objv[2]); + return TCL_OK; + } } /* * 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. */ - TclNewObj(listPtr); - TclNewLiteralStringObj(objPtr, "::namespace"); - Tcl_ListObjAppendElement(interp, listPtr, objPtr); - TclNewLiteralStringObj(objPtr, "inscope"); - Tcl_ListObjAppendElement(interp, listPtr, objPtr); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("::namespace", -1)); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("inscope", -1)); - currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { - TclNewLiteralStringObj(objPtr, "::"); + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + objPtr = Tcl_NewStringObj("::", -1); } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - + Tcl_ListObjAppendElement(interp, listPtr, objv[2]); Tcl_SetObjResult(interp, listPtr); @@ -3063,9 +2790,9 @@ NamespaceCodeCmd( * * 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 * @@ -3073,40 +2800,40 @@ NamespaceCodeCmd( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { 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 *) TclGetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1); } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); + Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1); } return TCL_OK; } @@ -3124,58 +2851,57 @@ NamespaceCurrentCmd( * 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 - * function returns an error. If no namespaces are specified, this + * procedure 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 - * function returns an error message in the interpreter's result object. + * procedure returns an error message in the interpreter's + * result object. * *---------------------------------------------------------------------- */ static int -NamespaceDeleteCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { 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 = 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; - } + 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; + } } /* @@ -3183,11 +2909,12 @@ NamespaceDeleteCmd( */ for (i = 2; i < objc; i++) { - name = TclGetString(objv[i]); - namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); + name = Tcl_GetString(objv[i]); + namespacePtr = Tcl_FindNamespace(interp, name, + (Tcl_Namespace *) NULL, /* flags */ 0); if (namespacePtr) { - Tcl_DeleteNamespace(namespacePtr); - } + Tcl_DeleteNamespace(namespacePtr); + } } return TCL_OK; } @@ -3197,43 +2924,44 @@ NamespaceDeleteCmd( * * 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 function returns an error message as the - * result. + * 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. * *---------------------------------------------------------------------- */ static int -NamespaceEvalCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { Tcl_Namespace *namespacePtr; - CallFrame *framePtr, **framePtrPtr; + CallFrame frame; Tcl_Obj *objPtr; - int result; + char *name; + int length, 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; } /* @@ -3242,79 +2970,74 @@ NamespaceEvalCmd( */ result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + if (result != TCL_OK) { + return result; + } /* * If the namespace wasn't found, try to create it. */ - - if (result == TCL_ERROR) { - char *name = TclGetString(objv[2]); - - namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); + + if (namespacePtr == NULL) { + name = Tcl_GetStringFromObj(objv[2], &length); + namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, + (Tcl_NamespaceDeleteProc *) 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). */ - /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - namespacePtr, /*isProcCallFrame*/ 0); + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, + namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - - framePtr->objc = objc; - framePtr->objv = objv; + frame.objc = objc; + frame.objv = objv; /* ref counts do not need to be incremented here */ if (objc == 4) { - /* - * TIP #280: Make actual argument location available to eval'd script. - */ - - Interp *iPtr = (Interp *) interp; +#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; CmdFrame* invoker = iPtr->cmdFramePtr; int word = 3; - TclArgumentGet (interp, objv[3], &invoker, &word); - result = TclEvalObjEx(interp, objv[3], 0, invoker, word); + result = TclEvalObjEx(interp, objv[3], 0, invoker, word); +#endif } 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) { - 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)); + 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); } /* * Restore the previous "current" namespace. */ - - TclPopStackFrame(interp); + + Tcl_PopCallFrame(interp); return result; } @@ -3323,9 +3046,9 @@ NamespaceEvalCmd( * * 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 * @@ -3333,28 +3056,35 @@ NamespaceEvalCmd( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { Tcl_Namespace *namespacePtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; + 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_SetObjResult(interp, Tcl_NewBooleanObj( - GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL)); return TCL_OK; } @@ -3365,18 +3095,18 @@ NamespaceExistsCmd( * * 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. @@ -3388,27 +3118,28 @@ NamespaceExistsCmd( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(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; } /* @@ -3417,7 +3148,7 @@ NamespaceExportCmd( firstArg = 2; if (firstArg < objc) { - string = TclGetString(objv[firstArg]); + string = Tcl_GetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; @@ -3425,22 +3156,18 @@ NamespaceExportCmd( } /* - * 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, NULL); - result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, - listPtr); + } else { /* create list with export patterns */ + Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + result = Tcl_AppendExportList(interp, + (Tcl_Namespace *) currNsPtr, listPtr); if (result != TCL_OK) { return result; } @@ -3452,14 +3179,14 @@ NamespaceExportCmd( /* * Add each pattern to the namespace's export pattern list. */ - + for (i = firstArg; i < objc; i++) { - pattern = TclGetString(objv[i]); + pattern = Tcl_GetString(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; } @@ -3469,52 +3196,52 @@ NamespaceExportCmd( * * 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 function returns an error message in the + * Imported commands are removed from the current namespace. If + * anything goes wrong, this procedure returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceForgetCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { 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 = TclGetString(objv[i]); - result = Tcl_ForgetImport(interp, NULL, pattern); - if (result != TCL_OK) { - return result; - } + pattern = Tcl_GetString(objv[i]); + result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); + if (result != TCL_OK) { + return result; + } } return TCL_OK; } @@ -3529,42 +3256,39 @@ NamespaceForgetCmd( * * 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 function returns an error message in the interpreter's + * wrong, this procedure returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int -NamespaceImportCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { int allowOverwrite = 0; char *string, *pattern; @@ -3572,8 +3296,9 @@ NamespaceImportCmd( 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; } /* @@ -3582,34 +3307,11 @@ NamespaceImportCmd( firstArg = 2; if (firstArg < objc) { - string = TclGetString(objv[firstArg]); + string = Tcl_GetString(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; } /* @@ -3617,11 +3319,12 @@ NamespaceImportCmd( */ for (i = firstArg; i < objc; i++) { - pattern = TclGetString(objv[i]); - result = Tcl_Import(interp, NULL, pattern, allowOverwrite); - if (result != TCL_OK) { - return result; - } + pattern = Tcl_GetString(objv[i]); + result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, + allowOverwrite); + if (result != TCL_OK) { + return result; + } } return TCL_OK; } @@ -3633,29 +3336,30 @@ NamespaceImportCmd( * * 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 e + * namespace inscope ::foo a b c d * * is equivalent to * - * namespace eval ::foo [concat {a b} [list c d e]] + * namespace eval ::foo [concat a [list b c d]] * - * 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. @@ -3664,88 +3368,88 @@ NamespaceImportCmd( */ static int -NamespaceInscopeCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { Tcl_Namespace *namespacePtr; - CallFrame *framePtr, **framePtrPtr; + Tcl_CallFrame frame; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); - return TCL_ERROR; + return TCL_ERROR; } /* * Resolve the namespace reference. */ - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { - return TCL_ERROR; + 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; } /* * Make the specified namespace the current namespace. */ - framePtrPtr = &framePtr; /* This is needed to satisfy GCC's - * strict aliasing rules. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - namespacePtr, /*isProcCallFrame*/ 0); + result = Tcl_PushCallFrame(interp, &frame, 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, 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; - } - } + + 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; + } + } 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) { - 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)); + 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); } /* * Restore the previous "current" namespace. */ - TclPopStackFrame(interp); + Tcl_PopCallFrame(interp); return result; } @@ -3768,53 +3472,49 @@ NamespaceInscopeCmd( * 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 function returns TCL_OK if + * interpreter's result object. This procedure returns TCL_OK if * successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this function returns an error message in the - * interpreter's result object. + * If anything goes wrong, this procedure returns an error message in + * the interpreter's result object. * *---------------------------------------------------------------------- */ static int -NamespaceOriginCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { 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 == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[2]), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[2]), NULL); + if (command == (Tcl_Command) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", Tcl_GetString(objv[2]), + "\"", (char *) NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); - TclNewObj(resultPtr); - if (origCommand == NULL) { + if (origCommand == (Tcl_Command) 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, resultPtr); + + Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp)); } else { - Tcl_GetCommandFullName(interp, origCommand, resultPtr); + Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp)); } - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -3833,30 +3533,38 @@ NamespaceOriginCmd( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { Tcl_Namespace *nsPtr; + int result; if (objc == 2) { - nsPtr = TclGetCurrentNamespace(interp); + nsPtr = Tcl_GetCurrentNamespace(interp); } else if (objc == 3) { - if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { - return TCL_ERROR; - } + 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; + } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; } /* @@ -3864,8 +3572,8 @@ NamespaceParentCmd( */ if (nsPtr->parentPtr != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - nsPtr->parentPtr->fullName, -1)); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + nsPtr->parentPtr->fullName, -1); } return TCL_OK; } @@ -3873,479 +3581,66 @@ NamespaceParentCmd( /* *---------------------------------------------------------------------- * - * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { 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 = TclGetString(objv[2]); + name = Tcl_GetString(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_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; + length = p-name+1; + Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length); } return TCL_OK; } @@ -4356,13 +3651,13 @@ Tcl_SetNamespaceUnknownHandler( * 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 * @@ -4370,44 +3665,44 @@ Tcl_SetNamespaceUnknownHandler( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { 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 = TclGetString(objv[2]); + name = Tcl_GetString(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_SetObjResult(interp, Tcl_NewStringObj(p, -1)); + Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1); } return TCL_OK; } @@ -4415,81 +3710,6 @@ NamespaceTailCmd( /* *---------------------------------------------------------------------- * - * 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; -} - -/* - *---------------------------------------------------------------------- - * * NamespaceWhichCmd -- * * Invoked to implement the "namespace which" command that returns the @@ -4503,66 +3723,70 @@ NamespaceUpvarCmd( * 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( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { - static const char *opts[] = { - "-command", "-variable", NULL - }; - int lookupType = 0; - Tcl_Obj *resultPtr; + register char *arg; + Tcl_Command cmd; + Tcl_Var variable; + int argIndex, lookup; - 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. - */ + if (objc < 3) { + badArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "?-command? ?-variable? name"); + return TCL_ERROR; + } - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, - &lookupType) != TCL_OK) { - /* - * Preserve old style of error message! - */ + /* + * Look for a flag controlling the lookup. + */ - Tcl_ResetResult(interp); + 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 { goto badArgs; } + argIndex = 3; } - - 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; + if (objc != (argIndex + 1)) { + goto badArgs; } - case 1: { /* -variable */ - Tcl_Var var = Tcl_FindNamespaceVar(interp, - TclGetString(objv[objc-1]), NULL, /*flags*/ 0); - if (var != NULL) { - Tcl_GetVariableFullName(interp, var, resultPtr); - } - break; - } + 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; + + 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; } - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -4578,44 +3802,45 @@ NamespaceWhichCmd( * 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( - register Tcl_Obj *objPtr) /* nsName object with internal representation - * to free. */ +FreeNsNameInternalRep(objPtr) + register Tcl_Obj *objPtr; /* nsName object with internal + * representation to free */ { - register ResolvedNsName *resNamePtr = (ResolvedNsName *) - objPtr->internalRep.twoPtrValue.ptr1; + register ResolvedNsName *resNamePtr = + (ResolvedNsName *) objPtr->internalRep.otherValuePtr; 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. */ - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { + if (resNamePtr != NULL) { + 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); + } } - objPtr->typePtr = NULL; } /* @@ -4631,23 +3856,25 @@ FreeNsNameInternalRep( * * 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( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +DupNsNameInternalRep(srcPtr, copyPtr) + 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.twoPtrValue.ptr1; + register ResolvedNsName *resNamePtr = + (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; - copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - resNamePtr->refCount++; - copyPtr->typePtr = &nsNameType; + copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; + if (resNamePtr != NULL) { + resNamePtr->refCount++; + } + copyPtr->typePtr = &tclNsNameType; } /* @@ -4655,2349 +3882,146 @@ DupNsNameInternalRep( * * 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( - 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(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. */ { - const char *dummy; + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *name; + CONST char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; - const char *name; if (interp == NULL) { return TCL_ERROR; } - name = TclGetString(objPtr); - TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, - &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - /* - * If we found a namespace, then create a new ResolvedNsName structure - * that holds a reference to it. + * Get the string representation. Make it up-to-date if necessary. */ - 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); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ - - 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; - - /* - * 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! - */ - - 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); + name = objPtr->bytes; + if (name == NULL) { + name = Tcl_GetString(objPtr); } /* - * 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! + * 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. */ - ensemblePtr->nsPtr->exportLookupEpoch++; + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* - * 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_SetEnsembleMappingDict -- - * - * Set the mapping dictionary for a particular ensemble. - * - * Results: - * 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... + * If we found a namespace, then create a new ResolvedNsName structure + * that holds a reference to it. */ - 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: - * Alters the internal representation of the first object parameter. - * - *---------------------------------------------------------------------- - */ - -static void -MakeCachedEnsembleCommand( - Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - const char *subcommandName, - Tcl_Obj *prefixObjPtr) -{ - register EnsembleCmdRep *ensembleCmd; - int length; - - 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); + 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 { - /* - * 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; + resNamePtr = NULL; } /* - * Populate the internal rep. + * 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. */ - 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); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); } - /* - * 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); + objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; + objPtr->typePtr = &tclNsNameType; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * BuildEnsembleConfig -- + * UpdateStringOfNsName -- * - * 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. + * 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. * * 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. + * The object's string is set to a copy of the fully qualified + * namespace name. * *---------------------------------------------------------------------- */ static void -BuildEnsembleConfig( - EnsembleConfig *ensemblePtr) +UpdateStringOfNsName(objPtr) + register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ { - 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; + ResolvedNsName *resNamePtr = + (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + register Namespace *nsPtr; + char *name = ""; + int length; - 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); + if ((resNamePtr != NULL) + && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { + nsPtr = resNamePtr->nsPtr; + if (nsPtr->flags & NS_DEAD) { + nsPtr = NULL; + } + if (nsPtr != NULL) { + name = nsPtr->fullName; + } } /* - * 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. + * The following sets the string rep to an empty string on the heap + * if the internal rep is NULL. */ - 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); - } + length = strlen(name); + if (length == 0) { + objPtr->bytes = tclEmptyStringRep; } else { - /* - * 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); + objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); + memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); + objPtr->bytes[length] = '\0'; } - 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: - */ |