/* * 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. * * 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. * * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.8 2005/07/26 16:20:44 dgp Exp $ */ #include "tclInt.h" /* * Flag passed to TclGetNamespaceForQualName to indicate that it should * search for a namespace rather than a command or variable inside a * namespace. Note that this flag's value must not conflict with the values * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN. */ #define FIND_ONLY_NS 0x1000 /* * Initial size of stack allocated space for tail list - used when resetting * shadowed command references in the functin: TclResetShadowedCmdRefs. */ #define NUM_TRAIL_ELEMS 5 /* * Count of the number of namespaces created. This value is used as a * unique id for each namespace. */ static long numNsCreated = 0; TCL_DECLARE_MUTEX(nsMutex) /* * 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 namespace pointer. */ long nsId; /* nsPtr's unique namespace id. Used to * verify that nsPtr is still valid * (e.g., it's possible that the namespace * was deleted and a new one created at * the same address). */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that * contains the referenced namespace). */ int refCount; /* Reference count: 1 for each nsName * object that has a pointer to this * ResolvedNsName structure as its internal * rep. This structure can be freed when * refCount becomes zero. */ } ResolvedNsName; /* * Declarations for procedures local to this file: */ static void DeleteImportedCmd _ANSI_ARGS_(( ClientData clientData)); static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static void FreeNsNameInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static int GetNamespaceFromObj _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr)); static int InvokeImportedCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceChildrenCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceCodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceCurrentCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceDeleteCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceEvalCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceExistsCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceExportCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceForgetCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); static int NamespaceImportCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceInscopeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceOriginCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceParentCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceQualifiersCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceTailCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceWhichCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int SetNsNameFromAny _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * This structure defines a Tcl object type that contains a * namespace reference. It is used in commands that take the * name of a namespace as an argument. The namespace reference * is resolved, and the result in cached in the object. */ Tcl_ObjType tclNsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ UpdateStringOfNsName, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * TclInitNamespaceSubsystem -- * * This procedure is called to initialize all the structures that * are used by namespaces on a per-process basis. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclInitNamespaceSubsystem() { /* * 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(interp) register Tcl_Interp *interp; /* Interpreter whose current namespace is * being queried. */ { register Interp *iPtr = (Interp *) interp; register Namespace *nsPtr; if (iPtr->varFramePtr != NULL) { nsPtr = iPtr->varFramePtr->nsPtr; } else { nsPtr = iPtr->globalNsPtr; } return (Tcl_Namespace *) nsPtr; } /* *---------------------------------------------------------------------- * * 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(interp) register Tcl_Interp *interp; /* Interpreter whose global namespace * should be returned. */ { register Interp *iPtr = (Interp *) interp; return (Tcl_Namespace *) iPtr->globalNsPtr; } /* *---------------------------------------------------------------------- * * 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(interp, callFramePtr, namespacePtr, isProcCallFrame) Tcl_Interp *interp; /* Interpreter in which the new call frame * is to be pushed. */ Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to * push. Storage for this has already been * allocated by the caller; typically this * is the address of a CallFrame structure * allocated on the caller's C stack. The * call frame will be initialized by this * procedure. The caller can pop the frame * later with Tcl_PopCallFrame, and it is * responsible for freeing the frame's * storage. */ Tcl_Namespace *namespacePtr; /* Points to the namespace in which the * frame will execute. If NULL, the * interpreter's current namespace will * be used. */ int isProcCallFrame; /* If nonzero, the frame represents a * called Tcl procedure and may have local * vars. Vars will ordinarily be looked up * in the frame. If new variables are * created, they will be created in the * frame. If 0, the frame is for a * "namespace eval" or "namespace inscope" * command and var references are treated * as references to namespace variables. */ { Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; if (nsPtr->flags & NS_DEAD) { 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 = 1; } framePtr->procPtr = NULL; /* no called procedure */ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = 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(interp) Tcl_Interp* interp; /* Interpreter with call frame to pop. */ { register Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* * It's important to remove the call frame from the interpreter's stack * of call frames before deleting local variables, so that traces * invoked by the variable deletion don't see the partially-deleted * frame. */ iPtr->framePtr = framePtr->callerPtr; iPtr->varFramePtr = framePtr->callerVarPtr; if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree((char *) framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); } /* * Decrement the namespace's count of active call frames. If the * namespace is "dying" and there are no more active call frames, * call Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = 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(interp, name, clientData, deleteProc) Tcl_Interp *interp; /* Interpreter in which a new namespace * is being created. Also used for * error reporting. */ CONST char *name; /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ ClientData clientData; /* One-word value to store with * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure called to delete client * data when the namespace is deleted. * NULL if no procedure should be * called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; CONST char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; int newEntry; /* * 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 = ""; } else if (*name == '\0') { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); return NULL; } else { /* * Find the parent for the new namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing * "::"s after the namespace's name which we ignore. The new * namespace was already (recursively) created and is pointed to * by parentPtr. */ if (*simpleName == '\0') { return (Tcl_Namespace *) parentPtr; } /* * Check for a bad namespace name and make sure that the name * does not already exist in the parent namespace. */ if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create namespace \"", name, "\": already exists", (char *) NULL); return NULL; } } /* * Create the new namespace and root it in its parent. Increment the * count of namespaces created. */ nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); nsPtr->fullName = NULL; /* set below */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; nsPtr->parentPtr = parentPtr; Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); Tcl_MutexLock(&nsMutex); numNsCreated++; nsPtr->nsId = numNsCreated; Tcl_MutexUnlock(&nsMutex); nsPtr->interp = interp; nsPtr->flags = 0; nsPtr->activationCount = 0; nsPtr->refCount = 0; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; nsPtr->cmdRefEpoch = 0; nsPtr->resolverEpoch = 0; nsPtr->cmdResProc = NULL; nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, &newEntry); Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } /* * Build the fully qualified name for this namespace. */ Tcl_DStringInit(&buffer1); Tcl_DStringInit(&buffer2); for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { if (ancestorPtr != globalNsPtr) { Tcl_DStringAppend(&buffer1, "::", 2); Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); } Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); Tcl_DStringSetLength(&buffer2, 0); Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); Tcl_DStringSetLength(&buffer1, 0); } name = Tcl_DStringValue(&buffer2); nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); strcpy(nsPtr->fullName, name); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); /* * 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(namespacePtr) Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; /* * If the namespace is on the call frame stack, it is marked as "dying" * (NS_DYING is OR'd into its flags): the namespace can't be looked up * by name but its commands and variables are still usable by those * active call frames. When all active call frames referring to the * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will * call this procedure again to delete everything in the namespace. * If no nsName objects refer to the namespace (i.e., if its refCount * is zero), its commands and variables are deleted and the storage for * its namespace structure is freed. Otherwise, if its refCount is * nonzero, the namespace's commands and variables are deleted but the * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's * flags to allow the namespace resolution code to recognize that the * namespace is "deleted". The structure's storage is freed by * FreeNsNameInternalRep when its refCount reaches 0. */ if (nsPtr->activationCount > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; } else { /* * 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. */ 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. */ TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable); Tcl_DeleteHashTable(&nsPtr->childTable); Tcl_DeleteHashTable(&nsPtr->cmdTable); /* * If the reference count is 0, then discard the namespace. * Otherwise, mark it as "dead" so that it can't be used. */ if (nsPtr->refCount == 0) { NamespaceFree(nsPtr); } else { nsPtr->flags |= NS_DEAD; } } } } /* *---------------------------------------------------------------------- * * 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. Global variables like * "errorInfo" and "errorCode" need to remain intact while other * namespaces and commands are torn down, in case any errors occur. * * Results: * None. * * Side effects: * Removes this namespace from its parent's child namespace hashtable. * Deletes all commands, variables and namespaces in this namespace. * If this is the global namespace, the "errorInfo" and "errorCode" * variables are left alone and deleted later. * *---------------------------------------------------------------------- */ void TclTeardownNamespace(nsPtr) register Namespace *nsPtr; /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Namespace *childNsPtr; Tcl_Command cmd; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); int i; /* * Start by destroying the namespace's variable table, * since variables might trigger traces. */ if (nsPtr == globalNsPtr) { /* * This is the global namespace. Tearing it down will destroy the * ::errorInfo and ::errorCode variables. We save and restore them * in case there are any errors in progress, so the error details * they contain will not be lost. See test namespace-8.5 */ Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode", NULL, TCL_GLOBAL_ONLY); if (errorInfo) { Tcl_IncrRefCount(errorInfo); } if (errorCode) { Tcl_IncrRefCount(errorCode); } TclDeleteVars(iPtr, &nsPtr->varTable); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); if (errorInfo) { Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL, errorInfo, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(errorInfo); } if (errorCode) { Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL, errorCode, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(errorCode); } } else { /* * Variable table should be cleared but not freed! TclDeleteVars * frees it, so we reinitialize it afterwards. */ TclDeleteVars(iPtr, &nsPtr->varTable); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); } /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the * command table. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } 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(&nsPtr->parentPtr->childTable, nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce * itself from its parent. You can't traverse a hash table * properly if its elements are being deleted. We use only * the Tcl_FirstHashEntry function to be safe. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); Tcl_DeleteNamespace(childNsPtr); } /* * Free the namespace's export pattern array. */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } ckfree((char *) 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(nsPtr) 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((char *) 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(interp, namespacePtr, pattern, resetListFirst) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr; /* Points to the namespace from which * commands are to be exported. NULL for * the current namespace. */ CONST char *pattern; /* String pattern indicating which commands * to export. This pattern may not include * any namespace qualifiers; only commands * in the specified namespace may be * exported. */ int resetListFirst; /* If nonzero, resets the namespace's * export list before appending. */ { #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(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((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } } /* * Check that the pattern doesn't have namespace qualifiers. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", (char *) NULL); 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 (nsPtr->exportArrayPtr == NULL) { nsPtr->exportArrayPtr = (char **) ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; } else if (neededElems > nsPtr->maxExportPatterns) { int numNewElems = 2 * nsPtr->maxExportPatterns; size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); size_t newBytes = numNewElems * sizeof(char *); char **newPtr = (char **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes); ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = (char **) newPtr; nsPtr->maxExportPatterns = numNewElems; } /* * Add the pattern to the namespace's array of export patterns. */ len = strlen(pattern); patternCpy = (char *) ckalloc((unsigned) (len + 1)); strcpy(patternCpy, pattern); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; 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(interp, namespacePtr, objPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ Tcl_Namespace *namespacePtr; /* Points to the namespace whose export * pattern list is appended onto objPtr. * NULL for the current namespace. */ Tcl_Obj *objPtr; /* Points to the Tcl object onto which the * export pattern list is appended. */ { Namespace *nsPtr; int i, result; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(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(interp, namespacePtr, pattern, allowOverwrite) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr; /* Points to the namespace into which the * commands are to be imported. NULL for * the current namespace. */ CONST char *pattern; /* String pattern indicating which commands * to import. This pattern should be * qualified by the name of the namespace * from which to import the command(s). */ int allowOverwrite; /* If nonzero, allow existing commands to * be overwritten by imported commands. * If 0, return an error if an imported * cmd conflicts with an existing one. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr, *importNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; Command *cmdPtr; ImportRef *refPtr; Tcl_Command autoCmd, importedCmd; ImportedCmdData *dataPtr; int wasExported, i, result; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) currNsPtr; } 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. */ autoCmd = Tcl_FindCommand(interp, "auto_import", (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); if (autoCmd != NULL) { Tcl_Obj *objv[2]; objv[0] = Tcl_NewStringObj("auto_import", -1); Tcl_IncrRefCount(objv[0]); objv[1] = Tcl_NewStringObj(pattern, -1); Tcl_IncrRefCount(objv[1]); cmdPtr = (Command *) autoCmd; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, 2, objv); Tcl_DecrRefCount(objv[0]); Tcl_DecrRefCount(objv[1]); if (result != TCL_OK) { return TCL_ERROR; } 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_SetStringObj(Tcl_GetObjResult(interp), "empty import pattern", -1); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in import pattern \"", pattern, "\"", (char *) NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no namespace specified in import pattern \"", pattern, "\"", (char *) NULL); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "import pattern \"", pattern, "\" tries to import from namespace \"", importNsPtr->name, "\" into itself", (char *) 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. */ for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern)) { /* * The command cmdName in the source namespace matches the * pattern. Check whether it was exported. If it wasn't, * we ignore it. */ Tcl_HashEntry *found; wasExported = 0; for (i = 0; i < importNsPtr->numExportPatterns; i++) { if (Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i])) { wasExported = 1; break; } } if (!wasExported) { continue; } /* * 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_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); /* * Check whether creating the new imported command in the * current namespace would create a cycle of imported * command references. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if ((found != NULL) && cmdPtr->deleteProc == DeleteImportedCmd) { Command *overwrite = (Command *) Tcl_GetHashValue(found); Command *link = cmdPtr; while (link->deleteProc == DeleteImportedCmd) { ImportedCmdData *dataPtr; dataPtr = (ImportedCmdData *) link->objClientData; link = dataPtr->realCmdPtr; if (overwrite == link) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "import pattern \"", pattern, "\" would create a loop containing ", "command \"", Tcl_DStringValue(&ds), "\"", (char *) NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } } } dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), InvokeImportedCmd, (ClientData) dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import * command and add it to the import ref list in the "real" * command. */ refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { Command *overwrite = (Command *) Tcl_GetHashValue(found); if (overwrite->deleteProc == DeleteImportedCmd) { ImportedCmdData *dataPtr = (ImportedCmdData *) overwrite->objClientData; if (dataPtr->realCmdPtr == (Command *) Tcl_GetHashValue(hPtr)) { /* Repeated import of same command -- acceptable */ return TCL_OK; } } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't import command \"", cmdName, "\": already exists", (char *) NULL); return TCL_ERROR; } } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_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(interp, namespacePtr, pattern) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr; /* Points to the namespace from which * previously imported commands should be * removed. NULL for current namespace. */ CONST char *pattern; /* String pattern indicating which imported * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } /* * Parse the pattern into its namespace-qualification (if any) * and the simple pattern. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in namespace forget pattern \"", pattern, "\"", (char *) NULL); return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { /* * The pattern is simple. * Delete any imported commands that match it. */ for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Command *cmdPtr = (Command *) 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_Command) 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 = (ImportedCmdData *) 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 procedure returns the original command it * refers to. * * Results: * If the command was imported into a sequence of namespaces a, b,...,n * where each successive namespace just imports the command from the * previous namespace, this procedure returns the Tcl_Command token in * the first namespace, a. Otherwise, if the specified command is not * an imported command, the procedure returns NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command TclGetOriginalCommand(command) Tcl_Command command; /* The imported command for which the * original command should be returned. */ { register Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { return (Tcl_Command) NULL; } while (cmdPtr->deleteProc == DeleteImportedCmd) { dataPtr = (ImportedCmdData *) 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 InvokeImportedCmd(clientData, interp, objc, objv) ClientData clientData; /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* The argument objects. */ { register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; register Command *realCmdPtr = dataPtr->realCmdPtr; return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, objc, objv); } /* *---------------------------------------------------------------------- * * DeleteImportedCmd -- * * Invoked by Tcl whenever an imported command is deleted. The "real" * command keeps a list of all the imported commands that refer to it, * so those imported commands can be deleted when the real command is * deleted. This procedure removes the imported command reference from * the real command's list, and frees up the memory associated with * the imported command. * * Results: * None. * * Side effects: * Removes the imported command from the real command's import list. * *---------------------------------------------------------------------- */ static void DeleteImportedCmd(clientData) ClientData clientData; /* Points to the imported command's * ImportedCmdData structure. */ { ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; register ImportRef *refPtr, *prevPtr; prevPtr = NULL; for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; refPtr = refPtr->nextPtr) { 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((char *) refPtr); ckfree((char *) dataPtr); return; } prevPtr = refPtr; } 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 procedure returns * a pointer to the namespace that contains the item. A qualified name * consists of the "simple" name of an item qualified by the names of * an arbitrary number of containing namespace separated by "::"s. If * the qualified name starts with "::", it is interpreted absolutely * from the global namespace. Otherwise, it is interpreted relative to * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr * is NULL, the name is interpreted relative to the current namespace. * * A relative name like "foo::bar::x" can be found starting in either * the current namespace or in the global namespace. So each search * usually follows two tracks, and two possible namespaces are * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to * NULL, then that path failed. * * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is * sought only in the global :: namespace. The alternate search * (also) starting from the global namespace is ignored and * *altNsPtrPtr is set NULL. * * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified * name is sought only in the namespace specified by cxtNsPtr. The * alternate search starting from the global namespace is ignored and * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and * the search starts from the namespace specified by cxtNsPtr. * * If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace * components of the qualified name that cannot be found are * automatically created within their specified parent. This makes sure * that functions like Tcl_CreateCommand always succeed. There is no * alternate search path, so *altNsPtrPtr is set NULL. * * If "flags" contains FIND_ONLY_NS, the qualified name is treated as a * reference to a namespace, and the entire qualified name is * followed. If the name is relative, the namespace is looked up only * in the current namespace. A pointer to the namespace is stored in * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if * FIND_ONLY_NS is not specified, only the leading components are * treated as namespace names, and a pointer to the simple name of the * final component is stored in *simpleNamePtr. * * Results: * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible * namespaces which represent the last (containing) namespace in the * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr * to NULL, then the search along that path failed. The procedure also * stores a pointer to the simple name of the final component in * *simpleNamePtr. If the qualified name is "::" or was treated as a * namespace reference (FIND_ONLY_NS), the procedure stores a pointer * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * * If there is an error, this procedure returns TCL_ERROR. If "flags" * contains TCL_LEAVE_ERR_MSG, an error message is returned in the * interpreter's result object. Otherwise, the interpreter's result * object is left unchanged. * * *actualCxtPtrPtr is set to the actual context namespace. It is * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr * is NULL, it is set to the current namespace context. * * For backwards compatibility with the TclPro byte code loader, * this function always returns TCL_OK. * * Side effects: * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be * created. * *---------------------------------------------------------------------- */ int TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) Tcl_Interp *interp; /* Interpreter in which to find the * namespace containing qualName. */ CONST char *qualName; /* A namespace-qualified name of an * command, variable, or namespace. */ Namespace *cxtNsPtr; /* The namespace in which to start the * search for qualName's namespace. If NULL * start from the current namespace. * Ignored if TCL_GLOBAL_ONLY is set. */ int flags; /* Flags controlling the search: an OR'd * combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, * CREATE_NS_IF_UNKNOWN, and * FIND_ONLY_NS. */ Namespace **nsPtrPtr; /* Address where procedure stores a pointer * to containing namespace if qualName is * found starting from *cxtNsPtr or, if * TCL_GLOBAL_ONLY is set, if qualName is * found in the global :: namespace. NULL * is stored otherwise. */ Namespace **altNsPtrPtr; /* Address where procedure stores a pointer * to containing namespace if qualName is * found starting from the global :: * namespace. NULL is stored if qualName * isn't found starting from :: or if the * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag * is set. */ Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer * to the actual namespace from which the * search started. This is either cxtNsPtr, * the :: namespace if TCL_GLOBAL_ONLY was * specified, or the current namespace if * cxtNsPtr was NULL. */ CONST char **simpleNamePtr; /* Address where procedure stores the * simple name at end of the qualName, or * NULL if qualName is "::" or the flag * FIND_ONLY_NS was specified. */ { 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) { if (iPtr->varFramePtr != NULL) { nsPtr = iPtr->varFramePtr->nsPtr; } else { nsPtr = iPtr->globalNsPtr; } } start = qualName; /* pts 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 | 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 FIND_ONLY_NS * was specified, look this up as a namespace. Otherwise, * start is the name of a cmd or var and we are done. */ if (flags & FIND_ONLY_NS) { 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. */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } /* * Look up the namespace qualifier nsName in the current namespace * context. If it isn't found but CREATE_NS_IF_UNKNOWN is set, * create that qualifying namespace. This is needed for procedures * like Tcl_CreateCommand that cannot fail. */ if (nsPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); if (entryPtr != NULL) { nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else if (flags & CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame frame; (void) Tcl_PushCallFrame(interp, &frame, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); Tcl_PopCallFrame(interp); if (nsPtr == NULL) { panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ nsPtr = NULL; } } /* * Look up the namespace qualifier in the alternate search path too. */ if (altNsPtr != NULL) { entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); if (entryPtr != NULL) { altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else { altNsPtr = NULL; } } /* * If both search paths have failed, return NULL results. */ if ((nsPtr == NULL) && (altNsPtr == NULL)) { *nsPtrPtr = NULL; *altNsPtrPtr = NULL; *simpleNamePtr = NULL; Tcl_DStringFree(&buffer); return TCL_OK; } start = end; } /* * 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 & 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 & 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(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * namespace. */ CONST char *name; /* Namespace name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set * or if the name starts with "::". * Otherwise, points to namespace in which * to resolve name; if NULL, look up name * in the current namespace. */ register int flags; /* Flags controlling namespace lookup: an * OR'd combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; CONST char *dummy; /* * Find the namespace(s) that contain the specified namespace name. * Add the FIND_ONLY_NS flag to resolve the name all the way down * to its last component, a namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace \"", name, "\"", (char *) 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(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * command and to report errors. */ CONST char *name; /* Command's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. * Otherwise, points to namespace in which * to resolve name. If NULL, look up name * in the current namespace. */ int flags; /* An OR'd combination of flags: * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY * (look up only in contextNsPtr, or the * current namespace if contextNsPtr is * NULL), and TCL_LEAVE_ERR_MSG. If both * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY * are given, TCL_GLOBAL_ONLY is * ignored. */ { Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; CONST char *simpleName; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; register int search; int result; Tcl_Command cmd; /* * If this namespace has a command resolver, then give it first * crack at the command resolution. If the interpreter has any * command resolvers, consult them next. The command resolver * procedures may return a Tcl_Command value, they may signal * to continue onward, or they may signal an error. */ if ((flags & TCL_GLOBAL_ONLY) != 0) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { resPtr = iPtr->resolverPtr; 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) { return cmd; } else if (result != TCL_CONTINUE) { return (Tcl_Command) NULL; } } /* * Find the namespace(s) that contain the command. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. * Be sure to check both possible search paths: from the specified * namespace context and from the global namespace. */ cmdPtr = NULL; for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } if (cmdPtr != NULL) { return (Tcl_Command) cmdPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown command \"", name, "\"", (char *) NULL); } return (Tcl_Command) NULL; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespaceVar -- * * Searches for a namespace variable, a variable not local to a * procedure. The variable can be either a scalar or an array, but * may not be an element of an array. * * Results: * Returns a token for the variable if it is found. Otherwise, if it * can't be found or there is an error, returns NULL and leaves an * error message in the interpreter's result object if "flags" * contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Var Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * variable. */ CONST char *name; /* Variable's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. * Otherwise, points to namespace in which * to resolve name. If NULL, look up name * in the current namespace. */ int flags; /* An OR'd combination of flags: * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY * (look up only in contextNsPtr, or the * current namespace if contextNsPtr is * NULL), and TCL_LEAVE_ERR_MSG. If both * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY * are given, TCL_GLOBAL_ONLY is * ignored. */ { Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; CONST char *simpleName; Tcl_HashEntry *entryPtr; Var *varPtr; register int search; int result; Tcl_Var var; /* * If this namespace has a variable resolver, then give it first * crack at the variable resolution. It may return a Tcl_Var * value, it may signal to continue onward, or it may signal * an error. */ if ((flags & TCL_GLOBAL_ONLY) != 0) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { result = (*resPtr->varResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { return var; } else if (result != TCL_CONTINUE) { return (Tcl_Var) NULL; } } /* * Find the namespace(s) that contain the variable. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. * Be sure to check both possible search paths: from the specified * namespace context and from the global namespace. */ varPtr = NULL; for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); } } } if (varPtr != NULL) { return (Tcl_Var) varPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown variable \"", name, "\"", (char *) NULL); } return (Tcl_Var) 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(interp, newCmdPtr) Tcl_Interp *interp; /* Interpreter containing the new command. */ Command *newCmdPtr; /* Points to the new command. */ { char *cmdName; Tcl_HashEntry *hPtr; register Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); int found, i; /* * This procedure generates an array used to hold the trail list. This * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ Namespace *(trailStorage[NUM_TRAIL_ELEMS]); Namespace **trailPtr = trailStorage; int trailFront = -1; int trailSize = NUM_TRAIL_ELEMS; /* * Start at the namespace containing the new command, and work up * through the list of parents. Stop just before the global namespace, * since the global namespace can't "shadow" its own entries. * * 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]; hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, trailNsPtr->name); if (hPtr != NULL) { shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); } else { found = 0; break; } } /* * If shadowNsPtr contains a command named cmdName, we invalidate * all of the command refs cached in nsPtr. As a boundary case, * shadowNsPtr is initially :: and we check for case 1. above. */ if (found) { hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); if (hPtr != NULL) { nsPtr->cmdRefEpoch++; /* * If the shadowed command was compiled to bytecodes, we * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) { nsPtr->resolverEpoch++; } } } /* * Insert nsPtr at the front of the trail list: i.e., at the end * of the trailPtr array. */ trailFront++; if (trailFront == trailSize) { size_t currBytes = trailSize * sizeof(Namespace *); int newSize = 2*trailSize; size_t newBytes = newSize * sizeof(Namespace *); Namespace **newPtr = (Namespace **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } trailPtr = newPtr; trailSize = newSize; } trailPtr[trailFront] = nsPtr; } /* * Free any allocated storage. */ if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } } /* *---------------------------------------------------------------------- * * GetNamespaceFromObj -- * * Gets the namespace specified by the name in a Tcl_Obj. * * Results: * Returns TCL_OK if the namespace was resolved successfully, and * stores a pointer to the namespace in the location specified by * nsPtrPtr. If the namespace can't be found, the procedure stores * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, * this procedure returns TCL_ERROR. * * Side effects: * May update the internal representation for the object, caching the * namespace reference. The next time this procedure is called, the * namespace value can be found quickly. * * If anything goes wrong, an error message is left in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int GetNamespaceFromObj(interp, objPtr, nsPtrPtr) Tcl_Interp *interp; /* The current interpreter. */ Tcl_Obj *objPtr; /* The object to be resolved as the name * of a namespace. */ Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ { Interp *iPtr = (Interp *) interp; register ResolvedNsName *resNamePtr; register Namespace *nsPtr; Namespace *currNsPtr; CallFrame *savedFramePtr; int result = TCL_OK; char *name; /* * If the namespace name is fully qualified, do as if the lookup were * done from the global namespace; this helps avoid repeated lookups * of fully qualified names. */ savedFramePtr = iPtr->varFramePtr; name = Tcl_GetString(objPtr); if ((*name++ == ':') && (*name == ':')) { iPtr->varFramePtr = NULL; } currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); /* * Get the internal representation, converting to a namespace type if * needed. The internal representation is a ResolvedNsName that points * to the actual namespace. */ if (objPtr->typePtr != &tclNsNameType) { result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { goto done; } } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; /* * Check the context namespace of the resolved symbol to make sure that * it is fresh. If not, then force another conversion to the namespace * type, to discard the old rep and create a new one. Note that we * verify that the namespace id of the cached namespace is the same as * the id when we cached it; this insures that the namespace wasn't * deleted and a new one created at the same address. */ nsPtr = NULL; if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr) && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } } if (nsPtr == NULL) { /* try again */ result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { goto done; } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; if (resNamePtr != NULL) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } } } *nsPtrPtr = (Tcl_Namespace *) nsPtr; done: iPtr->varFramePtr = savedFramePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_NamespaceObjCmd -- * * Invoked to implement the "namespace" command that creates, deletes, * or manipulates Tcl namespaces. Handles the following syntax: * * namespace children ?name? ?pattern? * namespace code arg * namespace current * namespace delete ?name name...? * namespace eval name arg ?arg...? * namespace exists name * namespace export ?-clear? ?pattern pattern...? * namespace forget ?pattern pattern...? * namespace import ?-force? ?pattern pattern...? * namespace inscope name arg ?arg...? * namespace origin name * namespace parent ?name? * namespace qualifiers string * namespace tail string * namespace which ?-command? ?-variable? name * * Results: * Returns TCL_OK if the command is successful. Returns TCL_ERROR if * anything goes wrong. * * Side effects: * Based on the subcommand name (e.g., "import"), this procedure * dispatches to a corresponding procedure NamespaceXXXCmd defined * statically in this file. This procedure's side effects depend on * whatever that subcommand procedure does. If there is an error, this * procedure returns an error message in the interpreter's result * object. Otherwise it may return a result in the interpreter's result * object. * *---------------------------------------------------------------------- */ int Tcl_NamespaceObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Arbitrary value passed to cmd. */ Tcl_Interp *interp; /* Current interpreter. */ register int objc; /* Number of arguments. */ register Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { "children", "code", "current", "delete", "eval", "exists", "export", "forget", "import", "inscope", "origin", "parent", "qualifiers", "tail", "which", (char *) NULL }; enum NSSubCmdIdx { NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, NSTailIdx, NSWhichIdx }; int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } /* * Return an index reflecting the particular subcommand. */ result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, "option", /*flags*/ 0, (int *) &index); if (result != TCL_OK) { return result; } switch (index) { case NSChildrenIdx: result = NamespaceChildrenCmd(clientData, interp, objc, objv); break; case NSCodeIdx: result = NamespaceCodeCmd(clientData, interp, objc, objv); break; case NSCurrentIdx: result = NamespaceCurrentCmd(clientData, interp, objc, objv); break; case NSDeleteIdx: result = NamespaceDeleteCmd(clientData, interp, objc, objv); break; case NSEvalIdx: result = NamespaceEvalCmd(clientData, interp, objc, objv); break; case NSExistsIdx: result = NamespaceExistsCmd(clientData, interp, objc, objv); break; case NSExportIdx: result = NamespaceExportCmd(clientData, interp, objc, objv); break; case NSForgetIdx: result = NamespaceForgetCmd(clientData, interp, objc, objv); break; case NSImportIdx: result = NamespaceImportCmd(clientData, interp, objc, objv); break; case NSInscopeIdx: result = NamespaceInscopeCmd(clientData, interp, objc, objv); break; case NSOriginIdx: result = NamespaceOriginCmd(clientData, interp, objc, objv); break; case NSParentIdx: result = NamespaceParentCmd(clientData, interp, objc, objv); break; case NSQualifiersIdx: result = NamespaceQualifiersCmd(clientData, interp, objc, objv); break; case NSTailIdx: result = NamespaceTailCmd(clientData, interp, objc, objv); break; case NSWhichIdx: result = NamespaceWhichCmd(clientData, interp, objc, objv); break; } return result; } /* *---------------------------------------------------------------------- * * 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 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 == 2) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace \"", Tcl_GetString(objv[2]), "\" in namespace children command", (char *) NULL); return TCL_ERROR; } nsPtr = (Namespace *) namespacePtr; } else { Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); return TCL_ERROR; } /* * Get the glob-style pattern, if any, used to narrow the search. */ Tcl_DStringInit(&buffer); if (objc == 4) { char *name = Tcl_GetString(objv[3]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); if (nsPtr != globalNsPtr) { Tcl_DStringAppend(&buffer, "::", 2); } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); } } /* * Create a list containing the full names of all child namespaces * whose names match the specified pattern, if any. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemPtr); } entryPtr = Tcl_NextHashEntry(&search); } 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 procedure returns an error * message as the result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceCodeCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; register char *arg, *p; int length; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg"); return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. */ arg = Tcl_GetStringFromObj(objv[2], &length); while (*arg == ':') { arg++; length--; } if ((*arg == 'n') && (length > 17) && (strncmp(arg, "namespace", 9) == 0)) { for (p = (arg + 9); (*p == ' '); p++) { /* empty body: skip over spaces */ } if ((*p == 'i') && ((p + 7) <= (arg + length)) && (strncmp(p, "inscope", 7) == 0)) { Tcl_SetObjResult(interp, objv[2]); return TCL_OK; } } /* * Otherwise, construct a scoped command by building a list with * "namespace inscope", the full name of the current namespace, and * the argument "arg". By constructing a list, we ensure that scoped * commands are interpreted properly when they are executed later, * by the "namespace inscope" command. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("::namespace", -1)); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("inscope", -1)); currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { objPtr = Tcl_NewStringObj("::", -1); } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); Tcl_ListObjAppendElement(interp, listPtr, objv[2]); Tcl_SetObjResult(interp, listPtr); 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Namespace *currNsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } /* * The "real" name of the global namespace ("::") is the null string, * but we return "::" for it as a convenience to programmers. Note that * "" and "::" are treated as synonyms by the namespace code so that it * is still easy to do things like: * * namespace [namespace current]::bar { ... } */ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1); } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), 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 * procedure returns an error. If no namespaces are specified, this * command does nothing. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Deletes the specified namespaces. If anything goes wrong, this * procedure returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int NamespaceDeleteCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; char *name; register int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } /* * Destroying one namespace may cause another to be destroyed. Break * this into two passes: first check to make sure that all namespaces on * the command line are valid, and report any errors. */ for (i = 2; i < objc; i++) { name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /*flags*/ 0); if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace \"", Tcl_GetString(objv[i]), "\" in namespace delete command", (char *) NULL); return TCL_ERROR; } } /* * Okay, now delete each namespace. */ for (i = 2; i < objc; i++) { name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) 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 procedure returns an error * message as the result. * *---------------------------------------------------------------------- */ static int NamespaceEvalCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; CallFrame frame; Tcl_Obj *objPtr; char *name; int length, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, 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[2], &namespacePtr); if (result != TCL_OK) { return result; } /* * If the namespace wasn't found, try to create it. */ if (namespacePtr == NULL) { name = Tcl_GetStringFromObj(objv[2], &length); namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (namespacePtr == NULL) { return TCL_ERROR; } } /* * Make the specified namespace the current namespace and evaluate * the command(s). */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } frame.objc = objc; frame.objv = objv; /* ref counts do not need to be incremented here */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } 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-3, objv+3); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { char msg[256 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", namespacePtr->fullName, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } /* * Restore the previous "current" namespace. */ Tcl_PopCallFrame(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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } /* * Check whether the given namespace exists */ if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL)); 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); char *pattern, *string; int resetListFirst = 0; int firstArg, patternCt, i, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } /* * Process the optional "-clear" argument. */ firstArg = 2; if (firstArg < objc) { string = Tcl_GetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; } } /* * If no pattern arguments are given, and "-clear" isn't specified, * return the namespace's current export pattern list. */ patternCt = (objc - firstArg); if (patternCt == 0) { if (firstArg > 2) { return TCL_OK; } else { /* create list with export patterns */ Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, listPtr); if (result != TCL_OK) { return result; } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } } /* * Add each pattern to the namespace's export pattern list. */ for (i = firstArg; i < objc; i++) { pattern = Tcl_GetString(objv[i]); result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, ((i == firstArg)? resetListFirst : 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 procedure returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceForgetCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *pattern; register int i, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); return TCL_ERROR; } for (i = 2; i < objc; i++) { pattern = Tcl_GetString(objv[i]); result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); if (result != TCL_OK) { return result; } } 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. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Adds imported commands to the current namespace. If anything goes * wrong, this procedure returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int NamespaceImportCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int allowOverwrite = 0; char *string, *pattern; register int i, result; int firstArg; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } /* * Skip over the optional "-force" as the first argument. */ firstArg = 2; if (firstArg < objc) { string = Tcl_GetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { allowOverwrite = 1; firstArg++; } } /* * Handle the imports for each of the patterns. */ for (i = firstArg; i < objc; i++) { pattern = Tcl_GetString(objv[i]); result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, allowOverwrite); if (result != TCL_OK) { return result; } } 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 * * is equivalent to * * namespace eval ::foo [concat a [list b c d]] * * 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; Tcl_CallFrame frame; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Resolve the namespace reference. */ result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace \"", Tcl_GetString(objv[2]), "\" in inscope namespace command", (char *) NULL); return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ result = Tcl_PushCallFrame(interp, &frame, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } /* * Execute the command. If there is just one argument, just treat it as * a script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr, *cmdObjPtr; listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (i = 4; i < objc; i++) { result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); /* free unneeded obj */ return result; } } concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { char msg[256 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (in namespace inscope \"%.200s\" script line %d)", namespacePtr->fullName, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } /* * Restore the previous "current" namespace. */ Tcl_PopCallFrame(interp); return result; } /* *---------------------------------------------------------------------- * * 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 procedure returns TCL_OK if * successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error message in * the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceOriginCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Command command, origCommand; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } command = Tcl_GetCommandFromObj(interp, objv[2]); if (command == (Tcl_Command) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid command name \"", Tcl_GetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); if (origCommand == (Tcl_Command) NULL) { /* * The specified command isn't an imported command. Return the * command's name qualified by the full name of the namespace it * was defined in. */ Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp)); } else { Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp)); } 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *nsPtr; int result; if (objc == 2) { nsPtr = Tcl_GetCurrentNamespace(interp); } else if (objc == 3) { result = GetNamespaceFromObj(interp, objv[2], &nsPtr); if (result != TCL_OK) { return result; } if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace \"", Tcl_GetString(objv[2]), "\" in namespace parent command", (char *) NULL); return TCL_ERROR; } } else { Tcl_WrongNumArgs(interp, 2, objv, "?name?"); return TCL_ERROR; } /* * Report the parent of the specified namespace. */ if (nsPtr->parentPtr != NULL) { Tcl_SetStringObj(Tcl_GetObjResult(interp), nsPtr->parentPtr->fullName, -1); } return TCL_OK; } /* *---------------------------------------------------------------------- * * 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register char *name, *p; int length; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find * the start of the last "::" qualifier. */ name = Tcl_GetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { if ((*p == ':') && (p > name) && (*(p-1) == ':')) { p -= 2; /* back up over the :: */ while ((p >= name) && (*p == ':')) { p--; /* back up over the preceeding : */ } break; } } if (p >= name) { length = p-name+1; Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length); } 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register char *name, *p; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find the * last "::" qualifier. */ name = Tcl_GetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p > name) { if ((*p == ':') && (*(p-1) == ':')) { p++; /* just after the last "::" */ break; } } if (p >= name) { Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1); } 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(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register char *arg; Tcl_Command cmd; Tcl_Var variable; int argIndex, lookup; if (objc < 3) { badArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); return TCL_ERROR; } /* * Look for a flag controlling the lookup. */ argIndex = 2; lookup = 0; /* assume command lookup by default */ arg = Tcl_GetString(objv[2]); if (*arg == '-') { if (strncmp(arg, "-command", 8) == 0) { lookup = 0; } else if (strncmp(arg, "-variable", 9) == 0) { lookup = 1; } else { goto badArgs; } argIndex = 3; } if (objc != (argIndex + 1)) { goto badArgs; } switch (lookup) { case 0: /* -command */ cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]); if (cmd == (Tcl_Command) NULL) { return TCL_OK; /* cmd not found, just return (no error) */ } Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp)); break; case 1: /* -variable */ arg = Tcl_GetString(objv[argIndex]); variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, /*flags*/ 0); if (variable != (Tcl_Var) NULL) { Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); } break; } 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(objPtr) register Tcl_Obj *objPtr; /* nsName object with internal * representation to free */ { register ResolvedNsName *resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; Namespace *nsPtr; /* * Decrement the reference count of the namespace. If there are no * more references, free it up. */ if (resNamePtr != NULL) { resNamePtr->refCount--; if (resNamePtr->refCount == 0) { /* * Decrement the reference count for the cached namespace. If * the namespace is dead, and there are no more references to * it, free it. */ nsPtr = resNamePtr->nsPtr; nsPtr->refCount--; if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } ckfree((char *) resNamePtr); } } } /* *---------------------------------------------------------------------- * * 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(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { register ResolvedNsName *resNamePtr = (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; if (resNamePtr != NULL) { resNamePtr->refCount++; } copyPtr->typePtr = &tclNsNameType; } /* *---------------------------------------------------------------------- * * 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(interp, objPtr) Tcl_Interp *interp; /* Points to the namespace in which to * resolve name. Also used for error * reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { register Tcl_ObjType *oldTypePtr = objPtr->typePtr; char *name; CONST char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; /* * Get the string representation. Make it up-to-date if necessary. */ name = objPtr->bytes; if (name == NULL) { name = Tcl_GetString(objPtr); } /* * Look for the namespace "name" in the current namespace. If there is * an error parsing the (possibly qualified) name, return an error. * If the namespace isn't found, we convert the object to an nsName * object with a NULL ResolvedNsName* internal rep. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, 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) { Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); nsPtr->refCount++; resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; resNamePtr->nsId = nsPtr->nsId; resNamePtr->refNsPtr = currNsPtr; resNamePtr->refCount = 1; } else { resNamePtr = NULL; } /* * Free the old internalRep before setting the new one. * We do this as late as possible to allow the conversion code * (in particular, Tcl_GetStringFromObj) to use that old internalRep. */ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); } objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; objPtr->typePtr = &tclNsNameType; return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfNsName -- * * Updates the string representation for a nsName object. * Note: This procedure does not free an existing old string rep * so storage will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a copy of the fully qualified * namespace name. * *---------------------------------------------------------------------- */ static void UpdateStringOfNsName(objPtr) register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ { ResolvedNsName *resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; register Namespace *nsPtr; char *name = ""; int length; if ((resNamePtr != NULL) && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } if (nsPtr != NULL) { name = nsPtr->fullName; } } /* * The following sets the string rep to an empty string on the heap * if the internal rep is NULL. */ length = strlen(name); if (length == 0) { objPtr->bytes = tclEmptyStringRep; } else { objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); objPtr->bytes[length] = '\0'; } objPtr->length = length; }