sl@0: /* sl@0: * tclNamesp.c -- sl@0: * sl@0: * Contains support for namespaces, which provide a separate context of sl@0: * commands and global variables. The global :: namespace is the sl@0: * traditional Tcl "global" scope. Other namespaces are created as sl@0: * children of the global namespace. These other namespaces contain sl@0: * special-purpose commands and variables for packages. sl@0: * sl@0: * Copyright (c) 1993-1997 Lucent Technologies. sl@0: * Copyright (c) 1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: * sl@0: * Originally implemented by sl@0: * Michael J. McLennan sl@0: * Bell Labs Innovations for Lucent Technologies sl@0: * mmclennan@lucent.com sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.14 2007/05/15 18:32:18 dgp Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: sl@0: /* sl@0: * Flag passed to TclGetNamespaceForQualName to indicate that it should sl@0: * search for a namespace rather than a command or variable inside a sl@0: * namespace. Note that this flag's value must not conflict with the values sl@0: * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN. sl@0: */ sl@0: sl@0: #define FIND_ONLY_NS 0x1000 sl@0: sl@0: /* sl@0: * Initial size of stack allocated space for tail list - used when resetting sl@0: * shadowed command references in the functin: TclResetShadowedCmdRefs. sl@0: */ sl@0: sl@0: #define NUM_TRAIL_ELEMS 5 sl@0: sl@0: /* sl@0: * Count of the number of namespaces created. This value is used as a sl@0: * unique id for each namespace. sl@0: */ sl@0: sl@0: static long numNsCreated = 0; sl@0: TCL_DECLARE_MUTEX(nsMutex) sl@0: sl@0: /* sl@0: * This structure contains a cached pointer to a namespace that is the sl@0: * result of resolving the namespace's name in some other namespace. It is sl@0: * the internal representation for a nsName object. It contains the sl@0: * pointer along with some information that is used to check the cached sl@0: * pointer's validity. sl@0: */ sl@0: sl@0: typedef struct ResolvedNsName { sl@0: Namespace *nsPtr; /* A cached namespace pointer. */ sl@0: long nsId; /* nsPtr's unique namespace id. Used to sl@0: * verify that nsPtr is still valid sl@0: * (e.g., it's possible that the namespace sl@0: * was deleted and a new one created at sl@0: * the same address). */ sl@0: Namespace *refNsPtr; /* Points to the namespace containing the sl@0: * reference (not the namespace that sl@0: * contains the referenced namespace). */ sl@0: int refCount; /* Reference count: 1 for each nsName sl@0: * object that has a pointer to this sl@0: * ResolvedNsName structure as its internal sl@0: * rep. This structure can be freed when sl@0: * refCount becomes zero. */ sl@0: } ResolvedNsName; sl@0: sl@0: /* sl@0: * Declarations for procedures local to this file: sl@0: */ sl@0: sl@0: static void DeleteImportedCmd _ANSI_ARGS_(( sl@0: ClientData clientData)); sl@0: static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, sl@0: Tcl_Obj *copyPtr)); sl@0: static void FreeNsNameInternalRep _ANSI_ARGS_(( sl@0: Tcl_Obj *objPtr)); sl@0: static int GetNamespaceFromObj _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, Tcl_Obj *objPtr, sl@0: Tcl_Namespace **nsPtrPtr)); sl@0: static int InvokeImportedCmd _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceChildrenCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceCodeCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceCurrentCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceDeleteCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceEvalCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceExistsCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceExportCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceForgetCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); sl@0: static int NamespaceImportCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceInscopeCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceOriginCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceParentCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceQualifiersCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceTailCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int NamespaceWhichCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static int SetNsNameFromAny _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, Tcl_Obj *objPtr)); sl@0: static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: sl@0: /* sl@0: * This structure defines a Tcl object type that contains a sl@0: * namespace reference. It is used in commands that take the sl@0: * name of a namespace as an argument. The namespace reference sl@0: * is resolved, and the result in cached in the object. sl@0: */ sl@0: sl@0: Tcl_ObjType tclNsNameType = { sl@0: "nsName", /* the type's name */ sl@0: FreeNsNameInternalRep, /* freeIntRepProc */ sl@0: DupNsNameInternalRep, /* dupIntRepProc */ sl@0: UpdateStringOfNsName, /* updateStringProc */ sl@0: SetNsNameFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclInitNamespaceSubsystem -- sl@0: * sl@0: * This procedure is called to initialize all the structures that sl@0: * are used by namespaces on a per-process basis. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclInitNamespaceSubsystem() sl@0: { sl@0: /* sl@0: * Does nothing for now. sl@0: */ sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetCurrentNamespace -- sl@0: * sl@0: * Returns a pointer to an interpreter's currently active namespace. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the interpreter's current namespace. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Namespace * sl@0: Tcl_GetCurrentNamespace(interp) sl@0: register Tcl_Interp *interp; /* Interpreter whose current namespace is sl@0: * being queried. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: register Namespace *nsPtr; sl@0: sl@0: if (iPtr->varFramePtr != NULL) { sl@0: nsPtr = iPtr->varFramePtr->nsPtr; sl@0: } else { sl@0: nsPtr = iPtr->globalNsPtr; sl@0: } sl@0: return (Tcl_Namespace *) nsPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetGlobalNamespace -- sl@0: * sl@0: * Returns a pointer to an interpreter's global :: namespace. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the specified interpreter's global namespace. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Namespace * sl@0: Tcl_GetGlobalNamespace(interp) sl@0: register Tcl_Interp *interp; /* Interpreter whose global namespace sl@0: * should be returned. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: sl@0: return (Tcl_Namespace *) iPtr->globalNsPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PushCallFrame -- sl@0: * sl@0: * Pushes a new call frame onto the interpreter's Tcl call stack. sl@0: * Called when executing a Tcl procedure or a "namespace eval" or sl@0: * "namespace inscope" command. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, or TCL_ERROR (along with an error sl@0: * message in the interpreter's result object) if something goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Modifies the interpreter's Tcl call stack. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) sl@0: Tcl_Interp *interp; /* Interpreter in which the new call frame sl@0: * is to be pushed. */ sl@0: Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to sl@0: * push. Storage for this has already been sl@0: * allocated by the caller; typically this sl@0: * is the address of a CallFrame structure sl@0: * allocated on the caller's C stack. The sl@0: * call frame will be initialized by this sl@0: * procedure. The caller can pop the frame sl@0: * later with Tcl_PopCallFrame, and it is sl@0: * responsible for freeing the frame's sl@0: * storage. */ sl@0: Tcl_Namespace *namespacePtr; /* Points to the namespace in which the sl@0: * frame will execute. If NULL, the sl@0: * interpreter's current namespace will sl@0: * be used. */ sl@0: int isProcCallFrame; /* If nonzero, the frame represents a sl@0: * called Tcl procedure and may have local sl@0: * vars. Vars will ordinarily be looked up sl@0: * in the frame. If new variables are sl@0: * created, they will be created in the sl@0: * frame. If 0, the frame is for a sl@0: * "namespace eval" or "namespace inscope" sl@0: * command and var references are treated sl@0: * as references to namespace variables. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register CallFrame *framePtr = (CallFrame *) callFramePtr; sl@0: register Namespace *nsPtr; sl@0: sl@0: if (namespacePtr == NULL) { sl@0: nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: } else { sl@0: nsPtr = (Namespace *) namespacePtr; sl@0: if (nsPtr->flags & NS_DEAD) { sl@0: panic("Trying to push call frame for dead namespace"); sl@0: /*NOTREACHED*/ sl@0: } sl@0: } sl@0: sl@0: nsPtr->activationCount++; sl@0: framePtr->nsPtr = nsPtr; sl@0: framePtr->isProcCallFrame = isProcCallFrame; sl@0: framePtr->objc = 0; sl@0: framePtr->objv = NULL; sl@0: framePtr->callerPtr = iPtr->framePtr; sl@0: framePtr->callerVarPtr = iPtr->varFramePtr; sl@0: if (iPtr->varFramePtr != NULL) { sl@0: framePtr->level = (iPtr->varFramePtr->level + 1); sl@0: } else { sl@0: framePtr->level = 1; sl@0: } sl@0: framePtr->procPtr = NULL; /* no called procedure */ sl@0: framePtr->varTablePtr = NULL; /* and no local variables */ sl@0: framePtr->numCompiledLocals = 0; sl@0: framePtr->compiledLocals = NULL; sl@0: sl@0: /* sl@0: * Push the new call frame onto the interpreter's stack of procedure sl@0: * call frames making it the current frame. sl@0: */ sl@0: sl@0: iPtr->framePtr = framePtr; sl@0: iPtr->varFramePtr = framePtr; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PopCallFrame -- sl@0: * sl@0: * Removes a call frame from the Tcl call stack for the interpreter. sl@0: * Called to remove a frame previously pushed by Tcl_PushCallFrame. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Modifies the call stack of the interpreter. Resets various fields of sl@0: * the popped call frame. If a namespace has been deleted and sl@0: * has no more activations on the call stack, the namespace is sl@0: * destroyed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: Tcl_PopCallFrame(interp) sl@0: Tcl_Interp* interp; /* Interpreter with call frame to pop. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: register CallFrame *framePtr = iPtr->framePtr; sl@0: Namespace *nsPtr; sl@0: sl@0: /* sl@0: * It's important to remove the call frame from the interpreter's stack sl@0: * of call frames before deleting local variables, so that traces sl@0: * invoked by the variable deletion don't see the partially-deleted sl@0: * frame. sl@0: */ sl@0: sl@0: iPtr->framePtr = framePtr->callerPtr; sl@0: iPtr->varFramePtr = framePtr->callerVarPtr; sl@0: sl@0: if (framePtr->varTablePtr != NULL) { sl@0: TclDeleteVars(iPtr, framePtr->varTablePtr); sl@0: ckfree((char *) framePtr->varTablePtr); sl@0: framePtr->varTablePtr = NULL; sl@0: } sl@0: if (framePtr->numCompiledLocals > 0) { sl@0: TclDeleteCompiledLocalVars(iPtr, framePtr); sl@0: } sl@0: sl@0: /* sl@0: * Decrement the namespace's count of active call frames. If the sl@0: * namespace is "dying" and there are no more active call frames, sl@0: * call Tcl_DeleteNamespace to destroy it. sl@0: */ sl@0: sl@0: nsPtr = framePtr->nsPtr; sl@0: nsPtr->activationCount--; sl@0: if ((nsPtr->flags & NS_DYING) sl@0: && (nsPtr->activationCount == 0)) { sl@0: Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); sl@0: } sl@0: framePtr->nsPtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateNamespace -- sl@0: * sl@0: * Creates a new namespace with the given name. If there is no sl@0: * active namespace (i.e., the interpreter is being initialized), sl@0: * the global :: namespace is created and returned. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the new namespace if successful. If the sl@0: * namespace already exists or if another error occurs, this routine sl@0: * returns NULL, along with an error message in the interpreter's sl@0: * result object. sl@0: * sl@0: * Side effects: sl@0: * If the name contains "::" qualifiers and a parent namespace does sl@0: * not already exist, it is automatically created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Namespace * sl@0: Tcl_CreateNamespace(interp, name, clientData, deleteProc) sl@0: Tcl_Interp *interp; /* Interpreter in which a new namespace sl@0: * is being created. Also used for sl@0: * error reporting. */ sl@0: CONST char *name; /* Name for the new namespace. May be a sl@0: * qualified name with names of ancestor sl@0: * namespaces separated by "::"s. */ sl@0: ClientData clientData; /* One-word value to store with sl@0: * namespace. */ sl@0: Tcl_NamespaceDeleteProc *deleteProc; sl@0: /* Procedure called to delete client sl@0: * data when the namespace is deleted. sl@0: * NULL if no procedure should be sl@0: * called. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register Namespace *nsPtr, *ancestorPtr; sl@0: Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; sl@0: Namespace *globalNsPtr = iPtr->globalNsPtr; sl@0: CONST char *simpleName; sl@0: Tcl_HashEntry *entryPtr; sl@0: Tcl_DString buffer1, buffer2; sl@0: int newEntry; sl@0: sl@0: /* sl@0: * If there is no active namespace, the interpreter is being sl@0: * initialized. sl@0: */ sl@0: sl@0: if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { sl@0: /* sl@0: * Treat this namespace as the global namespace, and avoid sl@0: * looking for a parent. sl@0: */ sl@0: sl@0: parentPtr = NULL; sl@0: simpleName = ""; sl@0: } else if (*name == '\0') { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); sl@0: return NULL; sl@0: } else { sl@0: /* sl@0: * Find the parent for the new namespace. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, sl@0: /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), sl@0: &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); sl@0: sl@0: /* sl@0: * If the unqualified name at the end is empty, there were trailing sl@0: * "::"s after the namespace's name which we ignore. The new sl@0: * namespace was already (recursively) created and is pointed to sl@0: * by parentPtr. sl@0: */ sl@0: sl@0: if (*simpleName == '\0') { sl@0: return (Tcl_Namespace *) parentPtr; sl@0: } sl@0: sl@0: /* sl@0: * Check for a bad namespace name and make sure that the name sl@0: * does not already exist in the parent namespace. sl@0: */ sl@0: sl@0: if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can't create namespace \"", name, sl@0: "\": already exists", (char *) NULL); sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Create the new namespace and root it in its parent. Increment the sl@0: * count of namespaces created. sl@0: */ sl@0: sl@0: sl@0: nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); sl@0: nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); sl@0: strcpy(nsPtr->name, simpleName); sl@0: nsPtr->fullName = NULL; /* set below */ sl@0: nsPtr->clientData = clientData; sl@0: nsPtr->deleteProc = deleteProc; sl@0: nsPtr->parentPtr = parentPtr; sl@0: Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); sl@0: Tcl_MutexLock(&nsMutex); sl@0: numNsCreated++; sl@0: nsPtr->nsId = numNsCreated; sl@0: Tcl_MutexUnlock(&nsMutex); sl@0: nsPtr->interp = interp; sl@0: nsPtr->flags = 0; sl@0: nsPtr->activationCount = 0; sl@0: nsPtr->refCount = 0; sl@0: Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); sl@0: Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); sl@0: nsPtr->exportArrayPtr = NULL; sl@0: nsPtr->numExportPatterns = 0; sl@0: nsPtr->maxExportPatterns = 0; sl@0: nsPtr->cmdRefEpoch = 0; sl@0: nsPtr->resolverEpoch = 0; sl@0: nsPtr->cmdResProc = NULL; sl@0: nsPtr->varResProc = NULL; sl@0: nsPtr->compiledVarResProc = NULL; sl@0: sl@0: if (parentPtr != NULL) { sl@0: entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, sl@0: &newEntry); sl@0: Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); sl@0: } sl@0: sl@0: /* sl@0: * Build the fully qualified name for this namespace. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&buffer1); sl@0: Tcl_DStringInit(&buffer2); sl@0: for (ancestorPtr = nsPtr; ancestorPtr != NULL; sl@0: ancestorPtr = ancestorPtr->parentPtr) { sl@0: if (ancestorPtr != globalNsPtr) { sl@0: Tcl_DStringAppend(&buffer1, "::", 2); sl@0: Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); sl@0: } sl@0: Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); sl@0: sl@0: Tcl_DStringSetLength(&buffer2, 0); sl@0: Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); sl@0: Tcl_DStringSetLength(&buffer1, 0); sl@0: } sl@0: sl@0: name = Tcl_DStringValue(&buffer2); sl@0: nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); sl@0: strcpy(nsPtr->fullName, name); sl@0: sl@0: Tcl_DStringFree(&buffer1); sl@0: Tcl_DStringFree(&buffer2); sl@0: sl@0: /* sl@0: * Return a pointer to the new namespace. sl@0: */ sl@0: sl@0: return (Tcl_Namespace *) nsPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DeleteNamespace -- sl@0: * sl@0: * Deletes a namespace and all of the commands, variables, and other sl@0: * namespaces within it. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * When a namespace is deleted, it is automatically removed as a sl@0: * child of its parent namespace. Also, all its commands, variables sl@0: * and child namespaces are deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: Tcl_DeleteNamespace(namespacePtr) sl@0: Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ sl@0: { sl@0: register Namespace *nsPtr = (Namespace *) namespacePtr; sl@0: Interp *iPtr = (Interp *) nsPtr->interp; sl@0: Namespace *globalNsPtr = sl@0: (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); sl@0: Tcl_HashEntry *entryPtr; sl@0: sl@0: /* sl@0: * If the namespace is on the call frame stack, it is marked as "dying" sl@0: * (NS_DYING is OR'd into its flags): the namespace can't be looked up sl@0: * by name but its commands and variables are still usable by those sl@0: * active call frames. When all active call frames referring to the sl@0: * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will sl@0: * call this procedure again to delete everything in the namespace. sl@0: * If no nsName objects refer to the namespace (i.e., if its refCount sl@0: * is zero), its commands and variables are deleted and the storage for sl@0: * its namespace structure is freed. Otherwise, if its refCount is sl@0: * nonzero, the namespace's commands and variables are deleted but the sl@0: * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's sl@0: * flags to allow the namespace resolution code to recognize that the sl@0: * namespace is "deleted". The structure's storage is freed by sl@0: * FreeNsNameInternalRep when its refCount reaches 0. sl@0: */ sl@0: sl@0: if (nsPtr->activationCount > 0) { sl@0: nsPtr->flags |= NS_DYING; sl@0: if (nsPtr->parentPtr != NULL) { sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, sl@0: nsPtr->name); sl@0: if (entryPtr != NULL) { sl@0: Tcl_DeleteHashEntry(entryPtr); sl@0: } sl@0: } sl@0: nsPtr->parentPtr = NULL; sl@0: } else if (!(nsPtr->flags & NS_KILLED)) { sl@0: /* sl@0: * Delete the namespace and everything in it. If this is the global sl@0: * namespace, then clear it but don't free its storage unless the sl@0: * interpreter is being torn down. Set the NS_KILLED flag to avoid sl@0: * recursive calls here - if the namespace is really in the process of sl@0: * being deleted, ignore any second call. sl@0: */ sl@0: sl@0: nsPtr->flags |= (NS_DYING|NS_KILLED); sl@0: sl@0: TclTeardownNamespace(nsPtr); sl@0: sl@0: if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { sl@0: /* sl@0: * If this is the global namespace, then it may have residual sl@0: * "errorInfo" and "errorCode" variables for errors that sl@0: * occurred while it was being torn down. Try to clear the sl@0: * variable list one last time. sl@0: */ sl@0: sl@0: TclDeleteNamespaceVars(nsPtr); sl@0: sl@0: Tcl_DeleteHashTable(&nsPtr->childTable); sl@0: Tcl_DeleteHashTable(&nsPtr->cmdTable); sl@0: sl@0: /* sl@0: * If the reference count is 0, then discard the namespace. sl@0: * Otherwise, mark it as "dead" so that it can't be used. sl@0: */ sl@0: sl@0: if (nsPtr->refCount == 0) { sl@0: NamespaceFree(nsPtr); sl@0: } else { sl@0: nsPtr->flags |= NS_DEAD; sl@0: } sl@0: } else { sl@0: /* sl@0: * We didn't really kill it, so remove the KILLED marks, so sl@0: * it can get killed later, avoiding mem leaks sl@0: */ sl@0: nsPtr->flags &= ~(NS_DYING|NS_KILLED); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclTeardownNamespace -- sl@0: * sl@0: * Used internally to dismantle and unlink a namespace when it is sl@0: * deleted. Divorces the namespace from its parent, and deletes all sl@0: * commands, variables, and child namespaces. sl@0: * sl@0: * This is kept separate from Tcl_DeleteNamespace so that the global sl@0: * namespace can be handled specially. Global variables like sl@0: * "errorInfo" and "errorCode" need to remain intact while other sl@0: * namespaces and commands are torn down, in case any errors occur. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Removes this namespace from its parent's child namespace hashtable. sl@0: * Deletes all commands, variables and namespaces in this namespace. sl@0: * If this is the global namespace, the "errorInfo" and "errorCode" sl@0: * variables are left alone and deleted later. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclTeardownNamespace(nsPtr) sl@0: register Namespace *nsPtr; /* Points to the namespace to be dismantled sl@0: * and unlinked from its parent. */ sl@0: { sl@0: Interp *iPtr = (Interp *) nsPtr->interp; sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: Tcl_Namespace *childNsPtr; sl@0: Tcl_Command cmd; sl@0: Namespace *globalNsPtr = sl@0: (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); sl@0: int i; sl@0: sl@0: /* sl@0: * Start by destroying the namespace's variable table, sl@0: * since variables might trigger traces. sl@0: */ sl@0: sl@0: if (nsPtr == globalNsPtr) { sl@0: /* sl@0: * This is the global namespace. Tearing it down will destroy the sl@0: * ::errorInfo and ::errorCode variables. We save and restore them sl@0: * in case there are any errors in progress, so the error details sl@0: * they contain will not be lost. See test namespace-8.5 sl@0: */ sl@0: sl@0: Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo", sl@0: NULL, TCL_GLOBAL_ONLY); sl@0: Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode", sl@0: NULL, TCL_GLOBAL_ONLY); sl@0: sl@0: if (errorInfo) { sl@0: Tcl_IncrRefCount(errorInfo); sl@0: } sl@0: if (errorCode) { sl@0: Tcl_IncrRefCount(errorCode); sl@0: } sl@0: sl@0: TclDeleteNamespaceVars(nsPtr); sl@0: Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); sl@0: sl@0: if (errorInfo) { sl@0: Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL, sl@0: errorInfo, TCL_GLOBAL_ONLY); sl@0: Tcl_DecrRefCount(errorInfo); sl@0: } sl@0: if (errorCode) { sl@0: Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL, sl@0: errorCode, TCL_GLOBAL_ONLY); sl@0: Tcl_DecrRefCount(errorCode); sl@0: } sl@0: } else { sl@0: /* sl@0: * Variable table should be cleared but not freed! TclDeleteVars sl@0: * frees it, so we reinitialize it afterwards. sl@0: */ sl@0: sl@0: TclDeleteNamespaceVars(nsPtr); sl@0: Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); sl@0: } sl@0: sl@0: /* sl@0: * Delete all commands in this namespace. Be careful when traversing the sl@0: * hash table: when each command is deleted, it removes itself from the sl@0: * command table. sl@0: */ sl@0: sl@0: for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); sl@0: entryPtr != NULL; sl@0: entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { sl@0: cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); sl@0: Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); sl@0: } sl@0: Tcl_DeleteHashTable(&nsPtr->cmdTable); sl@0: Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); sl@0: sl@0: /* sl@0: * Remove the namespace from its parent's child hashtable. sl@0: */ sl@0: sl@0: if (nsPtr->parentPtr != NULL) { sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, sl@0: nsPtr->name); sl@0: if (entryPtr != NULL) { sl@0: Tcl_DeleteHashEntry(entryPtr); sl@0: } sl@0: } sl@0: nsPtr->parentPtr = NULL; sl@0: sl@0: /* sl@0: * Delete all the child namespaces. sl@0: * sl@0: * BE CAREFUL: When each child is deleted, it will divorce sl@0: * itself from its parent. You can't traverse a hash table sl@0: * properly if its elements are being deleted. We use only sl@0: * the Tcl_FirstHashEntry function to be safe. sl@0: */ sl@0: sl@0: for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); sl@0: entryPtr != NULL; sl@0: entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { sl@0: childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); sl@0: Tcl_DeleteNamespace(childNsPtr); sl@0: } sl@0: sl@0: /* sl@0: * Free the namespace's export pattern array. sl@0: */ sl@0: sl@0: if (nsPtr->exportArrayPtr != NULL) { sl@0: for (i = 0; i < nsPtr->numExportPatterns; i++) { sl@0: ckfree(nsPtr->exportArrayPtr[i]); sl@0: } sl@0: ckfree((char *) nsPtr->exportArrayPtr); sl@0: nsPtr->exportArrayPtr = NULL; sl@0: nsPtr->numExportPatterns = 0; sl@0: nsPtr->maxExportPatterns = 0; sl@0: } sl@0: sl@0: /* sl@0: * Free any client data associated with the namespace. sl@0: */ sl@0: sl@0: if (nsPtr->deleteProc != NULL) { sl@0: (*nsPtr->deleteProc)(nsPtr->clientData); sl@0: } sl@0: nsPtr->deleteProc = NULL; sl@0: nsPtr->clientData = NULL; sl@0: sl@0: /* sl@0: * Reset the namespace's id field to ensure that this namespace won't sl@0: * be interpreted as valid by, e.g., the cache validation code for sl@0: * cached command references in Tcl_GetCommandFromObj. sl@0: */ sl@0: sl@0: nsPtr->nsId = 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceFree -- sl@0: * sl@0: * Called after a namespace has been deleted, when its sl@0: * reference count reaches 0. Frees the data structure sl@0: * representing the namespace. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: NamespaceFree(nsPtr) sl@0: register Namespace *nsPtr; /* Points to the namespace to free. */ sl@0: { sl@0: /* sl@0: * Most of the namespace's contents are freed when the namespace is sl@0: * deleted by Tcl_DeleteNamespace. All that remains is to free its names sl@0: * (for error messages), and the structure itself. sl@0: */ sl@0: sl@0: ckfree(nsPtr->name); sl@0: ckfree(nsPtr->fullName); sl@0: sl@0: ckfree((char *) nsPtr); sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_Export -- sl@0: * sl@0: * Makes all the commands matching a pattern available to later be sl@0: * imported from the namespace specified by namespacePtr (or the sl@0: * current namespace if namespacePtr is NULL). The specified pattern is sl@0: * appended onto the namespace's export pattern list, which is sl@0: * optionally cleared beforehand. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, or TCL_ERROR (along with an error sl@0: * message in the interpreter's result) if something goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Appends the export pattern onto the namespace's export list. sl@0: * Optionally reset the namespace's export pattern list. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_Export(interp, namespacePtr, pattern, resetListFirst) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: Tcl_Namespace *namespacePtr; /* Points to the namespace from which sl@0: * commands are to be exported. NULL for sl@0: * the current namespace. */ sl@0: CONST char *pattern; /* String pattern indicating which commands sl@0: * to export. This pattern may not include sl@0: * any namespace qualifiers; only commands sl@0: * in the specified namespace may be sl@0: * exported. */ sl@0: int resetListFirst; /* If nonzero, resets the namespace's sl@0: * export list before appending. */ sl@0: { sl@0: #define INIT_EXPORT_PATTERNS 5 sl@0: Namespace *nsPtr, *exportNsPtr, *dummyPtr; sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: CONST char *simplePattern; sl@0: char *patternCpy; sl@0: int neededElems, len, i; sl@0: sl@0: /* sl@0: * If the specified namespace is NULL, use the current namespace. sl@0: */ sl@0: sl@0: if (namespacePtr == NULL) { sl@0: nsPtr = (Namespace *) currNsPtr; sl@0: } else { sl@0: nsPtr = (Namespace *) namespacePtr; sl@0: } sl@0: sl@0: /* sl@0: * If resetListFirst is true (nonzero), clear the namespace's export sl@0: * pattern list. sl@0: */ sl@0: sl@0: if (resetListFirst) { sl@0: if (nsPtr->exportArrayPtr != NULL) { sl@0: for (i = 0; i < nsPtr->numExportPatterns; i++) { sl@0: ckfree(nsPtr->exportArrayPtr[i]); sl@0: } sl@0: ckfree((char *) nsPtr->exportArrayPtr); sl@0: nsPtr->exportArrayPtr = NULL; sl@0: nsPtr->numExportPatterns = 0; sl@0: nsPtr->maxExportPatterns = 0; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Check that the pattern doesn't have namespace qualifiers. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, pattern, nsPtr, sl@0: /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), sl@0: &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); sl@0: sl@0: if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "invalid export pattern \"", pattern, sl@0: "\": pattern can't specify a namespace", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure that we don't already have the pattern in the array sl@0: */ sl@0: if (nsPtr->exportArrayPtr != NULL) { sl@0: for (i = 0; i < nsPtr->numExportPatterns; i++) { sl@0: if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { sl@0: /* sl@0: * The pattern already exists in the list sl@0: */ sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Make sure there is room in the namespace's pattern array for the sl@0: * new pattern. sl@0: */ sl@0: sl@0: neededElems = nsPtr->numExportPatterns + 1; sl@0: if (nsPtr->exportArrayPtr == NULL) { sl@0: nsPtr->exportArrayPtr = (char **) sl@0: ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); sl@0: nsPtr->numExportPatterns = 0; sl@0: nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; sl@0: } else if (neededElems > nsPtr->maxExportPatterns) { sl@0: int numNewElems = 2 * nsPtr->maxExportPatterns; sl@0: size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); sl@0: size_t newBytes = numNewElems * sizeof(char *); sl@0: char **newPtr = (char **) ckalloc((unsigned) newBytes); sl@0: sl@0: memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, sl@0: currBytes); sl@0: ckfree((char *) nsPtr->exportArrayPtr); sl@0: nsPtr->exportArrayPtr = (char **) newPtr; sl@0: nsPtr->maxExportPatterns = numNewElems; sl@0: } sl@0: sl@0: /* sl@0: * Add the pattern to the namespace's array of export patterns. sl@0: */ sl@0: sl@0: len = strlen(pattern); sl@0: patternCpy = (char *) ckalloc((unsigned) (len + 1)); sl@0: strcpy(patternCpy, pattern); sl@0: sl@0: nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; sl@0: nsPtr->numExportPatterns++; sl@0: return TCL_OK; sl@0: #undef INIT_EXPORT_PATTERNS sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AppendExportList -- sl@0: * sl@0: * Appends onto the argument object the list of export patterns for the sl@0: * specified namespace. sl@0: * sl@0: * Results: sl@0: * The return value is normally TCL_OK; in this case the object sl@0: * referenced by objPtr has each export pattern appended to it. If an sl@0: * error occurs, TCL_ERROR is returned and the interpreter's result sl@0: * holds an error message. sl@0: * sl@0: * Side effects: sl@0: * If necessary, the object referenced by objPtr is converted into sl@0: * a list object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_AppendExportList(interp, namespacePtr, objPtr) sl@0: Tcl_Interp *interp; /* Interpreter used for error reporting. */ sl@0: Tcl_Namespace *namespacePtr; /* Points to the namespace whose export sl@0: * pattern list is appended onto objPtr. sl@0: * NULL for the current namespace. */ sl@0: Tcl_Obj *objPtr; /* Points to the Tcl object onto which the sl@0: * export pattern list is appended. */ sl@0: { sl@0: Namespace *nsPtr; sl@0: int i, result; sl@0: sl@0: /* sl@0: * If the specified namespace is NULL, use the current namespace. sl@0: */ sl@0: sl@0: if (namespacePtr == NULL) { sl@0: nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: } else { sl@0: nsPtr = (Namespace *) namespacePtr; sl@0: } sl@0: sl@0: /* sl@0: * Append the export pattern list onto objPtr. sl@0: */ sl@0: sl@0: for (i = 0; i < nsPtr->numExportPatterns; i++) { sl@0: result = Tcl_ListObjAppendElement(interp, objPtr, sl@0: Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_Import -- sl@0: * sl@0: * Imports all of the commands matching a pattern into the namespace sl@0: * specified by namespacePtr (or the current namespace if contextNsPtr sl@0: * is NULL). This is done by creating a new command (the "imported sl@0: * command") that points to the real command in its original namespace. sl@0: * sl@0: * If matching commands are on the autoload path but haven't been sl@0: * loaded yet, this command forces them to be loaded, then creates sl@0: * the links to them. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, or TCL_ERROR (along with an error sl@0: * message in the interpreter's result) if something goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Creates new commands in the importing namespace. These indirect sl@0: * calls back to the real command and are deleted if the real commands sl@0: * are deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: Tcl_Namespace *namespacePtr; /* Points to the namespace into which the sl@0: * commands are to be imported. NULL for sl@0: * the current namespace. */ sl@0: CONST char *pattern; /* String pattern indicating which commands sl@0: * to import. This pattern should be sl@0: * qualified by the name of the namespace sl@0: * from which to import the command(s). */ sl@0: int allowOverwrite; /* If nonzero, allow existing commands to sl@0: * be overwritten by imported commands. sl@0: * If 0, return an error if an imported sl@0: * cmd conflicts with an existing one. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Namespace *nsPtr, *importNsPtr, *dummyPtr; sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: CONST char *simplePattern; sl@0: char *cmdName; sl@0: register Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch search; sl@0: Command *cmdPtr; sl@0: ImportRef *refPtr; sl@0: Tcl_Command autoCmd, importedCmd; sl@0: ImportedCmdData *dataPtr; sl@0: int wasExported, i, result; sl@0: sl@0: /* sl@0: * If the specified namespace is NULL, use the current namespace. sl@0: */ sl@0: sl@0: if (namespacePtr == NULL) { sl@0: nsPtr = (Namespace *) currNsPtr; sl@0: } else { sl@0: nsPtr = (Namespace *) namespacePtr; sl@0: } sl@0: sl@0: /* sl@0: * First, invoke the "auto_import" command with the pattern sl@0: * being imported. This command is part of the Tcl library. sl@0: * It looks for imported commands in autoloaded libraries and sl@0: * loads them in. That way, they will be found when we try sl@0: * to create links below. sl@0: */ sl@0: sl@0: autoCmd = Tcl_FindCommand(interp, "auto_import", sl@0: (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); sl@0: sl@0: if (autoCmd != NULL) { sl@0: Tcl_Obj *objv[2]; sl@0: sl@0: objv[0] = Tcl_NewStringObj("auto_import", -1); sl@0: Tcl_IncrRefCount(objv[0]); sl@0: objv[1] = Tcl_NewStringObj(pattern, -1); sl@0: Tcl_IncrRefCount(objv[1]); sl@0: sl@0: cmdPtr = (Command *) autoCmd; sl@0: result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, sl@0: 2, objv); sl@0: sl@0: Tcl_DecrRefCount(objv[0]); sl@0: Tcl_DecrRefCount(objv[1]); sl@0: sl@0: if (result != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: sl@0: /* sl@0: * From the pattern, find the namespace from which we are importing sl@0: * and get the simple pattern (no namespace qualifiers or ::'s) at sl@0: * the end. sl@0: */ sl@0: sl@0: if (strlen(pattern) == 0) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), sl@0: "empty import pattern", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: TclGetNamespaceForQualName(interp, pattern, nsPtr, sl@0: /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), sl@0: &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); sl@0: sl@0: if (importNsPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace in import pattern \"", sl@0: pattern, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (importNsPtr == nsPtr) { sl@0: if (pattern == simplePattern) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "no namespace specified in import pattern \"", pattern, sl@0: "\"", (char *) NULL); sl@0: } else { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "import pattern \"", pattern, sl@0: "\" tries to import from namespace \"", sl@0: importNsPtr->name, "\" into itself", (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Scan through the command table in the source namespace and look for sl@0: * exported commands that match the string pattern. Create an "imported sl@0: * command" in the current namespace for each imported command; these sl@0: * commands redirect their invocations to the "real" command. sl@0: */ sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); sl@0: (hPtr != NULL); sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); sl@0: if (Tcl_StringMatch(cmdName, simplePattern)) { sl@0: /* sl@0: * The command cmdName in the source namespace matches the sl@0: * pattern. Check whether it was exported. If it wasn't, sl@0: * we ignore it. sl@0: */ sl@0: Tcl_HashEntry *found; sl@0: sl@0: wasExported = 0; sl@0: for (i = 0; i < importNsPtr->numExportPatterns; i++) { sl@0: if (Tcl_StringMatch(cmdName, sl@0: importNsPtr->exportArrayPtr[i])) { sl@0: wasExported = 1; sl@0: break; sl@0: } sl@0: } sl@0: if (!wasExported) { sl@0: continue; sl@0: } sl@0: sl@0: /* sl@0: * Unless there is a name clash, create an imported command sl@0: * in the current namespace that refers to cmdPtr. sl@0: */ sl@0: sl@0: found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); sl@0: if ((found == NULL) || allowOverwrite) { sl@0: /* sl@0: * Create the imported command and its client data. sl@0: * To create the new command in the current namespace, sl@0: * generate a fully qualified name for it. sl@0: */ sl@0: sl@0: Tcl_DString ds; sl@0: sl@0: Tcl_DStringInit(&ds); sl@0: Tcl_DStringAppend(&ds, nsPtr->fullName, -1); sl@0: if (nsPtr != iPtr->globalNsPtr) { sl@0: Tcl_DStringAppend(&ds, "::", 2); sl@0: } sl@0: Tcl_DStringAppend(&ds, cmdName, -1); sl@0: sl@0: /* sl@0: * Check whether creating the new imported command in the sl@0: * current namespace would create a cycle of imported sl@0: * command references. sl@0: */ sl@0: sl@0: cmdPtr = (Command *) Tcl_GetHashValue(hPtr); sl@0: if ((found != NULL) sl@0: && cmdPtr->deleteProc == DeleteImportedCmd) { sl@0: sl@0: Command *overwrite = (Command *) Tcl_GetHashValue(found); sl@0: Command *link = cmdPtr; sl@0: while (link->deleteProc == DeleteImportedCmd) { sl@0: ImportedCmdData *dataPtr; sl@0: sl@0: dataPtr = (ImportedCmdData *) link->objClientData; sl@0: link = dataPtr->realCmdPtr; sl@0: if (overwrite == link) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "import pattern \"", pattern, sl@0: "\" would create a loop containing ", sl@0: "command \"", Tcl_DStringValue(&ds), sl@0: "\"", (char *) NULL); sl@0: Tcl_DStringFree(&ds); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: sl@0: dataPtr = (ImportedCmdData *) sl@0: ckalloc(sizeof(ImportedCmdData)); sl@0: importedCmd = Tcl_CreateObjCommand(interp, sl@0: Tcl_DStringValue(&ds), InvokeImportedCmd, sl@0: (ClientData) dataPtr, DeleteImportedCmd); sl@0: dataPtr->realCmdPtr = cmdPtr; sl@0: dataPtr->selfPtr = (Command *) importedCmd; sl@0: dataPtr->selfPtr->compileProc = cmdPtr->compileProc; sl@0: Tcl_DStringFree(&ds); sl@0: sl@0: /* sl@0: * Create an ImportRef structure describing this new import sl@0: * command and add it to the import ref list in the "real" sl@0: * command. sl@0: */ sl@0: sl@0: refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); sl@0: refPtr->importedCmdPtr = (Command *) importedCmd; sl@0: refPtr->nextPtr = cmdPtr->importRefPtr; sl@0: cmdPtr->importRefPtr = refPtr; sl@0: } else { sl@0: Command *overwrite = (Command *) Tcl_GetHashValue(found); sl@0: if (overwrite->deleteProc == DeleteImportedCmd) { sl@0: ImportedCmdData *dataPtr = sl@0: (ImportedCmdData *) overwrite->objClientData; sl@0: if (dataPtr->realCmdPtr sl@0: == (Command *) Tcl_GetHashValue(hPtr)) { sl@0: /* Repeated import of same command -- acceptable */ sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can't import command \"", cmdName, sl@0: "\": already exists", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ForgetImport -- sl@0: * sl@0: * Deletes commands previously imported into the namespace indicated. The sl@0: * by namespacePtr, or the current namespace of interp, when sl@0: * namespacePtr is NULL. The pattern controls which imported commands sl@0: * are deleted. A simple pattern, one without namespace separators, sl@0: * matches the current command names of imported commands in the sl@0: * namespace. Matching imported commands are deleted. A qualified sl@0: * pattern is interpreted as deletion selection on the basis of where sl@0: * the command is imported from. The original command and "first link" sl@0: * command for each imported command are determined, and they are matched sl@0: * against the pattern. A match leads to deletion of the imported sl@0: * command. sl@0: * sl@0: * Results: sl@0: * Returns TCL_ERROR and records an error message in the interp sl@0: * result if a namespace qualified pattern refers to a namespace sl@0: * that does not exist. Otherwise, returns TCL_OK. sl@0: * sl@0: * Side effects: sl@0: * May delete commands. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_ForgetImport(interp, namespacePtr, pattern) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: Tcl_Namespace *namespacePtr; /* Points to the namespace from which sl@0: * previously imported commands should be sl@0: * removed. NULL for current namespace. */ sl@0: CONST char *pattern; /* String pattern indicating which imported sl@0: * commands to remove. */ sl@0: { sl@0: Namespace *nsPtr, *sourceNsPtr, *dummyPtr; sl@0: CONST char *simplePattern; sl@0: char *cmdName; sl@0: register Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch search; sl@0: sl@0: /* sl@0: * If the specified namespace is NULL, use the current namespace. sl@0: */ sl@0: sl@0: if (namespacePtr == NULL) { sl@0: nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: } else { sl@0: nsPtr = (Namespace *) namespacePtr; sl@0: } sl@0: sl@0: /* sl@0: * Parse the pattern into its namespace-qualification (if any) sl@0: * and the simple pattern. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, pattern, nsPtr, sl@0: /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), sl@0: &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); sl@0: sl@0: if (sourceNsPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace in namespace forget pattern \"", sl@0: pattern, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (strcmp(pattern, simplePattern) == 0) { sl@0: /* sl@0: * The pattern is simple. sl@0: * Delete any imported commands that match it. sl@0: */ sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); sl@0: (hPtr != NULL); sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); sl@0: if (cmdPtr->deleteProc != DeleteImportedCmd) { sl@0: continue; sl@0: } sl@0: cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); sl@0: if (Tcl_StringMatch(cmdName, simplePattern)) { sl@0: Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* The pattern was namespace-qualified */ sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: Tcl_CmdInfo info; sl@0: Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); sl@0: Tcl_Command origin = TclGetOriginalCommand(token); sl@0: sl@0: if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { sl@0: continue; /* Not an imported command */ sl@0: } sl@0: if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { sl@0: /* sl@0: * Original not in namespace we're matching. sl@0: * Check the first link in the import chain. sl@0: */ sl@0: Command *cmdPtr = (Command *) token; sl@0: ImportedCmdData *dataPtr = sl@0: (ImportedCmdData *) cmdPtr->objClientData; sl@0: Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; sl@0: if (firstToken == origin) { sl@0: continue; sl@0: } sl@0: Tcl_GetCommandInfoFromToken(firstToken, &info); sl@0: if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { sl@0: continue; sl@0: } sl@0: origin = firstToken; sl@0: } sl@0: if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { sl@0: Tcl_DeleteCommandFromToken(interp, token); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclGetOriginalCommand -- sl@0: * sl@0: * An imported command is created in an namespace when a "real" command sl@0: * is imported from another namespace. If the specified command is an sl@0: * imported command, this procedure returns the original command it sl@0: * refers to. sl@0: * sl@0: * Results: sl@0: * If the command was imported into a sequence of namespaces a, b,...,n sl@0: * where each successive namespace just imports the command from the sl@0: * previous namespace, this procedure returns the Tcl_Command token in sl@0: * the first namespace, a. Otherwise, if the specified command is not sl@0: * an imported command, the procedure returns NULL. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Command sl@0: TclGetOriginalCommand(command) sl@0: Tcl_Command command; /* The imported command for which the sl@0: * original command should be returned. */ sl@0: { sl@0: register Command *cmdPtr = (Command *) command; sl@0: ImportedCmdData *dataPtr; sl@0: sl@0: if (cmdPtr->deleteProc != DeleteImportedCmd) { sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: sl@0: while (cmdPtr->deleteProc == DeleteImportedCmd) { sl@0: dataPtr = (ImportedCmdData *) cmdPtr->objClientData; sl@0: cmdPtr = dataPtr->realCmdPtr; sl@0: } sl@0: return (Tcl_Command) cmdPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InvokeImportedCmd -- sl@0: * sl@0: * Invoked by Tcl whenever the user calls an imported command that sl@0: * was created by Tcl_Import. Finds the "real" command (in another sl@0: * namespace), and passes control to it. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result object is set to an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InvokeImportedCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Points to the imported command's sl@0: * ImportedCmdData structure. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; sl@0: register Command *realCmdPtr = dataPtr->realCmdPtr; sl@0: sl@0: return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, sl@0: objc, objv); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteImportedCmd -- sl@0: * sl@0: * Invoked by Tcl whenever an imported command is deleted. The "real" sl@0: * command keeps a list of all the imported commands that refer to it, sl@0: * so those imported commands can be deleted when the real command is sl@0: * deleted. This procedure removes the imported command reference from sl@0: * the real command's list, and frees up the memory associated with sl@0: * the imported command. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Removes the imported command from the real command's import list. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DeleteImportedCmd(clientData) sl@0: ClientData clientData; /* Points to the imported command's sl@0: * ImportedCmdData structure. */ sl@0: { sl@0: ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; sl@0: Command *realCmdPtr = dataPtr->realCmdPtr; sl@0: Command *selfPtr = dataPtr->selfPtr; sl@0: register ImportRef *refPtr, *prevPtr; sl@0: sl@0: prevPtr = NULL; sl@0: for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; sl@0: refPtr = refPtr->nextPtr) { sl@0: if (refPtr->importedCmdPtr == selfPtr) { sl@0: /* sl@0: * Remove *refPtr from real command's list of imported commands sl@0: * that refer to it. sl@0: */ sl@0: sl@0: if (prevPtr == NULL) { /* refPtr is first in list */ sl@0: realCmdPtr->importRefPtr = refPtr->nextPtr; sl@0: } else { sl@0: prevPtr->nextPtr = refPtr->nextPtr; sl@0: } sl@0: ckfree((char *) refPtr); sl@0: ckfree((char *) dataPtr); sl@0: return; sl@0: } sl@0: prevPtr = refPtr; sl@0: } sl@0: sl@0: panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclGetNamespaceForQualName -- sl@0: * sl@0: * Given a qualified name specifying a command, variable, or namespace, sl@0: * and a namespace in which to resolve the name, this procedure returns sl@0: * a pointer to the namespace that contains the item. A qualified name sl@0: * consists of the "simple" name of an item qualified by the names of sl@0: * an arbitrary number of containing namespace separated by "::"s. If sl@0: * the qualified name starts with "::", it is interpreted absolutely sl@0: * from the global namespace. Otherwise, it is interpreted relative to sl@0: * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr sl@0: * is NULL, the name is interpreted relative to the current namespace. sl@0: * sl@0: * A relative name like "foo::bar::x" can be found starting in either sl@0: * the current namespace or in the global namespace. So each search sl@0: * usually follows two tracks, and two possible namespaces are sl@0: * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to sl@0: * NULL, then that path failed. sl@0: * sl@0: * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is sl@0: * sought only in the global :: namespace. The alternate search sl@0: * (also) starting from the global namespace is ignored and sl@0: * *altNsPtrPtr is set NULL. sl@0: * sl@0: * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified sl@0: * name is sought only in the namespace specified by cxtNsPtr. The sl@0: * alternate search starting from the global namespace is ignored and sl@0: * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and sl@0: * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and sl@0: * the search starts from the namespace specified by cxtNsPtr. sl@0: * sl@0: * If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace sl@0: * components of the qualified name that cannot be found are sl@0: * automatically created within their specified parent. This makes sure sl@0: * that functions like Tcl_CreateCommand always succeed. There is no sl@0: * alternate search path, so *altNsPtrPtr is set NULL. sl@0: * sl@0: * If "flags" contains FIND_ONLY_NS, the qualified name is treated as a sl@0: * reference to a namespace, and the entire qualified name is sl@0: * followed. If the name is relative, the namespace is looked up only sl@0: * in the current namespace. A pointer to the namespace is stored in sl@0: * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if sl@0: * FIND_ONLY_NS is not specified, only the leading components are sl@0: * treated as namespace names, and a pointer to the simple name of the sl@0: * final component is stored in *simpleNamePtr. sl@0: * sl@0: * Results: sl@0: * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible sl@0: * namespaces which represent the last (containing) namespace in the sl@0: * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr sl@0: * to NULL, then the search along that path failed. The procedure also sl@0: * stores a pointer to the simple name of the final component in sl@0: * *simpleNamePtr. If the qualified name is "::" or was treated as a sl@0: * namespace reference (FIND_ONLY_NS), the procedure stores a pointer sl@0: * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets sl@0: * *simpleNamePtr to point to an empty string. sl@0: * sl@0: * If there is an error, this procedure returns TCL_ERROR. If "flags" sl@0: * contains TCL_LEAVE_ERR_MSG, an error message is returned in the sl@0: * interpreter's result object. Otherwise, the interpreter's result sl@0: * object is left unchanged. sl@0: * sl@0: * *actualCxtPtrPtr is set to the actual context namespace. It is sl@0: * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr sl@0: * is NULL, it is set to the current namespace context. sl@0: * sl@0: * For backwards compatibility with the TclPro byte code loader, sl@0: * this function always returns TCL_OK. sl@0: * sl@0: * Side effects: sl@0: * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be sl@0: * created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, sl@0: nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) sl@0: Tcl_Interp *interp; /* Interpreter in which to find the sl@0: * namespace containing qualName. */ sl@0: CONST char *qualName; /* A namespace-qualified name of an sl@0: * command, variable, or namespace. */ sl@0: Namespace *cxtNsPtr; /* The namespace in which to start the sl@0: * search for qualName's namespace. If NULL sl@0: * start from the current namespace. sl@0: * Ignored if TCL_GLOBAL_ONLY is set. */ sl@0: int flags; /* Flags controlling the search: an OR'd sl@0: * combination of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, sl@0: * CREATE_NS_IF_UNKNOWN, and sl@0: * FIND_ONLY_NS. */ sl@0: Namespace **nsPtrPtr; /* Address where procedure stores a pointer sl@0: * to containing namespace if qualName is sl@0: * found starting from *cxtNsPtr or, if sl@0: * TCL_GLOBAL_ONLY is set, if qualName is sl@0: * found in the global :: namespace. NULL sl@0: * is stored otherwise. */ sl@0: Namespace **altNsPtrPtr; /* Address where procedure stores a pointer sl@0: * to containing namespace if qualName is sl@0: * found starting from the global :: sl@0: * namespace. NULL is stored if qualName sl@0: * isn't found starting from :: or if the sl@0: * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag sl@0: * is set. */ sl@0: Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer sl@0: * to the actual namespace from which the sl@0: * search started. This is either cxtNsPtr, sl@0: * the :: namespace if TCL_GLOBAL_ONLY was sl@0: * specified, or the current namespace if sl@0: * cxtNsPtr was NULL. */ sl@0: CONST char **simpleNamePtr; /* Address where procedure stores the sl@0: * simple name at end of the qualName, or sl@0: * NULL if qualName is "::" or the flag sl@0: * FIND_ONLY_NS was specified. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Namespace *nsPtr = cxtNsPtr; sl@0: Namespace *altNsPtr; sl@0: Namespace *globalNsPtr = iPtr->globalNsPtr; sl@0: CONST char *start, *end; sl@0: CONST char *nsName; sl@0: Tcl_HashEntry *entryPtr; sl@0: Tcl_DString buffer; sl@0: int len; sl@0: sl@0: /* sl@0: * Determine the context namespace nsPtr in which to start the primary sl@0: * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY sl@0: * was specified, search from the global namespace. Otherwise, use the sl@0: * namespace given in cxtNsPtr, or if that is NULL, use the current sl@0: * namespace context. Note that we always treat two or more sl@0: * adjacent ":"s as a namespace separator. sl@0: */ sl@0: sl@0: if (flags & TCL_GLOBAL_ONLY) { sl@0: nsPtr = globalNsPtr; sl@0: } else if (nsPtr == NULL) { sl@0: if (iPtr->varFramePtr != NULL) { sl@0: nsPtr = iPtr->varFramePtr->nsPtr; sl@0: } else { sl@0: nsPtr = iPtr->globalNsPtr; sl@0: } sl@0: } sl@0: sl@0: start = qualName; /* pts to start of qualifying namespace */ sl@0: if ((*qualName == ':') && (*(qualName+1) == ':')) { sl@0: start = qualName+2; /* skip over the initial :: */ sl@0: while (*start == ':') { sl@0: start++; /* skip over a subsequent : */ sl@0: } sl@0: nsPtr = globalNsPtr; sl@0: if (*start == '\0') { /* qualName is just two or more ":"s */ sl@0: *nsPtrPtr = globalNsPtr; sl@0: *altNsPtrPtr = NULL; sl@0: *actualCxtPtrPtr = globalNsPtr; sl@0: *simpleNamePtr = start; /* points to empty string */ sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: *actualCxtPtrPtr = nsPtr; sl@0: sl@0: /* sl@0: * Start an alternate search path starting with the global namespace. sl@0: * However, if the starting context is the global namespace, or if the sl@0: * flag is set to search only the namespace *cxtNsPtr, ignore the sl@0: * alternate search path. sl@0: */ sl@0: sl@0: altNsPtr = globalNsPtr; sl@0: if ((nsPtr == globalNsPtr) sl@0: || (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) { sl@0: altNsPtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Loop to resolve each namespace qualifier in qualName. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&buffer); sl@0: end = start; sl@0: while (*start != '\0') { sl@0: /* sl@0: * Find the next namespace qualifier (i.e., a name ending in "::") sl@0: * or the end of the qualified name (i.e., a name ending in "\0"). sl@0: * Set len to the number of characters, starting from start, sl@0: * in the name; set end to point after the "::"s or at the "\0". sl@0: */ sl@0: sl@0: len = 0; sl@0: for (end = start; *end != '\0'; end++) { sl@0: if ((*end == ':') && (*(end+1) == ':')) { sl@0: end += 2; /* skip over the initial :: */ sl@0: while (*end == ':') { sl@0: end++; /* skip over the subsequent : */ sl@0: } sl@0: break; /* exit for loop; end is after ::'s */ sl@0: } sl@0: len++; sl@0: } sl@0: sl@0: if ((*end == '\0') sl@0: && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) { sl@0: /* sl@0: * qualName ended with a simple name at start. If FIND_ONLY_NS sl@0: * was specified, look this up as a namespace. Otherwise, sl@0: * start is the name of a cmd or var and we are done. sl@0: */ sl@0: sl@0: if (flags & FIND_ONLY_NS) { sl@0: nsName = start; sl@0: } else { sl@0: *nsPtrPtr = nsPtr; sl@0: *altNsPtrPtr = altNsPtr; sl@0: *simpleNamePtr = start; sl@0: Tcl_DStringFree(&buffer); sl@0: return TCL_OK; sl@0: } sl@0: } else { sl@0: /* sl@0: * start points to the beginning of a namespace qualifier ending sl@0: * in "::". end points to the start of a name in that namespace sl@0: * that might be empty. Copy the namespace qualifier to a sl@0: * buffer so it can be null terminated. We can't modify the sl@0: * incoming qualName since it may be a string constant. sl@0: */ sl@0: sl@0: Tcl_DStringSetLength(&buffer, 0); sl@0: Tcl_DStringAppend(&buffer, start, len); sl@0: nsName = Tcl_DStringValue(&buffer); sl@0: } sl@0: sl@0: /* sl@0: * Look up the namespace qualifier nsName in the current namespace sl@0: * context. If it isn't found but CREATE_NS_IF_UNKNOWN is set, sl@0: * create that qualifying namespace. This is needed for procedures sl@0: * like Tcl_CreateCommand that cannot fail. sl@0: */ sl@0: sl@0: if (nsPtr != NULL) { sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); sl@0: if (entryPtr != NULL) { sl@0: nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); sl@0: } else if (flags & CREATE_NS_IF_UNKNOWN) { sl@0: Tcl_CallFrame frame; sl@0: sl@0: (void) Tcl_PushCallFrame(interp, &frame, sl@0: (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); sl@0: sl@0: nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, sl@0: (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); sl@0: Tcl_PopCallFrame(interp); sl@0: sl@0: if (nsPtr == NULL) { sl@0: panic("Could not create namespace '%s'", nsName); sl@0: } sl@0: } else { /* namespace not found and wasn't created */ sl@0: nsPtr = NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Look up the namespace qualifier in the alternate search path too. sl@0: */ sl@0: sl@0: if (altNsPtr != NULL) { sl@0: entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); sl@0: if (entryPtr != NULL) { sl@0: altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); sl@0: } else { sl@0: altNsPtr = NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If both search paths have failed, return NULL results. sl@0: */ sl@0: sl@0: if ((nsPtr == NULL) && (altNsPtr == NULL)) { sl@0: *nsPtrPtr = NULL; sl@0: *altNsPtrPtr = NULL; sl@0: *simpleNamePtr = NULL; sl@0: Tcl_DStringFree(&buffer); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: start = end; sl@0: } sl@0: sl@0: /* sl@0: * We ignore trailing "::"s in a namespace name, but in a command or sl@0: * variable name, trailing "::"s refer to the cmd or var named {}. sl@0: */ sl@0: sl@0: if ((flags & FIND_ONLY_NS) sl@0: || ((end > start ) && (*(end-1) != ':'))) { sl@0: *simpleNamePtr = NULL; /* found namespace name */ sl@0: } else { sl@0: *simpleNamePtr = end; /* found cmd/var: points to empty string */ sl@0: } sl@0: sl@0: /* sl@0: * As a special case, if we are looking for a namespace and qualName sl@0: * is "" and the current active namespace (nsPtr) is not the global sl@0: * namespace, return NULL (no namespace was found). This is because sl@0: * namespaces can not have empty names except for the global namespace. sl@0: */ sl@0: sl@0: if ((flags & FIND_ONLY_NS) && (*qualName == '\0') sl@0: && (nsPtr != globalNsPtr)) { sl@0: nsPtr = NULL; sl@0: } sl@0: sl@0: *nsPtrPtr = nsPtr; sl@0: *altNsPtrPtr = altNsPtr; sl@0: Tcl_DStringFree(&buffer); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FindNamespace -- sl@0: * sl@0: * Searches for a namespace. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the namespace if it is found. Otherwise, sl@0: * returns NULL and leaves an error message in the interpreter's sl@0: * result object if "flags" contains TCL_LEAVE_ERR_MSG. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Namespace * sl@0: Tcl_FindNamespace(interp, name, contextNsPtr, flags) sl@0: Tcl_Interp *interp; /* The interpreter in which to find the sl@0: * namespace. */ sl@0: CONST char *name; /* Namespace name. If it starts with "::", sl@0: * will be looked up in global namespace. sl@0: * Else, looked up first in contextNsPtr sl@0: * (current namespace if contextNsPtr is sl@0: * NULL), then in global namespace. */ sl@0: Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set sl@0: * or if the name starts with "::". sl@0: * Otherwise, points to namespace in which sl@0: * to resolve name; if NULL, look up name sl@0: * in the current namespace. */ sl@0: register int flags; /* Flags controlling namespace lookup: an sl@0: * OR'd combination of TCL_GLOBAL_ONLY and sl@0: * TCL_LEAVE_ERR_MSG flags. */ sl@0: { sl@0: Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; sl@0: CONST char *dummy; sl@0: sl@0: /* sl@0: * Find the namespace(s) that contain the specified namespace name. sl@0: * Add the FIND_ONLY_NS flag to resolve the name all the way down sl@0: * to its last component, a namespace. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, sl@0: (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); sl@0: sl@0: if (nsPtr != NULL) { sl@0: return (Tcl_Namespace *) nsPtr; sl@0: } else if (flags & TCL_LEAVE_ERR_MSG) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace \"", name, "\"", (char *) NULL); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FindCommand -- sl@0: * sl@0: * Searches for a command. sl@0: * sl@0: * Results: sl@0: * Returns a token for the command if it is found. Otherwise, if it sl@0: * can't be found or there is an error, returns NULL and leaves an sl@0: * error message in the interpreter's result object if "flags" sl@0: * contains TCL_LEAVE_ERR_MSG. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Command sl@0: Tcl_FindCommand(interp, name, contextNsPtr, flags) sl@0: Tcl_Interp *interp; /* The interpreter in which to find the sl@0: * command and to report errors. */ sl@0: CONST char *name; /* Command's name. If it starts with "::", sl@0: * will be looked up in global namespace. sl@0: * Else, looked up first in contextNsPtr sl@0: * (current namespace if contextNsPtr is sl@0: * NULL), then in global namespace. */ sl@0: Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. sl@0: * Otherwise, points to namespace in which sl@0: * to resolve name. If NULL, look up name sl@0: * in the current namespace. */ sl@0: int flags; /* An OR'd combination of flags: sl@0: * TCL_GLOBAL_ONLY (look up name only in sl@0: * global namespace), TCL_NAMESPACE_ONLY sl@0: * (look up only in contextNsPtr, or the sl@0: * current namespace if contextNsPtr is sl@0: * NULL), and TCL_LEAVE_ERR_MSG. If both sl@0: * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY sl@0: * are given, TCL_GLOBAL_ONLY is sl@0: * ignored. */ sl@0: { sl@0: Interp *iPtr = (Interp*)interp; sl@0: sl@0: ResolverScheme *resPtr; sl@0: Namespace *nsPtr[2], *cxtNsPtr; sl@0: CONST char *simpleName; sl@0: register Tcl_HashEntry *entryPtr; sl@0: register Command *cmdPtr; sl@0: register int search; sl@0: int result; sl@0: Tcl_Command cmd; sl@0: sl@0: /* sl@0: * If this namespace has a command resolver, then give it first sl@0: * crack at the command resolution. If the interpreter has any sl@0: * command resolvers, consult them next. The command resolver sl@0: * procedures may return a Tcl_Command value, they may signal sl@0: * to continue onward, or they may signal an error. sl@0: */ sl@0: if ((flags & TCL_GLOBAL_ONLY) != 0) { sl@0: cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: } sl@0: else if (contextNsPtr != NULL) { sl@0: cxtNsPtr = (Namespace *) contextNsPtr; sl@0: } sl@0: else { sl@0: cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: } sl@0: sl@0: if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { sl@0: resPtr = iPtr->resolverPtr; sl@0: sl@0: if (cxtNsPtr->cmdResProc) { sl@0: result = (*cxtNsPtr->cmdResProc)(interp, name, sl@0: (Tcl_Namespace *) cxtNsPtr, flags, &cmd); sl@0: } else { sl@0: result = TCL_CONTINUE; sl@0: } sl@0: sl@0: while (result == TCL_CONTINUE && resPtr) { sl@0: if (resPtr->cmdResProc) { sl@0: result = (*resPtr->cmdResProc)(interp, name, sl@0: (Tcl_Namespace *) cxtNsPtr, flags, &cmd); sl@0: } sl@0: resPtr = resPtr->nextPtr; sl@0: } sl@0: sl@0: if (result == TCL_OK) { sl@0: return cmd; sl@0: } sl@0: else if (result != TCL_CONTINUE) { sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Find the namespace(s) that contain the command. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, sl@0: flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); sl@0: sl@0: /* sl@0: * Look for the command in the command table of its namespace. sl@0: * Be sure to check both possible search paths: from the specified sl@0: * namespace context and from the global namespace. sl@0: */ sl@0: sl@0: cmdPtr = NULL; sl@0: for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { sl@0: if ((nsPtr[search] != NULL) && (simpleName != NULL)) { sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, sl@0: simpleName); sl@0: if (entryPtr != NULL) { sl@0: cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (cmdPtr != NULL) { sl@0: return (Tcl_Command) cmdPtr; sl@0: } else if (flags & TCL_LEAVE_ERR_MSG) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown command \"", name, "\"", (char *) NULL); sl@0: } sl@0: sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FindNamespaceVar -- sl@0: * sl@0: * Searches for a namespace variable, a variable not local to a sl@0: * procedure. The variable can be either a scalar or an array, but sl@0: * may not be an element of an array. sl@0: * sl@0: * Results: sl@0: * Returns a token for the variable if it is found. Otherwise, if it sl@0: * can't be found or there is an error, returns NULL and leaves an sl@0: * error message in the interpreter's result object if "flags" sl@0: * contains TCL_LEAVE_ERR_MSG. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Var sl@0: Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) sl@0: Tcl_Interp *interp; /* The interpreter in which to find the sl@0: * variable. */ sl@0: CONST char *name; /* Variable's name. If it starts with "::", sl@0: * will be looked up in global namespace. sl@0: * Else, looked up first in contextNsPtr sl@0: * (current namespace if contextNsPtr is sl@0: * NULL), then in global namespace. */ sl@0: Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. sl@0: * Otherwise, points to namespace in which sl@0: * to resolve name. If NULL, look up name sl@0: * in the current namespace. */ sl@0: int flags; /* An OR'd combination of flags: sl@0: * TCL_GLOBAL_ONLY (look up name only in sl@0: * global namespace), TCL_NAMESPACE_ONLY sl@0: * (look up only in contextNsPtr, or the sl@0: * current namespace if contextNsPtr is sl@0: * NULL), and TCL_LEAVE_ERR_MSG. If both sl@0: * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY sl@0: * are given, TCL_GLOBAL_ONLY is sl@0: * ignored. */ sl@0: { sl@0: Interp *iPtr = (Interp*)interp; sl@0: ResolverScheme *resPtr; sl@0: Namespace *nsPtr[2], *cxtNsPtr; sl@0: CONST char *simpleName; sl@0: Tcl_HashEntry *entryPtr; sl@0: Var *varPtr; sl@0: register int search; sl@0: int result; sl@0: Tcl_Var var; sl@0: sl@0: /* sl@0: * If this namespace has a variable resolver, then give it first sl@0: * crack at the variable resolution. It may return a Tcl_Var sl@0: * value, it may signal to continue onward, or it may signal sl@0: * an error. sl@0: */ sl@0: if ((flags & TCL_GLOBAL_ONLY) != 0) { sl@0: cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: } sl@0: else if (contextNsPtr != NULL) { sl@0: cxtNsPtr = (Namespace *) contextNsPtr; sl@0: } sl@0: else { sl@0: cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: } sl@0: sl@0: if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { sl@0: resPtr = iPtr->resolverPtr; sl@0: sl@0: if (cxtNsPtr->varResProc) { sl@0: result = (*cxtNsPtr->varResProc)(interp, name, sl@0: (Tcl_Namespace *) cxtNsPtr, flags, &var); sl@0: } else { sl@0: result = TCL_CONTINUE; sl@0: } sl@0: sl@0: while (result == TCL_CONTINUE && resPtr) { sl@0: if (resPtr->varResProc) { sl@0: result = (*resPtr->varResProc)(interp, name, sl@0: (Tcl_Namespace *) cxtNsPtr, flags, &var); sl@0: } sl@0: resPtr = resPtr->nextPtr; sl@0: } sl@0: sl@0: if (result == TCL_OK) { sl@0: return var; sl@0: } sl@0: else if (result != TCL_CONTINUE) { sl@0: return (Tcl_Var) NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Find the namespace(s) that contain the variable. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, sl@0: flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); sl@0: sl@0: /* sl@0: * Look for the variable in the variable table of its namespace. sl@0: * Be sure to check both possible search paths: from the specified sl@0: * namespace context and from the global namespace. sl@0: */ sl@0: sl@0: varPtr = NULL; sl@0: for (search = 0; (search < 2) && (varPtr == NULL); search++) { sl@0: if ((nsPtr[search] != NULL) && (simpleName != NULL)) { sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, sl@0: simpleName); sl@0: if (entryPtr != NULL) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: } sl@0: } sl@0: } sl@0: if (varPtr != NULL) { sl@0: return (Tcl_Var) varPtr; sl@0: } else if (flags & TCL_LEAVE_ERR_MSG) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown variable \"", name, "\"", (char *) NULL); sl@0: } sl@0: return (Tcl_Var) NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclResetShadowedCmdRefs -- sl@0: * sl@0: * Called when a command is added to a namespace to check for existing sl@0: * command references that the new command may invalidate. Consider the sl@0: * following cases that could happen when you add a command "foo" to a sl@0: * namespace "b": sl@0: * 1. It could shadow a command named "foo" at the global scope. sl@0: * If it does, all command references in the namespace "b" are sl@0: * suspect. sl@0: * 2. Suppose the namespace "b" resides in a namespace "a". sl@0: * Then to "a" the new command "b::foo" could shadow another sl@0: * command "b::foo" in the global namespace. If so, then all sl@0: * command references in "a" are suspect. sl@0: * The same checks are applied to all parent namespaces, until we sl@0: * reach the global :: namespace. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If the new command shadows an existing command, the cmdRefEpoch sl@0: * counter is incremented in each namespace that sees the shadow. sl@0: * This invalidates all command references that were previously cached sl@0: * in that namespace. The next time the commands are used, they are sl@0: * resolved from scratch. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclResetShadowedCmdRefs(interp, newCmdPtr) sl@0: Tcl_Interp *interp; /* Interpreter containing the new command. */ sl@0: Command *newCmdPtr; /* Points to the new command. */ sl@0: { sl@0: char *cmdName; sl@0: Tcl_HashEntry *hPtr; sl@0: register Namespace *nsPtr; sl@0: Namespace *trailNsPtr, *shadowNsPtr; sl@0: Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: int found, i; sl@0: sl@0: /* sl@0: * This procedure generates an array used to hold the trail list. This sl@0: * starts out with stack-allocated space but uses dynamically-allocated sl@0: * storage if needed. sl@0: */ sl@0: sl@0: Namespace *(trailStorage[NUM_TRAIL_ELEMS]); sl@0: Namespace **trailPtr = trailStorage; sl@0: int trailFront = -1; sl@0: int trailSize = NUM_TRAIL_ELEMS; sl@0: sl@0: /* sl@0: * Start at the namespace containing the new command, and work up sl@0: * through the list of parents. Stop just before the global namespace, sl@0: * since the global namespace can't "shadow" its own entries. sl@0: * sl@0: * The namespace "trail" list we build consists of the names of each sl@0: * namespace that encloses the new command, in order from outermost to sl@0: * innermost: for example, "a" then "b". Each iteration of this loop sl@0: * eventually extends the trail upwards by one namespace, nsPtr. We use sl@0: * this trail list to see if nsPtr (e.g. "a" in 2. above) could have sl@0: * now-invalid cached command references. This will happen if nsPtr sl@0: * (e.g. "a") contains a sequence of child namespaces (e.g. "b") sl@0: * such that there is a identically-named sequence of child namespaces sl@0: * starting from :: (e.g. "::b") whose tail namespace contains a command sl@0: * also named cmdName. sl@0: */ sl@0: sl@0: cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); sl@0: for (nsPtr = newCmdPtr->nsPtr; sl@0: (nsPtr != NULL) && (nsPtr != globalNsPtr); sl@0: nsPtr = nsPtr->parentPtr) { sl@0: /* sl@0: * Find the maximal sequence of child namespaces contained in nsPtr sl@0: * such that there is a identically-named sequence of child sl@0: * namespaces starting from ::. shadowNsPtr will be the tail of this sl@0: * sequence, or the deepest namespace under :: that might contain a sl@0: * command now shadowed by cmdName. We check below if shadowNsPtr sl@0: * actually contains a command cmdName. sl@0: */ sl@0: sl@0: found = 1; sl@0: shadowNsPtr = globalNsPtr; sl@0: sl@0: for (i = trailFront; i >= 0; i--) { sl@0: trailNsPtr = trailPtr[i]; sl@0: hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, sl@0: trailNsPtr->name); sl@0: if (hPtr != NULL) { sl@0: shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); sl@0: } else { sl@0: found = 0; sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If shadowNsPtr contains a command named cmdName, we invalidate sl@0: * all of the command refs cached in nsPtr. As a boundary case, sl@0: * shadowNsPtr is initially :: and we check for case 1. above. sl@0: */ sl@0: sl@0: if (found) { sl@0: hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); sl@0: if (hPtr != NULL) { sl@0: nsPtr->cmdRefEpoch++; sl@0: sl@0: /* sl@0: * If the shadowed command was compiled to bytecodes, we sl@0: * invalidate all the bytecodes in nsPtr, to force a new sl@0: * compilation. We use the resolverEpoch to signal the need sl@0: * for a fresh compilation of every bytecode. sl@0: */ sl@0: sl@0: if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) { sl@0: nsPtr->resolverEpoch++; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Insert nsPtr at the front of the trail list: i.e., at the end sl@0: * of the trailPtr array. sl@0: */ sl@0: sl@0: trailFront++; sl@0: if (trailFront == trailSize) { sl@0: size_t currBytes = trailSize * sizeof(Namespace *); sl@0: int newSize = 2*trailSize; sl@0: size_t newBytes = newSize * sizeof(Namespace *); sl@0: Namespace **newPtr = sl@0: (Namespace **) ckalloc((unsigned) newBytes); sl@0: sl@0: memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); sl@0: if (trailPtr != trailStorage) { sl@0: ckfree((char *) trailPtr); sl@0: } sl@0: trailPtr = newPtr; sl@0: trailSize = newSize; sl@0: } sl@0: trailPtr[trailFront] = nsPtr; sl@0: } sl@0: sl@0: /* sl@0: * Free any allocated storage. sl@0: */ sl@0: sl@0: if (trailPtr != trailStorage) { sl@0: ckfree((char *) trailPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetNamespaceFromObj -- sl@0: * sl@0: * Gets the namespace specified by the name in a Tcl_Obj. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the namespace was resolved successfully, and sl@0: * stores a pointer to the namespace in the location specified by sl@0: * nsPtrPtr. If the namespace can't be found, the procedure stores sl@0: * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, sl@0: * this procedure returns TCL_ERROR. sl@0: * sl@0: * Side effects: sl@0: * May update the internal representation for the object, caching the sl@0: * namespace reference. The next time this procedure is called, the sl@0: * namespace value can be found quickly. sl@0: * sl@0: * If anything goes wrong, an error message is left in the sl@0: * interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetNamespaceFromObj(interp, objPtr, nsPtrPtr) sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: Tcl_Obj *objPtr; /* The object to be resolved as the name sl@0: * of a namespace. */ sl@0: Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register ResolvedNsName *resNamePtr; sl@0: register Namespace *nsPtr; sl@0: Namespace *currNsPtr; sl@0: CallFrame *savedFramePtr; sl@0: int result = TCL_OK; sl@0: char *name; sl@0: sl@0: /* sl@0: * If the namespace name is fully qualified, do as if the lookup were sl@0: * done from the global namespace; this helps avoid repeated lookups sl@0: * of fully qualified names. sl@0: */ sl@0: sl@0: savedFramePtr = iPtr->varFramePtr; sl@0: name = Tcl_GetString(objPtr); sl@0: if ((*name++ == ':') && (*name == ':')) { sl@0: iPtr->varFramePtr = NULL; sl@0: } sl@0: sl@0: currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: sl@0: /* sl@0: * Get the internal representation, converting to a namespace type if sl@0: * needed. The internal representation is a ResolvedNsName that points sl@0: * to the actual namespace. sl@0: */ sl@0: sl@0: if (objPtr->typePtr != &tclNsNameType) { sl@0: result = tclNsNameType.setFromAnyProc(interp, objPtr); sl@0: if (result != TCL_OK) { sl@0: goto done; sl@0: } sl@0: } sl@0: resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; sl@0: sl@0: /* sl@0: * Check the context namespace of the resolved symbol to make sure that sl@0: * it is fresh. If not, then force another conversion to the namespace sl@0: * type, to discard the old rep and create a new one. Note that we sl@0: * verify that the namespace id of the cached namespace is the same as sl@0: * the id when we cached it; this insures that the namespace wasn't sl@0: * deleted and a new one created at the same address. sl@0: */ sl@0: sl@0: nsPtr = NULL; sl@0: if ((resNamePtr != NULL) sl@0: && (resNamePtr->refNsPtr == currNsPtr) sl@0: && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { sl@0: nsPtr = resNamePtr->nsPtr; sl@0: if (nsPtr->flags & NS_DEAD) { sl@0: nsPtr = NULL; sl@0: } sl@0: } sl@0: if (nsPtr == NULL) { /* try again */ sl@0: result = tclNsNameType.setFromAnyProc(interp, objPtr); sl@0: if (result != TCL_OK) { sl@0: goto done; sl@0: } sl@0: resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; sl@0: if (resNamePtr != NULL) { sl@0: nsPtr = resNamePtr->nsPtr; sl@0: if (nsPtr->flags & NS_DEAD) { sl@0: nsPtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: *nsPtrPtr = (Tcl_Namespace *) nsPtr; sl@0: sl@0: done: sl@0: iPtr->varFramePtr = savedFramePtr; sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NamespaceObjCmd -- sl@0: * sl@0: * Invoked to implement the "namespace" command that creates, deletes, sl@0: * or manipulates Tcl namespaces. Handles the following syntax: sl@0: * sl@0: * namespace children ?name? ?pattern? sl@0: * namespace code arg sl@0: * namespace current sl@0: * namespace delete ?name name...? sl@0: * namespace eval name arg ?arg...? sl@0: * namespace exists name sl@0: * namespace export ?-clear? ?pattern pattern...? sl@0: * namespace forget ?pattern pattern...? sl@0: * namespace import ?-force? ?pattern pattern...? sl@0: * namespace inscope name arg ?arg...? sl@0: * namespace origin name sl@0: * namespace parent ?name? sl@0: * namespace qualifiers string sl@0: * namespace tail string sl@0: * namespace which ?-command? ?-variable? name sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the command is successful. Returns TCL_ERROR if sl@0: * anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Based on the subcommand name (e.g., "import"), this procedure sl@0: * dispatches to a corresponding procedure NamespaceXXXCmd defined sl@0: * statically in this file. This procedure's side effects depend on sl@0: * whatever that subcommand procedure does. If there is an error, this sl@0: * procedure returns an error message in the interpreter's result sl@0: * object. Otherwise it may return a result in the interpreter's result sl@0: * object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_NamespaceObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Arbitrary value passed to cmd. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: register int objc; /* Number of arguments. */ sl@0: register Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: static CONST char *subCmds[] = { sl@0: "children", "code", "current", "delete", sl@0: "eval", "exists", "export", "forget", "import", sl@0: "inscope", "origin", "parent", "qualifiers", sl@0: "tail", "which", (char *) NULL sl@0: }; sl@0: enum NSSubCmdIdx { sl@0: NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, sl@0: NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, sl@0: NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, sl@0: NSTailIdx, NSWhichIdx sl@0: }; sl@0: int index, result; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Return an index reflecting the particular subcommand. sl@0: */ sl@0: sl@0: result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, sl@0: "option", /*flags*/ 0, (int *) &index); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: switch (index) { sl@0: case NSChildrenIdx: sl@0: result = NamespaceChildrenCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSCodeIdx: sl@0: result = NamespaceCodeCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSCurrentIdx: sl@0: result = NamespaceCurrentCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSDeleteIdx: sl@0: result = NamespaceDeleteCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSEvalIdx: sl@0: result = NamespaceEvalCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSExistsIdx: sl@0: result = NamespaceExistsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSExportIdx: sl@0: result = NamespaceExportCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSForgetIdx: sl@0: result = NamespaceForgetCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSImportIdx: sl@0: result = NamespaceImportCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSInscopeIdx: sl@0: result = NamespaceInscopeCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSOriginIdx: sl@0: result = NamespaceOriginCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSParentIdx: sl@0: result = NamespaceParentCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSQualifiersIdx: sl@0: result = NamespaceQualifiersCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSTailIdx: sl@0: result = NamespaceTailCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case NSWhichIdx: sl@0: result = NamespaceWhichCmd(clientData, interp, objc, objv); sl@0: break; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceChildrenCmd -- sl@0: * sl@0: * Invoked to implement the "namespace children" command that returns a sl@0: * list containing the fully-qualified names of the child namespaces of sl@0: * a given namespace. Handles the following syntax: sl@0: * sl@0: * namespace children ?name? ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceChildrenCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Namespace *namespacePtr; sl@0: Namespace *nsPtr, *childNsPtr; sl@0: Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: char *pattern = NULL; sl@0: Tcl_DString buffer; sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: Tcl_Obj *listPtr, *elemPtr; sl@0: sl@0: /* sl@0: * Get a pointer to the specified namespace, or the current namespace. sl@0: */ sl@0: sl@0: if (objc == 2) { sl@0: nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: } else if ((objc == 3) || (objc == 4)) { sl@0: if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (namespacePtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace \"", Tcl_GetString(objv[2]), sl@0: "\" in namespace children command", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: nsPtr = (Namespace *) namespacePtr; sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Get the glob-style pattern, if any, used to narrow the search. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&buffer); sl@0: if (objc == 4) { sl@0: char *name = Tcl_GetString(objv[3]); sl@0: sl@0: if ((*name == ':') && (*(name+1) == ':')) { sl@0: pattern = name; sl@0: } else { sl@0: Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); sl@0: if (nsPtr != globalNsPtr) { sl@0: Tcl_DStringAppend(&buffer, "::", 2); sl@0: } sl@0: Tcl_DStringAppend(&buffer, name, -1); sl@0: pattern = Tcl_DStringValue(&buffer); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Create a list containing the full names of all child namespaces sl@0: * whose names match the specified pattern, if any. sl@0: */ sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); sl@0: while (entryPtr != NULL) { sl@0: childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); sl@0: if ((pattern == NULL) sl@0: || Tcl_StringMatch(childNsPtr->fullName, pattern)) { sl@0: elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemPtr); sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: Tcl_DStringFree(&buffer); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceCodeCmd -- sl@0: * sl@0: * Invoked to implement the "namespace code" command to capture the sl@0: * namespace context of a command. Handles the following syntax: sl@0: * sl@0: * namespace code arg sl@0: * sl@0: * Here "arg" can be a list. "namespace code arg" produces a result sl@0: * equivalent to that produced by the command sl@0: * sl@0: * list ::namespace inscope [namespace current] $arg sl@0: * sl@0: * However, if "arg" is itself a scoped value starting with sl@0: * "::namespace inscope", then the result is just "arg". sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * If anything goes wrong, this procedure returns an error sl@0: * message as the result in the interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceCodeCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Namespace *currNsPtr; sl@0: Tcl_Obj *listPtr, *objPtr; sl@0: register char *arg, *p; sl@0: int length; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arg"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If "arg" is already a scoped value, then return it directly. sl@0: */ sl@0: sl@0: arg = Tcl_GetStringFromObj(objv[2], &length); sl@0: while (*arg == ':') { sl@0: arg++; sl@0: length--; sl@0: } sl@0: if ((*arg == 'n') && (length > 17) sl@0: && (strncmp(arg, "namespace", 9) == 0)) { sl@0: for (p = (arg + 9); (*p == ' '); p++) { sl@0: /* empty body: skip over spaces */ sl@0: } sl@0: if ((*p == 'i') && ((p + 7) <= (arg + length)) sl@0: && (strncmp(p, "inscope", 7) == 0)) { sl@0: Tcl_SetObjResult(interp, objv[2]); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Otherwise, construct a scoped command by building a list with sl@0: * "namespace inscope", the full name of the current namespace, and sl@0: * the argument "arg". By constructing a list, we ensure that scoped sl@0: * commands are interpreted properly when they are executed later, sl@0: * by the "namespace inscope" command. sl@0: */ sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj("::namespace", -1)); sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj("inscope", -1)); sl@0: sl@0: currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { sl@0: objPtr = Tcl_NewStringObj("::", -1); sl@0: } else { sl@0: objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, objPtr); sl@0: sl@0: Tcl_ListObjAppendElement(interp, listPtr, objv[2]); sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceCurrentCmd -- sl@0: * sl@0: * Invoked to implement the "namespace current" command which returns sl@0: * the fully-qualified name of the current namespace. Handles the sl@0: * following syntax: sl@0: * sl@0: * namespace current sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceCurrentCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register Namespace *currNsPtr; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * The "real" name of the global namespace ("::") is the null string, sl@0: * but we return "::" for it as a convenience to programmers. Note that sl@0: * "" and "::" are treated as synonyms by the namespace code so that it sl@0: * is still easy to do things like: sl@0: * sl@0: * namespace [namespace current]::bar { ... } sl@0: */ sl@0: sl@0: currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1); sl@0: } else { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceDeleteCmd -- sl@0: * sl@0: * Invoked to implement the "namespace delete" command to delete sl@0: * namespace(s). Handles the following syntax: sl@0: * sl@0: * namespace delete ?name name...? sl@0: * sl@0: * Each name identifies a namespace. It may include a sequence of sl@0: * namespace qualifiers separated by "::"s. If a namespace is found, it sl@0: * is deleted: all variables and procedures contained in that namespace sl@0: * are deleted. If that namespace is being used on the call stack, it sl@0: * is kept alive (but logically deleted) until it is removed from the sl@0: * call stack: that is, it can no longer be referenced by name but any sl@0: * currently executing procedure that refers to it is allowed to do so sl@0: * until the procedure returns. If the namespace can't be found, this sl@0: * procedure returns an error. If no namespaces are specified, this sl@0: * command does nothing. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Deletes the specified namespaces. If anything goes wrong, this sl@0: * procedure returns an error message in the interpreter's sl@0: * result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceDeleteCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Namespace *namespacePtr; sl@0: char *name; sl@0: register int i; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Destroying one namespace may cause another to be destroyed. Break sl@0: * this into two passes: first check to make sure that all namespaces on sl@0: * the command line are valid, and report any errors. sl@0: */ sl@0: sl@0: for (i = 2; i < objc; i++) { sl@0: name = Tcl_GetString(objv[i]); sl@0: namespacePtr = Tcl_FindNamespace(interp, name, sl@0: (Tcl_Namespace *) NULL, /*flags*/ 0); sl@0: if (namespacePtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace \"", Tcl_GetString(objv[i]), sl@0: "\" in namespace delete command", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Okay, now delete each namespace. sl@0: */ sl@0: sl@0: for (i = 2; i < objc; i++) { sl@0: name = Tcl_GetString(objv[i]); sl@0: namespacePtr = Tcl_FindNamespace(interp, name, sl@0: (Tcl_Namespace *) NULL, /* flags */ 0); sl@0: if (namespacePtr) { sl@0: Tcl_DeleteNamespace(namespacePtr); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceEvalCmd -- sl@0: * sl@0: * Invoked to implement the "namespace eval" command. Executes sl@0: * commands in a namespace. If the namespace does not already exist, sl@0: * it is created. Handles the following syntax: sl@0: * sl@0: * namespace eval name arg ?arg...? sl@0: * sl@0: * If more than one arg argument is specified, the command that is sl@0: * executed is the result of concatenating the arguments together with sl@0: * a space between each argument. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the namespace is found and the commands are sl@0: * executed successfully. Returns TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns the result of the command in the interpreter's result sl@0: * object. If anything goes wrong, this procedure returns an error sl@0: * message as the result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceEvalCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Namespace *namespacePtr; sl@0: CallFrame frame; sl@0: Tcl_Obj *objPtr; sl@0: char *name; sl@0: int length, result; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Try to resolve the namespace reference, caching the result in the sl@0: * namespace object along the way. sl@0: */ sl@0: sl@0: result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * If the namespace wasn't found, try to create it. sl@0: */ sl@0: sl@0: if (namespacePtr == NULL) { sl@0: name = Tcl_GetStringFromObj(objv[2], &length); sl@0: namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, sl@0: (Tcl_NamespaceDeleteProc *) NULL); sl@0: if (namespacePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Make the specified namespace the current namespace and evaluate sl@0: * the command(s). sl@0: */ sl@0: sl@0: result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, sl@0: namespacePtr, /*isProcCallFrame*/ 0); sl@0: if (result != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: frame.objc = objc; sl@0: frame.objv = objv; /* ref counts do not need to be incremented here */ sl@0: sl@0: if (objc == 4) { sl@0: #ifndef TCL_TIP280 sl@0: result = Tcl_EvalObjEx(interp, objv[3], 0); sl@0: #else sl@0: /* TIP #280 : Make invoker available to eval'd script */ sl@0: Interp* iPtr = (Interp*) interp; sl@0: result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3); sl@0: #endif sl@0: } else { sl@0: /* sl@0: * More than one argument: concatenate them together with spaces sl@0: * between, then evaluate the result. Tcl_EvalObjEx will delete sl@0: * the object when it decrements its refcount after eval'ing it. sl@0: */ sl@0: objPtr = Tcl_ConcatObj(objc-3, objv+3); sl@0: #ifndef TCL_TIP280 sl@0: result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); sl@0: #else sl@0: /* TIP #280. Make invoking context available to eval'd script */ sl@0: result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); sl@0: #endif sl@0: } sl@0: if (result == TCL_ERROR) { sl@0: char msg[256 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", sl@0: namespacePtr->fullName, interp->errorLine); sl@0: Tcl_AddObjErrorInfo(interp, msg, -1); sl@0: } sl@0: sl@0: /* sl@0: * Restore the previous "current" namespace. sl@0: */ sl@0: sl@0: Tcl_PopCallFrame(interp); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceExistsCmd -- sl@0: * sl@0: * Invoked to implement the "namespace exists" command that returns sl@0: * true if the given namespace currently exists, and false otherwise. sl@0: * Handles the following syntax: sl@0: * sl@0: * namespace exists name sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceExistsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Namespace *namespacePtr; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "name"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Check whether the given namespace exists sl@0: */ sl@0: sl@0: if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL)); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceExportCmd -- sl@0: * sl@0: * Invoked to implement the "namespace export" command that specifies sl@0: * which commands are exported from a namespace. The exported commands sl@0: * are those that can be imported into another namespace using sl@0: * "namespace import". Both commands defined in a namespace and sl@0: * commands the namespace has imported can be exported by a sl@0: * namespace. This command has the following syntax: sl@0: * sl@0: * namespace export ?-clear? ?pattern pattern...? sl@0: * sl@0: * Each pattern may contain "string match"-style pattern matching sl@0: * special characters, but the pattern may not include any namespace sl@0: * qualifiers: that is, the pattern must specify commands in the sl@0: * current (exporting) namespace. The specified patterns are appended sl@0: * onto the namespace's list of export patterns. sl@0: * sl@0: * To reset the namespace's export pattern list, specify the "-clear" sl@0: * flag. sl@0: * sl@0: * If there are no export patterns and the "-clear" flag isn't given, sl@0: * this command returns the namespace's current export list. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceExportCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); sl@0: char *pattern, *string; sl@0: int resetListFirst = 0; sl@0: int firstArg, patternCt, i, result; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "?-clear? ?pattern pattern...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Process the optional "-clear" argument. sl@0: */ sl@0: sl@0: firstArg = 2; sl@0: if (firstArg < objc) { sl@0: string = Tcl_GetString(objv[firstArg]); sl@0: if (strcmp(string, "-clear") == 0) { sl@0: resetListFirst = 1; sl@0: firstArg++; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If no pattern arguments are given, and "-clear" isn't specified, sl@0: * return the namespace's current export pattern list. sl@0: */ sl@0: sl@0: patternCt = (objc - firstArg); sl@0: if (patternCt == 0) { sl@0: if (firstArg > 2) { sl@0: return TCL_OK; sl@0: } else { /* create list with export patterns */ sl@0: Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: result = Tcl_AppendExportList(interp, sl@0: (Tcl_Namespace *) currNsPtr, listPtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Add each pattern to the namespace's export pattern list. sl@0: */ sl@0: sl@0: for (i = firstArg; i < objc; i++) { sl@0: pattern = Tcl_GetString(objv[i]); sl@0: result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, sl@0: ((i == firstArg)? resetListFirst : 0)); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceForgetCmd -- sl@0: * sl@0: * Invoked to implement the "namespace forget" command to remove sl@0: * imported commands from a namespace. Handles the following syntax: sl@0: * sl@0: * namespace forget ?pattern pattern...? sl@0: * sl@0: * Each pattern is a name like "foo::*" or "a::b::x*". That is, the sl@0: * pattern may include the special pattern matching characters sl@0: * recognized by the "string match" command, but only in the command sl@0: * name at the end of the qualified name; the special pattern sl@0: * characters may not appear in a namespace name. All of the commands sl@0: * that match that pattern are checked to see if they have an imported sl@0: * command in the current namespace that refers to the matched sl@0: * command. If there is an alias, it is removed. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Imported commands are removed from the current namespace. If sl@0: * anything goes wrong, this procedure returns an error message in the sl@0: * interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceForgetCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *pattern; sl@0: register int i, result; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (i = 2; i < objc; i++) { sl@0: pattern = Tcl_GetString(objv[i]); sl@0: result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceImportCmd -- sl@0: * sl@0: * Invoked to implement the "namespace import" command that imports sl@0: * commands into a namespace. Handles the following syntax: sl@0: * sl@0: * namespace import ?-force? ?pattern pattern...? sl@0: * sl@0: * Each pattern is a namespace-qualified name like "foo::*", sl@0: * "a::b::x*", or "bar::p". That is, the pattern may include the sl@0: * special pattern matching characters recognized by the "string match" sl@0: * command, but only in the command name at the end of the qualified sl@0: * name; the special pattern characters may not appear in a namespace sl@0: * name. All of the commands that match the pattern and which are sl@0: * exported from their namespace are made accessible from the current sl@0: * namespace context. This is done by creating a new "imported command" sl@0: * in the current namespace that points to the real command in its sl@0: * original namespace; when the imported command is called, it invokes sl@0: * the real command. sl@0: * sl@0: * If an imported command conflicts with an existing command, it is sl@0: * treated as an error. But if the "-force" option is included, then sl@0: * existing commands are overwritten by the imported commands. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Adds imported commands to the current namespace. If anything goes sl@0: * wrong, this procedure returns an error message in the interpreter's sl@0: * result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceImportCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int allowOverwrite = 0; sl@0: char *string, *pattern; sl@0: register int i, result; sl@0: int firstArg; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "?-force? ?pattern pattern...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Skip over the optional "-force" as the first argument. sl@0: */ sl@0: sl@0: firstArg = 2; sl@0: if (firstArg < objc) { sl@0: string = Tcl_GetString(objv[firstArg]); sl@0: if ((*string == '-') && (strcmp(string, "-force") == 0)) { sl@0: allowOverwrite = 1; sl@0: firstArg++; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Handle the imports for each of the patterns. sl@0: */ sl@0: sl@0: for (i = firstArg; i < objc; i++) { sl@0: pattern = Tcl_GetString(objv[i]); sl@0: result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, sl@0: allowOverwrite); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceInscopeCmd -- sl@0: * sl@0: * Invoked to implement the "namespace inscope" command that executes a sl@0: * script in the context of a particular namespace. This command is not sl@0: * expected to be used directly by programmers; calls to it are sl@0: * generated implicitly when programs use "namespace code" commands sl@0: * to register callback scripts. Handles the following syntax: sl@0: * sl@0: * namespace inscope name arg ?arg...? sl@0: * sl@0: * The "namespace inscope" command is much like the "namespace eval" sl@0: * command except that it has lappend semantics and the namespace must sl@0: * already exist. It treats the first argument as a list, and appends sl@0: * any arguments after the first onto the end as proper list elements. sl@0: * For example, sl@0: * sl@0: * namespace inscope ::foo a b c d sl@0: * sl@0: * is equivalent to sl@0: * sl@0: * namespace eval ::foo [concat a [list b c d]] sl@0: * sl@0: * This lappend semantics is important because many callback scripts sl@0: * are actually prefixes. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK to indicate success, or TCL_ERROR to indicate sl@0: * failure. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the Tcl interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceInscopeCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Namespace *namespacePtr; sl@0: Tcl_CallFrame frame; sl@0: int i, result; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Resolve the namespace reference. sl@0: */ sl@0: sl@0: result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (namespacePtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace \"", Tcl_GetString(objv[2]), sl@0: "\" in inscope namespace command", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make the specified namespace the current namespace. sl@0: */ sl@0: sl@0: result = Tcl_PushCallFrame(interp, &frame, namespacePtr, sl@0: /*isProcCallFrame*/ 0); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Execute the command. If there is just one argument, just treat it as sl@0: * a script and evaluate it. Otherwise, create a list from the arguments sl@0: * after the first one, then concatenate the first argument and the list sl@0: * of extra arguments to form the command to evaluate. sl@0: */ sl@0: sl@0: if (objc == 4) { sl@0: result = Tcl_EvalObjEx(interp, objv[3], 0); sl@0: } else { sl@0: Tcl_Obj *concatObjv[2]; sl@0: register Tcl_Obj *listPtr, *cmdObjPtr; sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: for (i = 4; i < objc; i++) { sl@0: result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount(listPtr); /* free unneeded obj */ sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: concatObjv[0] = objv[3]; sl@0: concatObjv[1] = listPtr; sl@0: cmdObjPtr = Tcl_ConcatObj(2, concatObjv); sl@0: result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); sl@0: Tcl_DecrRefCount(listPtr); /* we're done with the list object */ sl@0: } sl@0: if (result == TCL_ERROR) { sl@0: char msg[256 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(msg, sl@0: "\n (in namespace inscope \"%.200s\" script line %d)", sl@0: namespacePtr->fullName, interp->errorLine); sl@0: Tcl_AddObjErrorInfo(interp, msg, -1); sl@0: } sl@0: sl@0: /* sl@0: * Restore the previous "current" namespace. sl@0: */ sl@0: sl@0: Tcl_PopCallFrame(interp); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceOriginCmd -- sl@0: * sl@0: * Invoked to implement the "namespace origin" command to return the sl@0: * fully-qualified name of the "real" command to which the specified sl@0: * "imported command" refers. Handles the following syntax: sl@0: * sl@0: * namespace origin name sl@0: * sl@0: * Results: sl@0: * An imported command is created in an namespace when that namespace sl@0: * imports a command from another namespace. If a command is imported sl@0: * into a sequence of namespaces a, b,...,n where each successive sl@0: * namespace just imports the command from the previous namespace, this sl@0: * command returns the fully-qualified name of the original command in sl@0: * the first namespace, a. If "name" does not refer to an alias, its sl@0: * fully-qualified name is returned. The returned name is stored in the sl@0: * interpreter's result object. This procedure returns TCL_OK if sl@0: * successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * If anything goes wrong, this procedure returns an error message in sl@0: * the interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceOriginCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Command command, origCommand; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "name"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: command = Tcl_GetCommandFromObj(interp, objv[2]); sl@0: if (command == (Tcl_Command) NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "invalid command name \"", Tcl_GetString(objv[2]), sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: origCommand = TclGetOriginalCommand(command); sl@0: if (origCommand == (Tcl_Command) NULL) { sl@0: /* sl@0: * The specified command isn't an imported command. Return the sl@0: * command's name qualified by the full name of the namespace it sl@0: * was defined in. sl@0: */ sl@0: sl@0: Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp)); sl@0: } else { sl@0: Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp)); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceParentCmd -- sl@0: * sl@0: * Invoked to implement the "namespace parent" command that returns the sl@0: * fully-qualified name of the parent namespace for a specified sl@0: * namespace. Handles the following syntax: sl@0: * sl@0: * namespace parent ?name? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceParentCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Namespace *nsPtr; sl@0: int result; sl@0: sl@0: if (objc == 2) { sl@0: nsPtr = Tcl_GetCurrentNamespace(interp); sl@0: } else if (objc == 3) { sl@0: result = GetNamespaceFromObj(interp, objv[2], &nsPtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (nsPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown namespace \"", Tcl_GetString(objv[2]), sl@0: "\" in namespace parent command", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?name?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Report the parent of the specified namespace. sl@0: */ sl@0: sl@0: if (nsPtr->parentPtr != NULL) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), sl@0: nsPtr->parentPtr->fullName, -1); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceQualifiersCmd -- sl@0: * sl@0: * Invoked to implement the "namespace qualifiers" command that returns sl@0: * any leading namespace qualifiers in a string. These qualifiers are sl@0: * namespace names separated by "::"s. For example, for "::foo::p" this sl@0: * command returns "::foo", and for "::" it returns "". This command sl@0: * is the complement of the "namespace tail" command. Note that this sl@0: * command does not check whether the "namespace" names are, in fact, sl@0: * the names of currently defined namespaces. Handles the following sl@0: * syntax: sl@0: * sl@0: * namespace qualifiers string sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceQualifiersCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register char *name, *p; sl@0: int length; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Find the end of the string, then work backward and find sl@0: * the start of the last "::" qualifier. sl@0: */ sl@0: sl@0: name = Tcl_GetString(objv[2]); sl@0: for (p = name; *p != '\0'; p++) { sl@0: /* empty body */ sl@0: } sl@0: while (--p >= name) { sl@0: if ((*p == ':') && (p > name) && (*(p-1) == ':')) { sl@0: p -= 2; /* back up over the :: */ sl@0: while ((p >= name) && (*p == ':')) { sl@0: p--; /* back up over the preceeding : */ sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: sl@0: if (p >= name) { sl@0: length = p-name+1; sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceTailCmd -- sl@0: * sl@0: * Invoked to implement the "namespace tail" command that returns the sl@0: * trailing name at the end of a string with "::" namespace sl@0: * qualifiers. These qualifiers are namespace names separated by sl@0: * "::"s. For example, for "::foo::p" this command returns "p", and for sl@0: * "::" it returns "". This command is the complement of the "namespace sl@0: * qualifiers" command. Note that this command does not check whether sl@0: * the "namespace" names are, in fact, the names of currently defined sl@0: * namespaces. Handles the following syntax: sl@0: * sl@0: * namespace tail string sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceTailCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register char *name, *p; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Find the end of the string, then work backward and find the sl@0: * last "::" qualifier. sl@0: */ sl@0: sl@0: name = Tcl_GetString(objv[2]); sl@0: for (p = name; *p != '\0'; p++) { sl@0: /* empty body */ sl@0: } sl@0: while (--p > name) { sl@0: if ((*p == ':') && (*(p-1) == ':')) { sl@0: p++; /* just after the last "::" */ sl@0: break; sl@0: } sl@0: } sl@0: sl@0: if (p >= name) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NamespaceWhichCmd -- sl@0: * sl@0: * Invoked to implement the "namespace which" command that returns the sl@0: * fully-qualified name of a command or variable. If the specified sl@0: * command or variable does not exist, it returns "". Handles the sl@0: * following syntax: sl@0: * sl@0: * namespace which ?-command? ?-variable? name sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If anything sl@0: * goes wrong, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NamespaceWhichCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register char *arg; sl@0: Tcl_Command cmd; sl@0: Tcl_Var variable; sl@0: int argIndex, lookup; sl@0: sl@0: if (objc < 3) { sl@0: badArgs: sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "?-command? ?-variable? name"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Look for a flag controlling the lookup. sl@0: */ sl@0: sl@0: argIndex = 2; sl@0: lookup = 0; /* assume command lookup by default */ sl@0: arg = Tcl_GetString(objv[2]); sl@0: if (*arg == '-') { sl@0: if (strncmp(arg, "-command", 8) == 0) { sl@0: lookup = 0; sl@0: } else if (strncmp(arg, "-variable", 9) == 0) { sl@0: lookup = 1; sl@0: } else { sl@0: goto badArgs; sl@0: } sl@0: argIndex = 3; sl@0: } sl@0: if (objc != (argIndex + 1)) { sl@0: goto badArgs; sl@0: } sl@0: sl@0: switch (lookup) { sl@0: case 0: /* -command */ sl@0: cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]); sl@0: if (cmd == (Tcl_Command) NULL) { sl@0: return TCL_OK; /* cmd not found, just return (no error) */ sl@0: } sl@0: Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp)); sl@0: break; sl@0: sl@0: case 1: /* -variable */ sl@0: arg = Tcl_GetString(objv[argIndex]); sl@0: variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, sl@0: /*flags*/ 0); sl@0: if (variable != (Tcl_Var) NULL) { sl@0: Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); sl@0: } sl@0: break; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FreeNsNameInternalRep -- sl@0: * sl@0: * Frees the resources associated with a nsName object's internal sl@0: * representation. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Decrements the ref count of any Namespace structure pointed sl@0: * to by the nsName's internal representation. If there are no more sl@0: * references to the namespace, it's structure will be freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: FreeNsNameInternalRep(objPtr) sl@0: register Tcl_Obj *objPtr; /* nsName object with internal sl@0: * representation to free */ sl@0: { sl@0: register ResolvedNsName *resNamePtr = sl@0: (ResolvedNsName *) objPtr->internalRep.otherValuePtr; sl@0: Namespace *nsPtr; sl@0: sl@0: /* sl@0: * Decrement the reference count of the namespace. If there are no sl@0: * more references, free it up. sl@0: */ sl@0: sl@0: if (resNamePtr != NULL) { sl@0: resNamePtr->refCount--; sl@0: if (resNamePtr->refCount == 0) { sl@0: sl@0: /* sl@0: * Decrement the reference count for the cached namespace. If sl@0: * the namespace is dead, and there are no more references to sl@0: * it, free it. sl@0: */ sl@0: sl@0: nsPtr = resNamePtr->nsPtr; sl@0: nsPtr->refCount--; sl@0: if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { sl@0: NamespaceFree(nsPtr); sl@0: } sl@0: ckfree((char *) resNamePtr); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DupNsNameInternalRep -- sl@0: * sl@0: * Initializes the internal representation of a nsName object to a copy sl@0: * of the internal representation of another nsName object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * copyPtr's internal rep is set to refer to the same namespace sl@0: * referenced by srcPtr's internal rep. Increments the ref count of sl@0: * the ResolvedNsName structure used to hold the namespace reference. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DupNsNameInternalRep(srcPtr, copyPtr) sl@0: Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ sl@0: register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ sl@0: { sl@0: register ResolvedNsName *resNamePtr = sl@0: (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; sl@0: sl@0: copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; sl@0: if (resNamePtr != NULL) { sl@0: resNamePtr->refCount++; sl@0: } sl@0: copyPtr->typePtr = &tclNsNameType; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetNsNameFromAny -- sl@0: * sl@0: * Attempt to generate a nsName internal representation for a sl@0: * Tcl object. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the value could be converted to a proper sl@0: * namespace reference. Otherwise, it returns TCL_ERROR, along sl@0: * with an error message in the interpreter's result object. sl@0: * sl@0: * Side effects: sl@0: * If successful, the object is made a nsName object. Its internal rep sl@0: * is set to point to a ResolvedNsName, which contains a cached pointer sl@0: * to the Namespace. Reference counts are kept on both the sl@0: * ResolvedNsName and the Namespace, so we can keep track of their sl@0: * usage and free them when appropriate. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetNsNameFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Points to the namespace in which to sl@0: * resolve name. Also used for error sl@0: * reporting if not NULL. */ sl@0: register Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: register Tcl_ObjType *oldTypePtr = objPtr->typePtr; sl@0: char *name; sl@0: CONST char *dummy; sl@0: Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; sl@0: register ResolvedNsName *resNamePtr; sl@0: sl@0: /* sl@0: * Get the string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: name = objPtr->bytes; sl@0: if (name == NULL) { sl@0: name = Tcl_GetString(objPtr); sl@0: } sl@0: sl@0: /* sl@0: * Look for the namespace "name" in the current namespace. If there is sl@0: * an error parsing the (possibly qualified) name, return an error. sl@0: * If the namespace isn't found, we convert the object to an nsName sl@0: * object with a NULL ResolvedNsName* internal rep. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, sl@0: FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); sl@0: sl@0: /* sl@0: * If we found a namespace, then create a new ResolvedNsName structure sl@0: * that holds a reference to it. sl@0: */ sl@0: sl@0: if (nsPtr != NULL) { sl@0: Namespace *currNsPtr = sl@0: (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: sl@0: nsPtr->refCount++; sl@0: resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); sl@0: resNamePtr->nsPtr = nsPtr; sl@0: resNamePtr->nsId = nsPtr->nsId; sl@0: resNamePtr->refNsPtr = currNsPtr; sl@0: resNamePtr->refCount = 1; sl@0: } else { sl@0: resNamePtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Free the old internalRep before setting the new one. sl@0: * We do this as late as possible to allow the conversion code sl@0: * (in particular, Tcl_GetStringFromObj) to use that old internalRep. sl@0: */ sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; sl@0: objPtr->typePtr = &tclNsNameType; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfNsName -- sl@0: * sl@0: * Updates the string representation for a nsName object. sl@0: * Note: This procedure does not free an existing old string rep sl@0: * so storage will be lost if this has not already been done. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's string is set to a copy of the fully qualified sl@0: * namespace name. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfNsName(objPtr) sl@0: register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ sl@0: { sl@0: ResolvedNsName *resNamePtr = sl@0: (ResolvedNsName *) objPtr->internalRep.otherValuePtr; sl@0: register Namespace *nsPtr; sl@0: char *name = ""; sl@0: int length; sl@0: sl@0: if ((resNamePtr != NULL) sl@0: && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { sl@0: nsPtr = resNamePtr->nsPtr; sl@0: if (nsPtr->flags & NS_DEAD) { sl@0: nsPtr = NULL; sl@0: } sl@0: if (nsPtr != NULL) { sl@0: name = nsPtr->fullName; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * The following sets the string rep to an empty string on the heap sl@0: * if the internal rep is NULL. sl@0: */ sl@0: sl@0: length = strlen(name); sl@0: if (length == 0) { sl@0: objPtr->bytes = tclEmptyStringRep; sl@0: } else { sl@0: objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); sl@0: memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); sl@0: objPtr->bytes[length] = '\0'; sl@0: } sl@0: objPtr->length = length; sl@0: }