diff options
Diffstat (limited to 'tcl8.6/generic/tclNamesp.c')
| -rw-r--r-- | tcl8.6/generic/tclNamesp.c | 5104 |
1 files changed, 5104 insertions, 0 deletions
diff --git a/tcl8.6/generic/tclNamesp.c b/tcl8.6/generic/tclNamesp.c new file mode 100644 index 0000000..a8d351f --- /dev/null +++ b/tcl8.6/generic/tclNamesp.c @@ -0,0 +1,5104 @@ +/* + * 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. + * + * 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. + */ + +#include "tclInt.h" +#include "tclCompile.h" /* for TclLogCommandInfo visibility */ + +/* + * Thread-local storage used to avoid having a global lock on data that is not + * limited to a single interpreter. + */ + +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; + +/* + * 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. + */ + +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; + +/* + * Declarations for functions local to this file: + */ + +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 InvokeImportedNRCmd(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 NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NRNamespaceEvalCmd(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 NRNamespaceInscopeCmd(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 void UnlinkNsPath(Namespace *nsPtr); + +static Tcl_NRPostProc NsEval_Callback; + +/* + * 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 const Tcl_ObjType nsNameType = { + "nsName", /* the type's name */ + FreeNsNameInternalRep, /* freeIntRepProc */ + DupNsNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetNsNameFromAny /* setFromAnyProc */ +}; + +/* + * Array of values describing how to implement each standard subcommand of the + * "namespace" command. + */ + +static const EnsembleImplMap defaultNamespaceMap[] = { + {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} +}; + +/* + *---------------------------------------------------------------------- + * + * TclInitNamespaceSubsystem -- + * + * This function is called to initialize all the structures that are used + * by namespaces on a per-process basis. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclInitNamespaceSubsystem(void) +{ + /* + * Does nothing for now. + */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCurrentNamespace -- + * + * Returns a pointer to an interpreter's currently active namespace. + * + * Results: + * Returns a pointer to the interpreter's current namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Namespace * +Tcl_GetCurrentNamespace( + register Tcl_Interp *interp)/* Interpreter whose current namespace is + * being queried. */ +{ + return TclGetCurrentNamespace(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetGlobalNamespace -- + * + * Returns a pointer to an interpreter's global :: namespace. + * + * Results: + * Returns a pointer to the specified interpreter's global namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Namespace * +Tcl_GetGlobalNamespace( + register Tcl_Interp *interp)/* Interpreter whose global namespace should + * be returned. */ +{ + return TclGetGlobalNamespace(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PushCallFrame -- + * + * Pushes a new call frame onto the interpreter's Tcl call stack. Called + * when executing a Tcl procedure or a "namespace eval" or "namespace + * inscope" command. + * + * 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 +Tcl_PushCallFrame( + Tcl_Interp *interp, /* Interpreter in which the new call frame is + * to be pushed. */ + Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push. + * Storage for this has already been allocated + * by the caller; typically this is the + * address of a CallFrame structure allocated + * on the caller's C stack. The call frame + * will be initialized by this function. The + * caller can pop the frame later with + * Tcl_PopCallFrame, and it is responsible for + * freeing the frame's storage. */ + Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame + * will execute. If NULL, the interpreter's + * current namespace will be used. */ + int isProcCallFrame) /* If nonzero, the frame represents a called + * Tcl procedure and may have local vars. Vars + * will ordinarily be looked up in the frame. + * If new variables are created, they will be + * created in the frame. If 0, the frame is + * for a "namespace eval" or "namespace + * inscope" command and var references are + * treated as references to namespace + * variables. */ +{ + Interp *iPtr = (Interp *) interp; + register CallFrame *framePtr = (CallFrame *) callFramePtr; + register Namespace *nsPtr; + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(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"); + /*NOTREACHED*/ + } + } + + nsPtr->activationCount++; + framePtr->nsPtr = nsPtr; + framePtr->isProcCallFrame = isProcCallFrame; + framePtr->objc = 0; + framePtr->objv = NULL; + framePtr->callerPtr = iPtr->framePtr; + framePtr->callerVarPtr = iPtr->varFramePtr; + if (iPtr->varFramePtr != NULL) { + framePtr->level = (iPtr->varFramePtr->level + 1); + } else { + framePtr->level = 0; + } + 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; + framePtr->tailcallPtr = NULL; + + /* + * Push the new call frame onto the interpreter's stack of procedure call + * frames making it the current frame. + */ + + iPtr->framePtr = framePtr; + iPtr->varFramePtr = framePtr; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PopCallFrame -- + * + * Removes a call frame from the Tcl call stack for the interpreter. + * Called to remove a frame previously pushed by Tcl_PushCallFrame. + * + * Results: + * None. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PopCallFrame( + Tcl_Interp *interp) /* Interpreter with call frame to pop. */ +{ + register Interp *iPtr = (Interp *) interp; + register CallFrame *framePtr = iPtr->framePtr; + Namespace *nsPtr; + + /* + * It's important to remove the call frame from the interpreter's stack of + * call frames before deleting local variables, so that traces invoked by + * the variable deletion don't see the partially-deleted frame. + */ + + if (framePtr->callerPtr) { + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + } else { + /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ + } + + if (framePtr->varTablePtr != NULL) { + TclDeleteVars(iPtr, framePtr->varTablePtr); + ckfree(framePtr->varTablePtr); + framePtr->varTablePtr = NULL; + } + if (framePtr->numCompiledLocals > 0) { + TclDeleteCompiledLocalVars(iPtr, framePtr); + if (--framePtr->localCachePtr->refCount == 0) { + TclFreeLocalCache(interp, framePtr->localCachePtr); + } + framePtr->localCachePtr = NULL; + } + + /* + * Decrement the namespace's count of active call frames. If the namespace + * is "dying" and there are no more active call frames, call + * Tcl_DeleteNamespace to destroy it. + */ + + nsPtr = framePtr->nsPtr; + nsPtr->activationCount--; + if ((nsPtr->flags & NS_DYING) + && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { + Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); + } + framePtr->nsPtr = NULL; + + if (framePtr->tailcallPtr) { + TclSetTailcall(interp, framePtr->tailcallPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 = 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_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, + ErrorCodeRead, NULL); + Tcl_TraceVar2(interp, "errorCode", NULL, 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_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, + ErrorInfoRead, NULL); + Tcl_TraceVar2(interp, "errorInfo", NULL, 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. + * + * 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. + * + * Side effects: + * 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. */ +{ + Interp *iPtr = (Interp *) interp; + register Namespace *nsPtr, *ancestorPtr; + Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; + Namespace *globalNsPtr = iPtr->globalNsPtr; + const char *simpleName; + Tcl_HashEntry *entryPtr; + Tcl_DString buffer1, buffer2; + Tcl_DString *namePtr, *buffPtr; + int newEntry, nameLen; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *nameStr; + Tcl_DString tmpBuffer; + + Tcl_DStringInit(&tmpBuffer); + + /* + * 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. + */ + + parentPtr = NULL; + simpleName = ""; + goto doCreate; + } + + /* + * Ensure that there are no trailing colons as that causes chaos when a + * deleteProc is specified. [Bug d614d63989] + */ + + if (deleteProc != NULL) { + nameStr = name + strlen(name) - 2; + if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') { + Tcl_DStringAppend(&tmpBuffer, name, -1); + while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0 + && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') { + Tcl_DStringSetLength(&tmpBuffer, nameLen-1); + } + name = Tcl_DStringValue(&tmpBuffer); + } + } + + /* + * If we've ended up with an empty string now, we're attempting to create + * the global namespace despite the global namespace existing. That's + * naughty! + */ + + if (*name == '\0') { + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" + " \"\": only global namespace can have empty name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; + } + + /* + * Find the parent for the new namespace. + */ + + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, + &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. + */ + + if (*simpleName == '\0') { + Tcl_DStringFree(&tmpBuffer); + return (Tcl_Namespace *) parentPtr; + } + + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. + */ + + if ( +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL +#else + parentPtr->childTablePtr != NULL && + Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL +#endif + ) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; + } + + /* + * Create the new namespace and root it in its parent. Increment the count + * of namespaces created. + */ + + doCreate: + nsPtr = ckalloc(sizeof(Namespace)); + nameLen = strlen(simpleName) + 1; + nsPtr->name = ckalloc(nameLen); + memcpy(nsPtr->name, simpleName, nameLen); + nsPtr->fullName = NULL; /* Set below. */ + nsPtr->clientData = clientData; + nsPtr->deleteProc = deleteProc; + nsPtr->parentPtr = parentPtr; +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); +#else + nsPtr->childTablePtr = NULL; +#endif + nsPtr->nsId = ++(tsdPtr->numNsCreated); + nsPtr->interp = interp; + nsPtr->flags = 0; + nsPtr->activationCount = 0; + nsPtr->refCount = 0; + Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); + TclInitVarHashTable(&nsPtr->varTable, nsPtr); + nsPtr->exportArrayPtr = NULL; + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = 0; + nsPtr->cmdRefEpoch = 0; + nsPtr->resolverEpoch = 0; + nsPtr->cmdResProc = NULL; + nsPtr->varResProc = NULL; + nsPtr->compiledVarResProc = NULL; + nsPtr->exportLookupEpoch = 0; + nsPtr->ensembles = NULL; + nsPtr->unknownHandlerPtr = NULL; + nsPtr->commandPathLength = 0; + nsPtr->commandPathArray = NULL; + nsPtr->commandPathSourceList = NULL; + nsPtr->earlyDeleteProc = NULL; + + if (parentPtr != NULL) { + entryPtr = Tcl_CreateHashEntry( + TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr), + 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); + } + + /* + * Build the fully qualified name for this namespace. + */ + + Tcl_DStringInit(&buffer1); + Tcl_DStringInit(&buffer2); + namePtr = &buffer1; + buffPtr = &buffer2; + for (ancestorPtr = nsPtr; ancestorPtr != NULL; + ancestorPtr = ancestorPtr->parentPtr) { + if (ancestorPtr != globalNsPtr) { + register Tcl_DString *tempPtr = namePtr; + + TclDStringAppendLiteral(buffPtr, "::"); + Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); + TclDStringAppendDString(buffPtr, namePtr); + + /* + * Clear the unwanted buffer or we end up appending to previous + * results, making the namespace fullNames of nested namespaces + * very wrong (and strange). + */ + + TclDStringClear(namePtr); + + /* + * 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; + } + } + + name = Tcl_DStringValue(namePtr); + nameLen = Tcl_DStringLength(namePtr); + nsPtr->fullName = ckalloc(nameLen + 1); + memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); + + Tcl_DStringFree(&buffer1); + Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&tmpBuffer); + + /* + * If compilation of commands originating from the parent NS is + * suppressed, suppress it for commands originating in this one too. + */ + + if (nsPtr->parentPtr != NULL && + nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) { + nsPtr->flags |= NS_SUPPRESS_COMPILATION; + } + + /* + * Return a pointer to the new namespace. + */ + + return (Tcl_Namespace *) nsPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteNamespace -- + * + * Deletes a namespace and all of the commands, variables, and other + * namespaces within it. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteNamespace( + 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); + Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr; + + /* + * Give anyone interested - notably TclOO - a chance to use this namespace + * normally despite the fact that the namespace is going to go. Allows the + * calling of destructors. Will only be called once (unless re-established + * by the called function). [Bug 2950259] + * + * Note that setting this field requires access to the internal definition + * of namespaces, so it should only be accessed by code that knows about + * being careful with reentrancy. + */ + + if (nsPtr->earlyDeleteProc != NULL) { + Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc; + + nsPtr->earlyDeleteProc = NULL; + nsPtr->activationCount++; + earlyDeleteProc(nsPtr->clientData); + nsPtr->activationCount--; + } + + /* + * Delete all coroutine commands now: break the circular ref cycle between + * the namespace and the coroutine command [Bug 2724403]. This code is + * essentially duplicated in TclTeardownNamespace() for all other + * commands. Don't optimize to Tcl_NextHashEntry() because of traces. + * + * NOTE: we could avoid traversing the ns's command list by keeping a + * separate list of coros. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL;) { + cmdPtr = Tcl_GetHashValue(entryPtr); + if (cmdPtr->nreProc == TclNRInterpCoroutine) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr); + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + } else { + entryPtr = Tcl_NextHashEntry(&search); + } + } + + /* + * 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( + TclGetNamespaceChildTable((Tcl_Namespace *) + nsPtr->parentPtr), nsPtr->name); + 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 + * namespace, then clear it but don't free its storage unless the + * interpreter is being torn down. Set the NS_KILLED flag to avoid + * recursive calls here - if the namespace is really in the process of + * being deleted, ignore any second call. + */ + + nsPtr->flags |= (NS_DYING|NS_KILLED); + + TclTeardownNamespace(nsPtr); + + if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { + /* + * If this is the global namespace, then it may have residual + * "errorInfo" and "errorCode" variables for errors that occurred + * while it was being torn down. Try to clear the variable list + * one last time. + */ + + TclDeleteNamespaceVars(nsPtr); + +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_DeleteHashTable(&nsPtr->childTable); +#else + if (nsPtr->childTablePtr != NULL) { + Tcl_DeleteHashTable(nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); + } +#endif + 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. + */ + + EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); + EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); + + /* + * We didn't really kill it, so remove the KILLED marks, so it can + * get killed later, avoiding mem leaks. + */ + + nsPtr->flags &= ~(NS_DYING|NS_KILLED); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclTeardownNamespace -- + * + * Used internally to dismantle and unlink a namespace when it is + * deleted. Divorces the namespace from its parent, and deletes all + * commands, variables, and child namespaces. + * + * This is kept separate from Tcl_DeleteNamespace so that the global + * namespace can be handled specially. + * + * Results: + * None. + * + * Side effects: + * Removes this namespace from its parent's child namespace hashtable. + * Deletes all commands, variables and namespaces in this namespace. + * + *---------------------------------------------------------------------- + */ + +void +TclTeardownNamespace( + register Namespace *nsPtr) /* Points to the namespace to be dismantled + * and unlinked from its parent. */ +{ + Interp *iPtr = (Interp *) nsPtr->interp; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + 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. + */ + + TclDeleteNamespaceVars(nsPtr); + TclInitVarHashTable(&nsPtr->varTable, nsPtr); + + /* + * Delete all commands in this namespace. Be careful when traversing the + * hash table: when each command is deleted, it removes itself from the + * command table. Because of traces (and the desire to avoid the quadratic + * problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * commands. + */ + + while (nsPtr->cmdTable.numEntries > 0) { + int length = nsPtr->cmdTable.numEntries; + Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Command *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + cmds[i] = Tcl_GetHashValue(entryPtr); + cmds[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmds[i]); + TclCleanupCommandMacro(cmds[i]); + } + TclStackFree((Tcl_Interp *) iPtr, cmds); + } + Tcl_DeleteHashTable(&nsPtr->cmdTable); + Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); + + /* + * Remove the namespace from its parent's child hashtable. + */ + + if (nsPtr->parentPtr != NULL) { + entryPtr = Tcl_FindHashEntry( + TclGetNamespaceChildTable((Tcl_Namespace *) + nsPtr->parentPtr), 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. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * namespaces. + * + * Important: leave the hash table itself still live. + */ + +#ifndef BREAK_NAMESPACE_COMPAT + while (nsPtr->childTable.numEntries > 0) { + int length = nsPtr->childTable.numEntries; + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + TclStackFree((Tcl_Interp *) iPtr, children); + } +#else + if (nsPtr->childTablePtr != NULL) { + while (nsPtr->childTablePtr->numEntries > 0) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + TclStackFree((Tcl_Interp *) iPtr, children); + } + } +#endif + + /* + * Free the namespace's export pattern array. + */ + + if (nsPtr->exportArrayPtr != NULL) { + for (i = 0; i < nsPtr->numExportPatterns; i++) { + ckfree(nsPtr->exportArrayPtr[i]); + } + ckfree(nsPtr->exportArrayPtr); + nsPtr->exportArrayPtr = NULL; + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = 0; + } + + /* + * Free any client data associated with the namespace. + */ + + if (nsPtr->deleteProc != NULL) { + 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. + */ + + nsPtr->nsId = 0; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceFree -- + * + * Called after a namespace has been deleted, when its reference count + * reaches 0. Frees the data structure representing the namespace. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +NamespaceFree( + register Namespace *nsPtr) /* Points to the namespace to free. */ +{ + /* + * Most of the namespace's contents are freed when the namespace is + * deleted by Tcl_DeleteNamespace. All that remains is to free its names + * (for error messages), and the structure itself. + */ + + ckfree(nsPtr->name); + ckfree(nsPtr->fullName); + ckfree(nsPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclNsDecrRefCount -- + * + * Drops a reference to a namespace and frees it if the namespace has + * been deleted and the last reference has just been dropped. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclNsDecrRefCount( + Namespace *nsPtr) +{ + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Export -- + * + * Makes all the commands matching a pattern available to later be + * imported from the namespace specified by namespacePtr (or the current + * namespace if namespacePtr is NULL). The specified pattern is appended + * onto the namespace's export pattern list, which is optionally cleared + * beforehand. + * + * 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: + * Appends the export pattern onto the namespace's export list. + * Optionally reset the namespace's export pattern list. + * + *---------------------------------------------------------------------- + */ + +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 + Namespace *nsPtr, *exportNsPtr, *dummyPtr; + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + const char *simplePattern; + char *patternCpy; + int neededElems, len, i; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) currNsPtr; + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * If resetListFirst is true (nonzero), clear the namespace's export + * pattern list. + */ + + if (resetListFirst) { + if (nsPtr->exportArrayPtr != NULL) { + for (i = 0; i < nsPtr->numExportPatterns; i++) { + ckfree(nsPtr->exportArrayPtr[i]); + } + ckfree(nsPtr->exportArrayPtr); + nsPtr->exportArrayPtr = NULL; + TclInvalidateNsCmdLookup(nsPtr); + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = 0; + } + } + + /* + * Check that the pattern doesn't have namespace qualifiers. + */ + + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, + &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", 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. + */ + + return TCL_OK; + } + } + } + + /* + * 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; + nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, + sizeof(char *) * nsPtr->maxExportPatterns); + } + + /* + * Add the pattern to the namespace's array of export patterns. + */ + + len = strlen(pattern); + patternCpy = ckalloc(len + 1); + memcpy(patternCpy, pattern, (unsigned) len + 1); + + nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; + nsPtr->numExportPatterns++; + + /* + * The list of commands actually exported from the namespace might have + * changed (probably will have!) However, we do not need to recompute this + * just yet; next time we need the info will be soon enough. + */ + + TclInvalidateNsCmdLookup(nsPtr); + + return TCL_OK; +#undef INIT_EXPORT_PATTERNS +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendExportList -- + * + * Appends onto the argument object the list of export patterns for the + * specified namespace. + * + * 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. + * + * Side effects: + * 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. */ +{ + Namespace *nsPtr; + int i, result; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * Append the export pattern list onto objPtr. + */ + + for (i = 0; i < nsPtr->numExportPatterns; i++) { + result = Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + Namespace *nsPtr, *importNsPtr, *dummyPtr; + const char *simplePattern; + register Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } else { + 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. + */ + + if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { + Tcl_Obj *objv[2]; + int result; + + TclNewLiteralStringObj(objv[0], "auto_import"); + objv[1] = Tcl_NewStringObj(pattern, -1); + + Tcl_IncrRefCount(objv[0]); + Tcl_IncrRefCount(objv[1]); + result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + + if (result != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + } + + /* + * 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)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); + return TCL_ERROR; + } + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, + &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + + if (importNsPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in import pattern \"%s\"", pattern)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); + return TCL_ERROR; + } + if (importNsPtr == nsPtr) { + if (pattern == simplePattern) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no namespace specified in import pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" tries to import from namespace" + " \"%s\" into itself", pattern, importNsPtr->name)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); + } + return TCL_ERROR; + } + + /* + * Scan through the command table in the source namespace and look for + * exported commands that match the string pattern. Create an "imported + * command" in the current namespace for each imported command; these + * 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. + */ + + 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. + */ + + Tcl_DString ds; + Tcl_Command importedCmd; + ImportedCmdData *dataPtr; + Command *cmdPtr; + ImportRef *refPtr; + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != ((Interp *) interp)->globalNsPtr) { + TclDStringAppendLiteral(&ds, "::"); + } + Tcl_DStringAppend(&ds, cmdName, -1); + + /* + * Check whether creating the new imported command in the current + * namespace would create a cycle of imported command references. + */ + + cmdPtr = Tcl_GetHashValue(hPtr); + if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { + Command *overwrite = Tcl_GetHashValue(found); + Command *linkCmd = cmdPtr; + + while (linkCmd->deleteProc == DeleteImportedCmd) { + dataPtr = linkCmd->objClientData; + linkCmd = dataPtr->realCmdPtr; + if (overwrite == linkCmd) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" would create a loop" + " containing command \"%s\"", + pattern, Tcl_DStringValue(&ds))); + Tcl_DStringFree(&ds); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); + return TCL_ERROR; + } + } + } + + dataPtr = ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + DeleteImportedCmd); + dataPtr->realCmdPtr = cmdPtr; + dataPtr->selfPtr = (Command *) importedCmd; + dataPtr->selfPtr->compileProc = cmdPtr->compileProc; + Tcl_DStringFree(&ds); + + /* + * Create an ImportRef structure describing this new import command + * and add it to the import ref list in the "real" command. + */ + + refPtr = ckalloc(sizeof(ImportRef)); + refPtr->importedCmdPtr = (Command *) importedCmd; + refPtr->nextPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = refPtr; + } else { + Command *overwrite = Tcl_GetHashValue(found); + + if (overwrite->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr = overwrite->objClientData; + + if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { + /* + * Repeated import of same command is acceptable. + */ + + return TCL_OK; + } + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't import command \"%s\": already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * 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. + * + * Side effects: + * 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. */ +{ + Namespace *nsPtr, *sourceNsPtr, *dummyPtr; + const char *simplePattern; + char *cmdName; + register Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * Parse the pattern into its namespace-qualification (if any) and the + * simple pattern. + */ + + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, + &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + + if (sourceNsPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in namespace forget pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); + return TCL_ERROR; + } + + if (strcmp(pattern, simplePattern) == 0) { + /* + * The pattern is simple. Delete any imported commands that match it. + */ + + if (TclMatchIsTrivial(simplePattern)) { + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if (hPtr != NULL) { + Command *cmdPtr = Tcl_GetHashValue(hPtr); + + if (cmdPtr && (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); + + if (cmdPtr->deleteProc != DeleteImportedCmd) { + continue; + } + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); + if (Tcl_StringMatch(cmdName, simplePattern)) { + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + } + } + return TCL_OK; + } + + /* + * 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 origin = TclGetOriginalCommand(token); + + if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { + 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. + */ + + Command *cmdPtr = (Command *) token; + ImportedCmdData *dataPtr = cmdPtr->objClientData; + Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; + + if (firstToken == origin) { + continue; + } + Tcl_GetCommandInfoFromToken(firstToken, &info); + if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { + continue; + } + origin = firstToken; + } + if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){ + Tcl_DeleteCommandFromToken(interp, token); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetOriginalCommand -- + * + * 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. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclGetOriginalCommand( + Tcl_Command command) /* The imported command for which the original + * command should be returned. */ +{ + register Command *cmdPtr = (Command *) command; + ImportedCmdData *dataPtr; + + if (cmdPtr->deleteProc != DeleteImportedCmd) { + return NULL; + } + + while (cmdPtr->deleteProc == DeleteImportedCmd) { + dataPtr = cmdPtr->objClientData; + cmdPtr = dataPtr->realCmdPtr; + } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * InvokeImportedCmd -- + * + * 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. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result object is set to an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InvokeImportedNRCmd( + 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. */ +{ + ImportedCmdData *dataPtr = clientData; + Command *realCmdPtr = dataPtr->realCmdPtr; + + TclSkipTailcall(interp); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); +} + +static int +InvokeImportedCmd( + ClientData clientData, /* Points to the imported command's + * ImportedCmdData structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData, + objc, objv); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteImportedCmd -- + * + * Invoked by Tcl whenever an imported command is deleted. The "real" + * command keeps a list of all the imported commands that refer to it, so + * those imported commands can be deleted when the real command is + * deleted. This function removes the imported command reference from the + * real command's list, and frees up the memory associated with the + * imported command. + * + * Results: + * None. + * + * Side effects: + * Removes the imported command from the real command's import list. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteImportedCmd( + ClientData clientData) /* Points to the imported command's + * ImportedCmdData structure. */ +{ + ImportedCmdData *dataPtr = clientData; + Command *realCmdPtr = dataPtr->realCmdPtr; + Command *selfPtr = dataPtr->selfPtr; + register ImportRef *refPtr, *prevPtr; + + prevPtr = NULL; + for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; + refPtr = refPtr->nextPtr) { + 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. */ + realCmdPtr->importRefPtr = refPtr->nextPtr; + } else { + prevPtr->nextPtr = refPtr->nextPtr; + } + ckfree(refPtr); + ckfree(dataPtr); + return; + } + prevPtr = refPtr; + } + + Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * 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. + * + * 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 + * 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 + * 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" + * 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. + * + * 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 + * 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. */ +{ + Interp *iPtr = (Interp *) interp; + Namespace *nsPtr = cxtNsPtr; + Namespace *altNsPtr; + Namespace *globalNsPtr = iPtr->globalNsPtr; + 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 + * 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. + */ + + if (flags & TCL_GLOBAL_ONLY) { + nsPtr = globalNsPtr; + } else if (nsPtr == NULL) { + nsPtr = iPtr->varFramePtr->nsPtr; + } + + start = qualName; /* Points to start of qualifying + * namespace. */ + if ((*qualName == ':') && (*(qualName+1) == ':')) { + start = qualName+2; /* Skip over the initial :: */ + while (*start == ':') { + start++; /* Skip over a subsequent : */ + } + 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; + } + } + *actualCxtPtrPtr = nsPtr; + + /* + * Start an alternate search path starting with the global namespace. + * However, if the starting context is the global namespace, or if the + * flag is set to search only the namespace *cxtNsPtr, ignore the + * alternate search path. + */ + + altNsPtr = globalNsPtr; + if ((nsPtr == globalNsPtr) + || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) { + altNsPtr = NULL; + } + + /* + * Loop to resolve each namespace qualifier in qualName. + */ + + 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". + */ + + len = 0; + for (end = start; *end != '\0'; end++) { + if ((*end == ':') && (*(end+1) == ':')) { + end += 2; /* Skip over the initial :: */ + while (*end == ':') { + end++; /* Skip over the subsequent : */ + } + break; /* Exit for loop; end is after ::'s */ + } + len++; + } + + 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. + */ + + if (flags & TCL_FIND_ONLY_NS) { + nsName = start; + } else { + *nsPtrPtr = nsPtr; + *altNsPtrPtr = altNsPtr; + *simpleNamePtr = start; + Tcl_DStringFree(&buffer); + return TCL_OK; + } + } else { + /* + * 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. + */ + + TclDStringClear(&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) { +#ifndef BREAK_NAMESPACE_COMPAT + entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); +#else + if (nsPtr->childTablePtr == NULL) { + entryPtr = NULL; + } else { + entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName); + } +#endif + if (entryPtr != NULL) { + nsPtr = Tcl_GetHashValue(entryPtr); + } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { + Tcl_CallFrame *framePtr; + + (void) TclPushStackFrame(interp, &framePtr, + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); + + nsPtr = (Namespace *) + Tcl_CreateNamespace(interp, nsName, NULL, NULL); + TclPopStackFrame(interp); + + if (nsPtr == NULL) { + Tcl_Panic("Could not create namespace '%s'", nsName); + } + } else { /* Namespace not found and was not + * created. */ + nsPtr = NULL; + } + } + + /* + * Look up the namespace qualifier in the alternate search path too. + */ + + if (altNsPtr != NULL) { +#ifndef BREAK_NAMESPACE_COMPAT + entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); +#else + if (altNsPtr->childTablePtr != NULL) { + entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName); + } else { + entryPtr = NULL; + } +#endif + if (entryPtr != NULL) { + altNsPtr = Tcl_GetHashValue(entryPtr); + } else { + altNsPtr = NULL; + } + } + + /* + * If both search paths have failed, return NULL results. + */ + + if ((nsPtr == NULL) && (altNsPtr == NULL)) { + *nsPtrPtr = NULL; + *altNsPtrPtr = NULL; + *simpleNamePtr = NULL; + Tcl_DStringFree(&buffer); + return TCL_OK; + } + + start = end; + } + + /* + * We ignore trailing "::"s in a namespace name, but in a command or + * 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. */ + } else { + *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. + */ + + if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0') + && (nsPtr != globalNsPtr)) { + nsPtr = NULL; + } + + *nsPtrPtr = nsPtr; + *altNsPtrPtr = altNsPtr; + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindNamespace -- + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; + 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. + */ + + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + + if (nsPtr != NULL) { + return (Tcl_Namespace *) nsPtr; + } + + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindCommand -- + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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; + register Tcl_HashEntry *entryPtr; + register Command *cmdPtr; + const char *simpleName; + int result; + + /* + * If this namespace has a command resolver, then give it first crack at + * the command resolution. If the interpreter has any command resolvers, + * consult them next. The command resolver functions may return a + * Tcl_Command value, they may signal to continue onward, or they may + * signal an error. + */ + + if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) { + cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + } else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } else { + cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { + ResolverScheme *resPtr = iPtr->resolverPtr; + Tcl_Command cmd; + + 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; + } + + if (result == TCL_OK) { + ((Command *)cmd)->flags |= CMD_VIA_RESOLVER; + return cmd; + + } else if (result != TCL_CONTINUE) { + return NULL; + } + } + + /* + * Find the namespace(s) that contain the command. + */ + + 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); + } + } + } + + /* + * Next, check along the path. + */ + + for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) { + pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; + if (pathNsPtr == NULL) { + continue; + } + (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, + TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if ((realNsPtr != NULL) && (simpleName != NULL) + && !(realNsPtr->flags & NS_DYING)) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + } + } + } + + /* + * If we've still not found the command, look in the global namespace + * as a last resort. + */ + + 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; + + 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. + */ + + 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); + } + } + } + } + + if (cmdPtr != NULL) { + cmdPtr->flags &= ~CMD_VIA_RESOLVER; + return (Tcl_Command) cmdPtr; + } + + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown command \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclResetShadowedCmdRefs -- + * + * Called when a command is added to a namespace to check for existing + * 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 + * 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. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +void +TclResetShadowedCmdRefs( + Tcl_Interp *interp, /* Interpreter containing the new command. */ + Command *newCmdPtr) /* Points to the new command. */ +{ + char *cmdName; + Tcl_HashEntry *hPtr; + register Namespace *nsPtr; + Namespace *trailNsPtr, *shadowNsPtr; + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + int found, i; + int trailFront = -1; + int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ + Namespace **trailPtr = TclStackAlloc(interp, + trailSize * sizeof(Namespace *)); + + /* + * Start at the namespace containing the new command, and work up through + * the list of parents. Stop just before the global namespace, since the + * global namespace can't "shadow" its own entries. + * + * The namespace "trail" list we build consists of the names of each + * namespace that encloses the new command, in order from outermost to + * innermost: for example, "a" then "b". Each iteration of this loop + * 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. + */ + + cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); + 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. + */ + + found = 1; + shadowNsPtr = globalNsPtr; + + for (i = trailFront; i >= 0; i--) { + trailNsPtr = trailPtr[i]; +#ifndef BREAK_NAMESPACE_COMPAT + hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, + trailNsPtr->name); +#else + if (shadowNsPtr->childTablePtr != NULL) { + hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr, + trailNsPtr->name); + } else { + hPtr = NULL; + } +#endif + if (hPtr != NULL) { + shadowNsPtr = Tcl_GetHashValue(hPtr); + } else { + found = 0; + break; + } + } + + /* + * If shadowNsPtr contains a command named cmdName, we invalidate all + * of the command refs cached in nsPtr. As a boundary case, + * shadowNsPtr is initially :: and we check for case 1. above. + */ + + if (found) { + hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); + if (hPtr != NULL) { + nsPtr->cmdRefEpoch++; + TclInvalidateNsPath(nsPtr); + + /* + * If the shadowed command was compiled to bytecodes, we + * invalidate all the bytecodes in nsPtr, to force a new + * compilation. We use the resolverEpoch to signal the need + * for a fresh compilation of every bytecode. + */ + + if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){ + nsPtr->resolverEpoch++; + } + } + } + + /* + * 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 = TclStackRealloc(interp, trailPtr, + newSize * sizeof(Namespace *)); + trailSize = newSize; + } + trailPtr[trailFront] = nsPtr; + } + TclStackFree(interp, trailPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNamespaceFromObj, GetNamespaceFromObj -- + * + * Gets the namespace specified by the name in a Tcl_Obj. + * + * Results: + * Returns TCL_OK if the namespace was resolved successfully, and stores + * a pointer to the namespace in the location specified by nsPtrPtr. If + * the namespace can't be found, or anything else goes wrong, this + * function returns TCL_ERROR and writes an error message to interp, + * if non-NULL. + * + * Side effects: + * May update the internal representation for the object, caching the + * namespace reference. The next time this function is called, the + * namespace value can be found quickly. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) { + const char *name = TclGetString(objPtr); + + if ((name[0] == ':') && (name[1] == ':')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found", name)); + } else { + /* + * Get the current namespace name. + */ + + NamespaceCurrentCmd(NULL, interp, 1, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found in \"%s\"", name, + Tcl_GetStringResult(interp))); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +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. + */ + + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + nsPtr = resNamePtr->nsPtr; + refNsPtr = resNamePtr->refNsPtr; + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && + (!refNsPtr || ((interp == refNsPtr->interp) && + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ + *nsPtrPtr = (Tcl_Namespace *) nsPtr; + return TCL_OK; + } + } + if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitNamespaceCmd -- + * + * This function is called to create the "namespace" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * Handle for the namespace command, or NULL on failure. + * + * Side effects: + * none + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitNamespaceCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap); +} + +/* + *---------------------------------------------------------------------- + * + * 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: + * + * namespace children ?name? ?pattern? + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceChildrenCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + Namespace *nsPtr, *childNsPtr; + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + const char *pattern = NULL; + Tcl_DString buffer; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Tcl_Obj *listPtr, *elemPtr; + + /* + * Get a pointer to the specified namespace, or the current namespace. + */ + + if (objc == 1) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } else if ((objc == 2) || (objc == 3)) { + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){ + return TCL_ERROR; + } + nsPtr = (Namespace *) namespacePtr; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?"); + return TCL_ERROR; + } + + /* + * Get the glob-style pattern, if any, used to narrow the search. + */ + + Tcl_DStringInit(&buffer); + if (objc == 3) { + const char *name = TclGetString(objv[2]); + + if ((*name == ':') && (*(name+1) == ':')) { + pattern = name; + } else { + Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); + if (nsPtr != globalNsPtr) { + TclDStringAppendLiteral(&buffer, "::"); + } + 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. + */ + + 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 ( +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL +#else + nsPtr->childTablePtr != NULL && + Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL +#endif + ) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern, -1)); + } + goto searchDone; + } +#ifndef BREAK_NAMESPACE_COMPAT + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); +#else + if (nsPtr->childTablePtr == NULL) { + goto searchDone; + } + entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); +#endif + 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); + } + + searchDone: + Tcl_SetObjResult(interp, listPtr); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceCodeCmd -- + * + * Invoked to implement the "namespace code" command to capture the + * namespace context of a command. Handles the following syntax: + * + * namespace code arg + * + * Here "arg" can be a list. "namespace code arg" produces a result + * equivalent to that produced by the command + * + * list ::namespace inscope [namespace current] $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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceCodeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Namespace *currNsPtr; + Tcl_Obj *listPtr, *objPtr; + register const char *arg; + int length; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg"); + 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[1], &length); + if (*arg==':' && length > 20 + && strncmp(arg, "::namespace inscope ", 20) == 0) { + Tcl_SetObjResult(interp, objv[1]); + 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. + */ + + TclNewObj(listPtr); + TclNewLiteralStringObj(objPtr, "::namespace"); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + TclNewLiteralStringObj(objPtr, "inscope"); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + TclNewLiteralStringObj(objPtr, "::"); + } else { + objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + Tcl_ListObjAppendElement(interp, listPtr, objv[1]); + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceCurrentCmd -- + * + * Invoked to implement the "namespace current" command which returns the + * fully-qualified name of the current namespace. Handles the following + * syntax: + * + * namespace current + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceCurrentCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Namespace *currNsPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + 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: + * + * namespace [namespace current]::bar { ... } + */ + + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceDeleteCmd -- + * + * Invoked to implement the "namespace delete" command to delete + * namespace(s). Handles the following syntax: + * + * namespace delete ?name name...? + * + * 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 + * 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 + * command does nothing. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceDeleteCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + const char *name; + register int i; + + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, 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. + */ + + for (i = 1; i < objc; i++) { + name = TclGetString(objv[i]); + namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); + if ((namespacePtr == NULL) + || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\" in namespace delete command", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", + TclGetString(objv[i]), NULL); + return TCL_ERROR; + } + } + + /* + * Okay, now delete each namespace. + */ + + for (i = 1; i < objc; i++) { + name = TclGetString(objv[i]); + namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); + if (namespacePtr) { + Tcl_DeleteNamespace(namespacePtr); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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: + * + * 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. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceEvalCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc, + objv); +} + +static int +NRNamespaceEvalCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + CmdFrame *invoker; + int word; + Tcl_Namespace *namespacePtr; + CallFrame *framePtr, **framePtrPtr; + Tcl_Obj *objPtr; + int result; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); + return TCL_ERROR; + } + + /* + * Try to resolve the namespace reference, caching the result in the + * namespace object along the way. + */ + + result = GetNamespaceFromObj(interp, objv[1], &namespacePtr); + + /* + * If the namespace wasn't found, try to create it. + */ + + if (result == TCL_ERROR) { + const char *name = TclGetString(objv[1]); + + namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); + if (namespacePtr == NULL) { + return TCL_ERROR; + } + } + + /* + * Make the specified namespace the current namespace and evaluate the + * command(s). + */ + + /* This is needed to satisfy GCC 3.3's strict aliasing rules */ + framePtrPtr = &framePtr; + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + namespacePtr, /*isProcCallFrame*/ 0); + + framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); + + if (objc == 3) { + /* + * TIP #280: Make actual argument location available to eval'd script. + */ + + objPtr = objv[2]; + invoker = iPtr->cmdFramePtr; + word = 3; + TclArgumentGet(interp, objPtr, &invoker, &word); + } else { + /* + * More than one argument: concatenate them together with spaces + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. + */ + + objPtr = Tcl_ConcatObj(objc-2, objv+2); + invoker = NULL; + word = 0; + } + + /* + * TIP #280: Make invoking context available to eval'd script. + */ + + TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval", + NULL, NULL); + return TclNREvalObjEx(interp, objPtr, 0, invoker, word); +} + +static int +NsEval_Callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Namespace *namespacePtr = data[0]; + + if (result == TCL_ERROR) { + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + char *cmd = data[1]; + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace %s \"%.*s%s\" script line %d)", + cmd, + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceExistsCmd -- + * + * 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 + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceExistsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceExportCmd -- + * + * 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: + * + * 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. + * + * To reset the namespace's export pattern list, specify the "-clear" + * flag. + * + * If there are no export patterns and the "-clear" flag isn't given, + * this command returns the namespace's current export list. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceExportCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int firstArg, i; + + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); + return TCL_ERROR; + } + + /* + * If no pattern arguments are given, and "-clear" isn't specified, return + * the namespace's current export pattern list. + */ + + if (objc == 1) { + Tcl_Obj *listPtr = Tcl_NewObj(); + + (void) Tcl_AppendExportList(interp, NULL, listPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + + /* + * Process the optional "-clear" argument. + */ + + firstArg = 1; + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + Tcl_Export(interp, NULL, "::", 1); + Tcl_ResetResult(interp); + firstArg++; + } + + /* + * Add each pattern to the namespace's export pattern list. + */ + + for (i = firstArg; i < objc; i++) { + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceForgetCmd -- + * + * 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. + * + * 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 + * 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. */ +{ + const char *pattern; + register int i, result; + + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); + return TCL_ERROR; + } + + for (i = 1; i < objc; i++) { + pattern = TclGetString(objv[i]); + result = Tcl_ForgetImport(interp, NULL, pattern); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceImportCmd -- + * + * Invoked to implement the "namespace import" command that imports + * commands into a namespace. Handles the following syntax: + * + * 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. + * + * 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 + * 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. */ +{ + int allowOverwrite = 0; + const char *string, *pattern; + register int i, result; + int firstArg; + + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); + return TCL_ERROR; + } + + /* + * Skip over the optional "-force" as the first argument. + */ + + firstArg = 1; + if (firstArg < objc) { + string = TclGetString(objv[firstArg]); + if ((*string == '-') && (strcmp(string, "-force") == 0)) { + allowOverwrite = 1; + firstArg++; + } + } else { + /* + * When objc == 1, 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; + } + + /* + * Handle the imports for each of the patterns. + */ + + for (i = firstArg; i < objc; i++) { + pattern = TclGetString(objv[i]); + result = Tcl_Import(interp, NULL, pattern, allowOverwrite); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceInscopeCmd -- + * + * 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: + * + * 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, + * + * namespace inscope ::foo {a b} c d e + * + * is equivalent to + * + * namespace eval ::foo [concat {a b} [list c d e]] + * + * 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. + * + * Side effects: + * Returns a result in the Tcl interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceInscopeCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, + objv); +} + +static int +NRNamespaceInscopeCmd( + 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; + int i; + Tcl_Obj *cmdObjPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); + return TCL_ERROR; + } + + /* + * Resolve the namespace reference. + */ + + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make the specified namespace the current namespace. + */ + + framePtrPtr = &framePtr; /* This is needed to satisfy GCC's + * strict aliasing rules. */ + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + namespacePtr, /*isProcCallFrame*/ 0); + + framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); + + /* + * 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 == 3) { + cmdObjPtr = objv[2]; + } else { + Tcl_Obj *concatObjv[2]; + register Tcl_Obj *listPtr; + + listPtr = Tcl_NewListObj(0, NULL); + for (i = 3; i < objc; i++) { + if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){ + Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ + return TCL_ERROR; + } + } + + concatObjv[0] = objv[2]; + concatObjv[1] = listPtr; + cmdObjPtr = Tcl_ConcatObj(2, concatObjv); + Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ + } + + TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope", + NULL, NULL); + return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceOriginCmd -- + * + * Invoked to implement the "namespace origin" command to return the + * fully-qualified name of the "real" command to which the specified + * "imported command" refers. Handles the following syntax: + * + * namespace origin name + * + * Results: + * An imported command is created in an namespace when that namespace + * imports a command from another namespace. If a command is imported + * into a sequence of namespaces a, b,...,n where each successive + * namespace just imports the command from the previous namespace, this + * 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 + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceOriginCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Command command, origCommand; + Tcl_Obj *resultPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + + command = Tcl_GetCommandFromObj(interp, objv[1]); + if (command == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + origCommand = TclGetOriginalCommand(command); + TclNewObj(resultPtr); + if (origCommand == NULL) { + /* + * The specified command isn't an imported command. Return the + * command's name qualified by the full name of the namespace it was + * defined in. + */ + + Tcl_GetCommandFullName(interp, command, resultPtr); + } else { + Tcl_GetCommandFullName(interp, origCommand, resultPtr); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceParentCmd -- + * + * Invoked to implement the "namespace parent" command that returns the + * fully-qualified name of the parent namespace for a specified + * namespace. Handles the following syntax: + * + * namespace parent ?name? + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceParentCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Namespace *nsPtr; + + if (objc == 1) { + nsPtr = TclGetCurrentNamespace(interp); + } else if (objc == 2) { + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); + return TCL_ERROR; + } + + /* + * Report the parent of the specified namespace. + */ + + if (nsPtr->parentPtr != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + nsPtr->parentPtr->fullName, -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pathList?"); + return TCL_ERROR; + } + + /* + * If no path is given, return the current path. + */ + + if (objc == 1) { + Tcl_Obj *resultObj = Tcl_NewObj(); + + for (i=0 ; i<nsPtr->commandPathLength ; i++) { + if (nsPtr->commandPathArray[i].nsPtr != NULL) { + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( + nsPtr->commandPathArray[i].nsPtr->fullName, -1)); + } + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } + + /* + * There is a path given, so parse it into an array of namespace pointers. + */ + + if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { + goto badNamespace; + } + if (nsObjc != 0) { + namespaceList = 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 = + 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(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: + * + * namespace qualifiers string + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceQualifiersCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register const char *name, *p; + int length; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + /* + * Find the end of the string, then work backward and find the start of + * the last "::" qualifier. + */ + + name = TclGetString(objv[1]); + for (p = name; *p != '\0'; p++) { + /* empty body */ + } + while (--p >= name) { + if ((*p == ':') && (p > name) && (*(p-1) == ':')) { + p -= 2; /* Back up over the :: */ + while ((p >= name) && (*p == ':')) { + 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 > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?script?"); + return TCL_ERROR; + } + + currNsPtr = TclGetCurrentNamespace(interp); + + if (objc == 1) { + /* + * 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[1]); + if (rc == TCL_OK) { + Tcl_SetObjResult(interp, objv[1]); + } + return rc; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNamespaceUnknownHandler -- + * + * Returns the unknown command handler registered for the given + * namespace. + * + * Results: + * Returns the current unknown command handler, or NULL if none exists + * for the namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_GetNamespaceUnknownHandler( + Tcl_Interp *interp, /* The interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr) /* The namespace. */ +{ + Namespace *currNsPtr = (Namespace *) nsPtr; + + if (currNsPtr->unknownHandlerPtr == NULL && + currNsPtr == ((Interp *) interp)->globalNsPtr) { + /* + * Default handler for global namespace is "::unknown". For all other + * namespaces, it is NULL (which falls back on the global unknown + * handler). + */ + + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + return currNsPtr->unknownHandlerPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetNamespaceUnknownHandler -- + * + * Sets the unknown command handler for the given namespace to the + * command prefix passed. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Sets the namespace unknown command handler. If the passed in handler + * is NULL or an empty list, then the handler is reset to its default. If + * an error occurs, then an error message is left in the interpreter + * result. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetNamespaceUnknownHandler( + Tcl_Interp *interp, /* Interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ + Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ +{ + int lstlen = 0; + Namespace *currNsPtr = (Namespace *) nsPtr; + + /* + * Ensure that we check for errors *first* before we change anything. + */ + + if (handlerPtr != NULL) { + if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { + /* + * Not a list. + */ + + return TCL_ERROR; + } + if (lstlen > 0) { + /* + * We are going to be saving this handler. Increment the reference + * count before decrementing the refcount on the previous handler, + * so that nothing strange can happen if we are told to set the + * handler to the previous value. + */ + + Tcl_IncrRefCount(handlerPtr); + } + } + + /* + * Remove old handler next. + */ + + if (currNsPtr->unknownHandlerPtr != NULL) { + Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr); + } + + /* + * Install the new handler. + */ + + if (lstlen > 0) { + /* + * Just store the handler. It already has the correct reference count. + */ + + currNsPtr->unknownHandlerPtr = handlerPtr; + } else { + /* + * If NULL or an empty list is passed, this resets to the default + * handler. + */ + + currNsPtr->unknownHandlerPtr = NULL; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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: + * + * namespace tail string + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceTailCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register const char *name, *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + /* + * Find the end of the string, then work backward and find the last "::" + * qualifier. + */ + + name = TclGetString(objv[1]); + for (p = name; *p != '\0'; p++) { + /* empty body */ + } + while (--p > name) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; /* Just after the last "::" */ + break; + } + } + + if (p >= name) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceUpvarCmd -- + * + * Invoked to implement the "namespace upvar" command, that creates + * variables in the current scope linked to variables in another + * namespace. Handles the following syntax: + * + * namespace upvar ns otherVar myVar ?otherVar myVar ...? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Creates new variables in the current scope, linked to the + * corresponding variables in the stipulated nmamespace. If anything goes + * wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceUpvarCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *nsPtr, *savedNsPtr; + Var *otherPtr, *arrayPtr; + const char *myName; + + if (objc < 2 || (objc & 1)) { + Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?"); + return TCL_ERROR; + } + + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { + return TCL_ERROR; + } + + objc -= 2; + objv += 2; + + 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|TCL_AVOID_RESOLVERS), + "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 + * fully-qualified name of a command or variable. If the specified + * command or variable does not exist, it returns "". Handles the + * following syntax: + * + * namespace which ?-command? ?-variable? name + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceWhichCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const opts[] = { + "-command", "-variable", NULL + }; + int lookupType = 0; + Tcl_Obj *resultPtr; + + if (objc < 2 || objc > 3) { + badArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name"); + return TCL_ERROR; + } else if (objc == 3) { + /* + * Look for a flag controlling the lookup. + */ + + if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, + &lookupType) != TCL_OK) { + /* + * Preserve old style of error message! + */ + + Tcl_ResetResult(interp); + goto badArgs; + } + } + + TclNewObj(resultPtr); + switch (lookupType) { + case 0: { /* -command */ + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); + + if (cmd != NULL) { + Tcl_GetCommandFullName(interp, cmd, resultPtr); + } + break; + } + case 1: { /* -variable */ + Tcl_Var var = Tcl_FindNamespaceVar(interp, + TclGetString(objv[objc-1]), NULL, /*flags*/ 0); + + if (var != NULL) { + Tcl_GetVariableFullName(interp, var, resultPtr); + } + break; + } + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeNsNameInternalRep -- + * + * Frees the resources associated with a nsName object's internal + * representation. + * + * Results: + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +FreeNsNameInternalRep( + register Tcl_Obj *objPtr) /* nsName object with internal representation + * to free. */ +{ + ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + + /* + * Decrement the reference count of the namespace. If there are no more + * references, free it up. + */ + + 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. + */ + + TclNsDecrRefCount(resNamePtr->nsPtr); + ckfree(resNamePtr); + } + objPtr->typePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupNsNameInternalRep -- + * + * Initializes the internal representation of a nsName object to a copy + * of the internal representation of another nsName object. + * + * Results: + * None. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +DupNsNameInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +{ + ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; + + copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + resNamePtr->refCount++; + copyPtr->typePtr = &nsNameType; +} + +/* + *---------------------------------------------------------------------- + * + * SetNsNameFromAny -- + * + * 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. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + 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. + */ + + 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); + } + return TCL_ERROR; + } + + nsPtr->refCount++; + resNamePtr = 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNamespaceCommandTable -- + * + * Returns the hash table of commands. + * + * Results: + * Pointer to the hash table. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashTable * +TclGetNamespaceCommandTable( + Tcl_Namespace *nsPtr) +{ + return &((Namespace *) nsPtr)->cmdTable; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNamespaceChildTable -- + * + * Returns the hash table of child namespaces. + * + * Results: + * Pointer to the hash table. + * + * Side effects: + * Might allocate memory. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashTable * +TclGetNamespaceChildTable( + Tcl_Namespace *nsPtr) +{ + Namespace *nPtr = (Namespace *) nsPtr; +#ifndef BREAK_NAMESPACE_COMPAT + return &nPtr->childTable; +#else + if (nPtr->childTablePtr == NULL) { + nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); + } + return nPtr->childTablePtr; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclLogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. When pc and + * tosPtr are non-NULL, conveying a bytecode execution "inner context", + * and the offending instruction is suitable, that inner context is + * recorded in errorStack. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. + * + *---------------------------------------------------------------------- + */ + +void +TclLogCommandInfo( + 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). */ + const unsigned char *pc, /* Current pc of bytecode execution context */ + Tcl_Obj **tosPtr) /* Current stack of bytecode execution + * context */ +{ + 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; + } + + if (command != NULL) { + /* + * 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); + } + } + } + + /* + * TIP #348 + */ + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + if (iPtr->resetErrorStack) { + int len; + + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; + + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); + } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(command, length)); + } + } + + if (!iPtr->framePtr->objc) { + /* + * Special frame, nothing to report. + */ + } else if (iPtr->varFramePtr != iPtr->framePtr) { + /* + * uplevel case, [lappend errorstack UP $relativelevel] + */ + + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + iPtr->framePtr->level - iPtr->varFramePtr->level)); + } else if (iPtr->framePtr != iPtr->rootFramePtr) { + /* + * normal case, [lappend errorstack CALL [info level 0]] + */ + + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( + iPtr->framePtr->objc, iPtr->framePtr->objv)); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclErrorStackResetIf -- + * + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. + * + * Results: + * None. + * + * Side effects: + * Reset errorstack if it needs be, and in that case remember the + * passed-in error message as inner context. + * + *---------------------------------------------------------------------- + */ + +void +TclErrorStackResetIf( + Tcl_Interp *interp, + const char *msg, + int length) +{ + Interp *iPtr = (Interp *) interp; + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + if (iPtr->resetErrorStack) { + int len; + + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(msg, length)); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo/errorStack 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). */ +{ + TclLogCommandInfo(interp, script, command, length, NULL, NULL); +} + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ |