/* * tclNamesp.c -- * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain * special-purpose commands and variables for packages. Also includes * the TIP#112 ensemble machinery. * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2002-2005 Donal K. Fellows. * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclNamesp.c,v 1.76 2005/05/30 00:04:48 dkf Exp $ */ #include "tclInt.h" /* * Initial size of stack allocated space for tail list - used when resetting * shadowed command references in the functin: TclResetShadowedCmdRefs. */ #define NUM_TRAIL_ELEMS 5 /* * Thread-local storage used to avoid having a global lock on data * that is not limited to a single interpreter. */ typedef struct ThreadSpecificData { long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to * distinguish objects which can be passed * around between interps in the same thread, * but does not need to be global because * object internal reps are always per-thread * anyway. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * This structure contains a cached pointer to a namespace that is the * result of resolving the namespace's name in some other namespace. It is * the internal representation for a nsName object. It contains the * pointer along with some information that is used to check the cached * pointer's validity. */ typedef struct ResolvedNsName { Namespace *nsPtr; /* A cached namespace pointer. */ long nsId; /* nsPtr's unique namespace id. Used to * verify that nsPtr is still valid * (e.g., it's possible that the namespace * was deleted and a new one created at * the same address). */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that * contains the referenced namespace). */ int refCount; /* Reference count: 1 for each nsName * object that has a pointer to this * ResolvedNsName structure as its internal * rep. This structure can be freed when * refCount becomes zero. */ } ResolvedNsName; /* * The client data for an ensemble command. This consists of the * table of commands that are actually exported by the namespace, and * an epoch counter that, combined with the exportLookupEpoch field of * the namespace structure, defines whether the table contains valid * data or will need to be recomputed next time the ensemble command * is called. */ typedef struct EnsembleConfig { Namespace *nsPtr; /* The namspace backing this ensemble up. */ Tcl_Command token; /* The token for the command that provides * ensemble support for the namespace, or * NULL if the command has been deleted (or * never existed; the global namespace never * has an ensemble command.) */ int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same * number of entries as there are entries in * the subcommandTable hash. */ Tcl_HashTable subcommandTable; /* Hash table of ensemble subcommand names, * which are its keys so this also provides * the storage management for those subcommand * names. The contents of the entry values are * object version the prefix lists to use when * substituting for the command/subcommand to * build the ensemble implementation command. * Has to be stored here as well as in * subcommandDict because that field is NULL * when we are deriving the ensemble from the * namespace exports list. * FUTURE WORK: use object hash table here. */ struct EnsembleConfig *next;/* The next ensemble in the linked list of * ensembles associated with a namespace. If * this field points to this ensemble, the * structure has already been unlinked from * all lists, and cannot be found by scanning * the list from the namespace's ensemble * field. */ int flags; /* ORed combo of ENS_DEAD and * TCL_ENSEMBLE_PREFIX. */ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from * subcommands to their implementing command * prefixes, or NULL if we are to build the * map automatically from the namespace * exports. */ Tcl_Obj *subcmdList; /* List of commands that this ensemble * actually provides, and whose implementation * will be built using the subcommandDict (if * present and defined) and by simple mapping * to the namespace otherwise. If NULL, * indicates that we are using the (dynamic) * list of currently exported commands. */ Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when * no match is found (according to the rule * defined by flag bit TCL_ENSEMBLE_PREFIX) or * NULL to use the default error-generating * behaviour. The script execution gets all * the arguments to the ensemble command * (including objv[0]) and will have the * results passed directly back to the caller * (including the error code) unless the code * is TCL_CONTINUE in which case the subcommand * will be reparsed by the ensemble core, * presumably because the ensemble itself has * been updated. */ } EnsembleConfig; #define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead * and on its way out. */ /* * The data cached in a subcommand's Tcl_Obj rep. This structure is * not shared between Tcl_Objs referring to the same subcommand, even * where one is a duplicate of another. */ typedef struct EnsembleCmdRep { Namespace *nsPtr; /* The namespace backing the ensemble which * this is a subcommand of. */ int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Tcl_Command token; /* Reference to the comamnd for which this * structure is a cache of the resolution. */ char *fullSubcmdName; /* The full (local) name of the subcommand, * allocated with ckalloc(). */ Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the * command that implements this ensemble * subcommand. */ } EnsembleCmdRep; /* * Declarations for procedures local to this file: */ static void DeleteImportedCmd _ANSI_ARGS_((ClientData clientData)); static int DoImport _ANSI_ARGS_((Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, CONST char *cmdName, CONST char *pattern, Namespace *importNsPtr, int allowOverwrite)); static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static char * ErrorCodeRead _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static char * ErrorInfoRead _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static char * EstablishErrorCodeTraces _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static char * EstablishErrorInfoTraces _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static void FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int InvokeImportedCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceChildrenCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceCodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceCurrentCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceDeleteCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceEnsembleCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceEvalCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceExistsCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceExportCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceForgetCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); static int NamespaceImportCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceInscopeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceOriginCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceParentCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespacePathCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceQualifiersCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceTailCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int NamespaceWhichCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int SetNsNameFromAny _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); static int NsEnsembleImplementationCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void BuildEnsembleConfig _ANSI_ARGS_(( EnsembleConfig *ensemblePtr)); static int NsEnsembleStringOrder _ANSI_ARGS_((CONST VOID *strPtr1, CONST VOID *strPtr2)); static void DeleteEnsembleConfig _ANSI_ARGS_(( ClientData clientData)); static void MakeCachedEnsembleCommand _ANSI_ARGS_(( Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, CONST char *subcmdName, Tcl_Obj *prefixObjPtr)); static void FreeEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static void StringOfEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UnlinkNsPath _ANSI_ARGS_((Namespace *nsPtr)); static void SetNsPath _ANSI_ARGS_((Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[])); /* * This structure defines a Tcl object type that contains a * namespace reference. It is used in commands that take the * name of a namespace as an argument. The namespace reference * is resolved, and the result in cached in the object. */ Tcl_ObjType tclNsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ UpdateStringOfNsName, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; /* * This structure defines a Tcl object type that contains a reference * to an ensemble subcommand (e.g. the "length" in [string length ab]) * It is used to cache the mapping between the subcommand itself and * the real command that implements it. */ Tcl_ObjType tclEnsembleCmdType = { "ensembleCommand", /* the type's name */ FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ StringOfEnsembleCmdRep, /* updateStringProc */ NULL /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * TclInitNamespaceSubsystem -- * * This procedure is called to initialize all the structures that * are used by namespaces on a per-process basis. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclInitNamespaceSubsystem() { /* * Does nothing for now. */ } /* *---------------------------------------------------------------------- * * Tcl_GetCurrentNamespace -- * * Returns a pointer to an interpreter's currently active namespace. * * Results: * Returns a pointer to the interpreter's current namespace. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace(interp) register Tcl_Interp *interp; /* Interpreter whose current namespace is * being queried. */ { register Interp *iPtr = (Interp *) interp; register Namespace *nsPtr; if (iPtr->varFramePtr != NULL) { nsPtr = iPtr->varFramePtr->nsPtr; } else { nsPtr = iPtr->globalNsPtr; } return (Tcl_Namespace *) nsPtr; } /* *---------------------------------------------------------------------- * * Tcl_GetGlobalNamespace -- * * Returns a pointer to an interpreter's global :: namespace. * * Results: * Returns a pointer to the specified interpreter's global namespace. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace(interp) register Tcl_Interp *interp; /* Interpreter whose global namespace * should be returned. */ { register Interp *iPtr = (Interp *) interp; return (Tcl_Namespace *) iPtr->globalNsPtr; } /* *---------------------------------------------------------------------- * * Tcl_PushCallFrame -- * * Pushes a new call frame onto the interpreter's Tcl call stack. * Called when executing a Tcl procedure or a "namespace eval" or * "namespace inscope" command. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result object) if something goes wrong. * * Side effects: * Modifies the interpreter's Tcl call stack. * *---------------------------------------------------------------------- */ int Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) Tcl_Interp *interp; /* Interpreter in which the new call frame * is to be pushed. */ Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to * push. Storage for this has already been * allocated by the caller; typically this * is the address of a CallFrame structure * allocated on the caller's C stack. The * call frame will be initialized by this * procedure. The caller can pop the frame * later with Tcl_PopCallFrame, and it is * responsible for freeing the frame's * storage. */ Tcl_Namespace *namespacePtr; /* Points to the namespace in which the * frame will execute. If NULL, the * interpreter's current namespace will * be used. */ int isProcCallFrame; /* If nonzero, the frame represents a * called Tcl procedure and may have local * vars. Vars will ordinarily be looked up * in the frame. If new variables are * created, they will be created in the * frame. If 0, the frame is for a * "namespace eval" or "namespace inscope" * command and var references are treated * as references to namespace variables. */ { Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; if (nsPtr->flags & NS_DEAD) { Tcl_Panic("Trying to push call frame for dead namespace"); /*NOTREACHED*/ } } nsPtr->activationCount++; framePtr->nsPtr = nsPtr; framePtr->isProcCallFrame = isProcCallFrame; framePtr->objc = 0; framePtr->objv = NULL; framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { framePtr->level = (iPtr->varFramePtr->level + 1); } else { framePtr->level = 1; } framePtr->procPtr = NULL; /* no called procedure */ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; /* * Push the new call frame onto the interpreter's stack of procedure * call frames making it the current frame. */ iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_PopCallFrame -- * * Removes a call frame from the Tcl call stack for the interpreter. * Called to remove a frame previously pushed by Tcl_PushCallFrame. * * Results: * None. * * Side effects: * Modifies the call stack of the interpreter. Resets various fields of * the popped call frame. If a namespace has been deleted and * has no more activations on the call stack, the namespace is * destroyed. * *---------------------------------------------------------------------- */ void Tcl_PopCallFrame(interp) Tcl_Interp* interp; /* Interpreter with call frame to pop. */ { register Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* * It's important to remove the call frame from the interpreter's stack * of call frames before deleting local variables, so that traces * invoked by the variable deletion don't see the partially-deleted * frame. */ iPtr->framePtr = framePtr->callerPtr; iPtr->varFramePtr = framePtr->callerVarPtr; if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree((char *) framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); } /* * Decrement the namespace's count of active call frames. If the * namespace is "dying" and there are no more active call frames, * call Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; } /* *---------------------------------------------------------------------- * * TclPushStackFrame -- * * Allocates a new call frame in the interpreter's execution stack, then * pushes it onto the interpreter's Tcl call stack. * Called when executing a Tcl procedure or a "namespace eval" or * "namespace inscope" command. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result object) if something goes wrong. * * Side effects: * Modifies the interpreter's Tcl call stack. * *---------------------------------------------------------------------- */ int TclPushStackFrame(interp, framePtrPtr, namespacePtr, isProcCallFrame) Tcl_Interp *interp; /* Interpreter in which the new call frame * is to be pushed. */ Tcl_CallFrame **framePtrPtr; /* Place to store a pointer to the stack * allocated call frame.*/ Tcl_Namespace *namespacePtr; /* Points to the namespace in which the * frame will execute. If NULL, the * interpreter's current namespace will * be used. */ int isProcCallFrame; /* If nonzero, the frame represents a * called Tcl procedure and may have local * vars. Vars will ordinarily be looked up * in the frame. If new variables are * created, they will be created in the * frame. If 0, the frame is for a * "namespace eval" or "namespace inscope" * command and var references are treated * as references to namespace variables. */ { *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } void TclPopStackFrame(interp) Tcl_Interp* interp; /* Interpreter with call frame to pop. */ { Tcl_PopCallFrame(interp); TclStackFree(interp); } /* *---------------------------------------------------------------------- * * EstablishErrorCodeTraces -- * * Creates traces on the ::errorCode variable to keep its value * consistent with the expectations of legacy code. * * Results: * None. * * Side effects: * Read and unset traces are established on ::errorCode. * *---------------------------------------------------------------------- */ static char * EstablishErrorCodeTraces(clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; CONST char *name1; CONST char *name2; int flags; { Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, ErrorCodeRead, (ClientData) NULL); Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, EstablishErrorCodeTraces, (ClientData) NULL); return NULL; } /* *---------------------------------------------------------------------- * * ErrorCodeRead -- * * Called when the ::errorCode variable is read. Copies the * current value of the interp's errorCode field into ::errorCode. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * ErrorCodeRead(clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; CONST char *name1; CONST char *name2; int flags; { Interp *iPtr = (Interp *)interp; if (flags & TCL_INTERP_DESTROYED) return NULL; if (iPtr->errorCode == NULL) return NULL; Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); return NULL; } /* *---------------------------------------------------------------------- * * EstablishErrorInfoTraces -- * * Creates traces on the ::errorInfo variable to keep its value * consistent with the expectations of legacy code. * * Results: * None. * * Side effects: * Read and unset traces are established on ::errorInfo. * *---------------------------------------------------------------------- */ static char * EstablishErrorInfoTraces(clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; CONST char *name1; CONST char *name2; int flags; { Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, ErrorInfoRead, (ClientData) NULL); Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, EstablishErrorInfoTraces, (ClientData) NULL); return NULL; } /* *---------------------------------------------------------------------- * * ErrorInfoRead -- * * Called when the ::errorInfo variable is read. Copies the * current value of the interp's errorInfo field into ::errorInfo. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * ErrorInfoRead(clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; CONST char *name1; CONST char *name2; int flags; { Interp *iPtr = (Interp *)interp; if (flags & TCL_INTERP_DESTROYED) return NULL; if (iPtr->errorInfo == NULL) return NULL; Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_CreateNamespace -- * * Creates a new namespace with the given name. If there is no * active namespace (i.e., the interpreter is being initialized), * the global :: namespace is created and returned. * * Results: * Returns a pointer to the new namespace if successful. If the * namespace already exists or if another error occurs, this routine * returns NULL, along with an error message in the interpreter's * result object. * * Side effects: * If the name contains "::" qualifiers and a parent namespace does * not already exist, it is automatically created. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_CreateNamespace(interp, name, clientData, deleteProc) Tcl_Interp *interp; /* Interpreter in which a new namespace * is being created. Also used for * error reporting. */ CONST char *name; /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ ClientData clientData; /* One-word value to store with * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure called to delete client * data when the namespace is deleted. * NULL if no procedure should be * called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; CONST char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; int newEntry; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * If there is no active namespace, the interpreter is being * initialized. */ if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { /* * Treat this namespace as the global namespace, and avoid * looking for a parent. */ parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": ", "only global namespace can have empty name", NULL); return NULL; } else { /* * Find the parent for the new namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing * "::"s after the namespace's name which we ignore. The new * namespace was already (recursively) created and is pointed to * by parentPtr. */ if (*simpleName == '\0') { return (Tcl_Namespace *) parentPtr; } /* * Check for a bad namespace name and make sure that the name * does not already exist in the parent namespace. */ if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", (char *) NULL); return NULL; } } /* * Create the new namespace and root it in its parent. Increment the * count of namespaces created. */ nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); nsPtr->fullName = NULL; /* set below */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; nsPtr->parentPtr = parentPtr; Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); nsPtr->nsId = ++(tsdPtr->numNsCreated); nsPtr->interp = interp; nsPtr->flags = 0; nsPtr->activationCount = 0; nsPtr->refCount = 0; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; nsPtr->cmdRefEpoch = 0; nsPtr->resolverEpoch = 0; nsPtr->cmdResProc = NULL; nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; nsPtr->exportLookupEpoch = 0; nsPtr->ensembles = NULL; nsPtr->commandPathLength = 0; nsPtr->commandPathArray = NULL; nsPtr->commandPathSourceList = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, &newEntry); Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } else { /* * In the global namespace create traces to maintain the * ::errorInfo and ::errorCode variables. */ iPtr->globalNsPtr = nsPtr; EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0); } /* * Build the fully qualified name for this namespace. */ Tcl_DStringInit(&buffer1); Tcl_DStringInit(&buffer2); for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { if (ancestorPtr != globalNsPtr) { Tcl_DStringAppend(&buffer1, "::", 2); Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); } Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); Tcl_DStringSetLength(&buffer2, 0); Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); Tcl_DStringSetLength(&buffer1, 0); } name = Tcl_DStringValue(&buffer2); nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); strcpy(nsPtr->fullName, name); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); /* * Return a pointer to the new namespace. */ return (Tcl_Namespace *) nsPtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteNamespace -- * * Deletes a namespace and all of the commands, variables, and other * namespaces within it. * * Results: * None. * * Side effects: * When a namespace is deleted, it is automatically removed as a * child of its parent namespace. Also, all its commands, variables * and child namespaces are deleted. * *---------------------------------------------------------------------- */ void Tcl_DeleteNamespace(namespacePtr) Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; /* * If the namespace has associated ensemble commands, delete them * first. This leaves the actual contents of the namespace alone * (unless they are linked ensemble commands, of course.) Note * that this code is actually reentrant so command delete traces * won't purturb things badly. */ while (nsPtr->ensembles != NULL) { /* * Splice out and link to indicate that we've already been * killed. */ EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; ensemblePtr->next = ensemblePtr; Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); } /* * If the namespace is on the call frame stack, it is marked as "dying" * (NS_DYING is OR'd into its flags): the namespace can't be looked up * by name but its commands and variables are still usable by those * active call frames. When all active call frames referring to the * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will * call this procedure again to delete everything in the namespace. * If no nsName objects refer to the namespace (i.e., if its refCount * is zero), its commands and variables are deleted and the storage for * its namespace structure is freed. Otherwise, if its refCount is * nonzero, the namespace's commands and variables are deleted but the * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's * flags to allow the namespace resolution code to recognize that the * namespace is "deleted". The structure's storage is freed by * FreeNsNameInternalRep when its refCount reaches 0. */ if (nsPtr->activationCount > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; } else { /* * Delete the namespace and everything in it. If this is the global * namespace, then clear it but don't free its storage unless the * interpreter is being torn down. */ TclTeardownNamespace(nsPtr); if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { /* * If this is the global namespace, then it may have residual * "errorInfo" and "errorCode" variables for errors that * occurred while it was being torn down. Try to clear the * variable list one last time. */ TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable); Tcl_DeleteHashTable(&nsPtr->childTable); Tcl_DeleteHashTable(&nsPtr->cmdTable); /* * If the reference count is 0, then discard the namespace. * Otherwise, mark it as "dead" so that it can't be used. */ if (nsPtr->refCount == 0) { NamespaceFree(nsPtr); } else { nsPtr->flags |= NS_DEAD; } } else { /* Restore the ::errorInfo and ::errorCode traces */ EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); } } } /* *---------------------------------------------------------------------- * * TclTeardownNamespace -- * * Used internally to dismantle and unlink a namespace when it is * deleted. Divorces the namespace from its parent, and deletes all * commands, variables, and child namespaces. * * This is kept separate from Tcl_DeleteNamespace so that the global * namespace can be handled specially. * * Results: * None. * * Side effects: * Removes this namespace from its parent's child namespace hashtable. * Deletes all commands, variables and namespaces in this namespace. * *---------------------------------------------------------------------- */ void TclTeardownNamespace(nsPtr) register Namespace *nsPtr; /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Namespace *childNsPtr; Tcl_Command cmd; int i; /* * Start by destroying the namespace's variable table, * since variables might trigger traces. * Variable table should be cleared but not freed! * TclDeleteVars frees it, so we reinitialize it afterwards. */ TclDeleteVars(iPtr, &nsPtr->varTable); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); /* * Remove the namespace from its parent's child hashtable. */ if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; /* * Delete the namespace path if one is installed. */ if (nsPtr->commandPathLength != 0) { UnlinkNsPath(nsPtr); nsPtr->commandPathLength = 0; } if (nsPtr->commandPathSourceList != NULL) { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; do { nsPathPtr->nsPtr = NULL; nsPathPtr = nsPathPtr->nextPtr; } while (nsPathPtr != NULL); } /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce * itself from its parent. You can't traverse a hash table * properly if its elements are being deleted. We use only * the Tcl_FirstHashEntry function to be safe. * * Don't optimize to Tcl_NextHashEntry() because of traces. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); Tcl_DeleteNamespace(childNsPtr); } /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the * command table. * * Don't optimize to Tcl_NextHashEntry() because of traces. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); /* * Free the namespace's export pattern array. */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } /* * Free any client data associated with the namespace. */ if (nsPtr->deleteProc != NULL) { (*nsPtr->deleteProc)(nsPtr->clientData); } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; /* * Reset the namespace's id field to ensure that this namespace won't * be interpreted as valid by, e.g., the cache validation code for * cached command references in Tcl_GetCommandFromObj. */ nsPtr->nsId = 0; } /* *---------------------------------------------------------------------- * * NamespaceFree -- * * Called after a namespace has been deleted, when its * reference count reaches 0. Frees the data structure * representing the namespace. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void NamespaceFree(nsPtr) register Namespace *nsPtr; /* Points to the namespace to free. */ { /* * Most of the namespace's contents are freed when the namespace is * deleted by Tcl_DeleteNamespace. All that remains is to free its names * (for error messages), and the structure itself. */ ckfree(nsPtr->name); ckfree(nsPtr->fullName); ckfree((char *) nsPtr); } /* *---------------------------------------------------------------------- * * Tcl_Export -- * * Makes all the commands matching a pattern available to later be * imported from the namespace specified by namespacePtr (or the * current namespace if namespacePtr is NULL). The specified pattern is * appended onto the namespace's export pattern list, which is * optionally cleared beforehand. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * * Side effects: * Appends the export pattern onto the namespace's export list. * Optionally reset the namespace's export pattern list. * *---------------------------------------------------------------------- */ int Tcl_Export(interp, namespacePtr, pattern, resetListFirst) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr; /* Points to the namespace from which * commands are to be exported. NULL for * the current namespace. */ CONST char *pattern; /* String pattern indicating which commands * to export. This pattern may not include * any namespace qualifiers; only commands * in the specified namespace may be * exported. */ int resetListFirst; /* If nonzero, resets the namespace's * export list before appending. */ { #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); CONST char *simplePattern; char *patternCpy; int neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) currNsPtr; } else { nsPtr = (Namespace *) namespacePtr; } /* * If resetListFirst is true (nonzero), clear the namespace's export * pattern list. */ if (resetListFirst) { if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } } /* * Check that the pattern doesn't have namespace qualifiers. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendResult(interp, "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", (char *) NULL); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { /* * The pattern already exists in the list */ return TCL_OK; } } } /* * Make sure there is room in the namespace's pattern array for the * new pattern. */ neededElems = nsPtr->numExportPatterns + 1; if (nsPtr->exportArrayPtr == NULL) { nsPtr->exportArrayPtr = (char **) ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; } else if (neededElems > nsPtr->maxExportPatterns) { int numNewElems = 2 * nsPtr->maxExportPatterns; size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); size_t newBytes = numNewElems * sizeof(char *); char **newPtr = (char **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes); ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = (char **) newPtr; nsPtr->maxExportPatterns = numNewElems; } /* * Add the pattern to the namespace's array of export patterns. */ len = strlen(pattern); patternCpy = (char *) ckalloc((unsigned) (len + 1)); strcpy(patternCpy, pattern); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; /* * The list of commands actually exported from the namespace might * have changed (probably will have!) However, we do not need to * recompute this just yet; next time we need the info will be * soon enough. */ TclInvalidateNsCmdLookup(nsPtr); return TCL_OK; #undef INIT_EXPORT_PATTERNS } /* *---------------------------------------------------------------------- * * Tcl_AppendExportList -- * * Appends onto the argument object the list of export patterns for the * specified namespace. * * Results: * The return value is normally TCL_OK; in this case the object * referenced by objPtr has each export pattern appended to it. If an * error occurs, TCL_ERROR is returned and the interpreter's result * holds an error message. * * Side effects: * If necessary, the object referenced by objPtr is converted into * a list object. * *---------------------------------------------------------------------- */ int Tcl_AppendExportList(interp, namespacePtr, objPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ Tcl_Namespace *namespacePtr; /* Points to the namespace whose export * pattern list is appended onto objPtr. * NULL for the current namespace. */ Tcl_Obj *objPtr; /* Points to the Tcl object onto which the * export pattern list is appended. */ { Namespace *nsPtr; int i, result; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } /* * Append the export pattern list onto objPtr. */ for (i = 0; i < nsPtr->numExportPatterns; i++) { result = Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); if (result != TCL_OK) { return result; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_Import -- * * Imports all of the commands matching a pattern into the namespace * specified by namespacePtr (or the current namespace if contextNsPtr * is NULL). This is done by creating a new command (the "imported * command") that points to the real command in its original namespace. * * If matching commands are on the autoload path but haven't been * loaded yet, this command forces them to be loaded, then creates * the links to them. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * * Side effects: * Creates new commands in the importing namespace. These indirect * calls back to the real command and are deleted if the real commands * are deleted. * *---------------------------------------------------------------------- */ int Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr; /* Points to the namespace into which the * commands are to be imported. NULL for * the current namespace. */ CONST char *pattern; /* String pattern indicating which commands * to import. This pattern should be * qualified by the name of the namespace * from which to import the command(s). */ int allowOverwrite; /* If nonzero, allow existing commands to * be overwritten by imported commands. * If 0, return an error if an imported * cmd conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; CONST char *simplePattern; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } /* * First, invoke the "auto_import" command with the pattern * being imported. This command is part of the Tcl library. * It looks for imported commands in autoloaded libraries and * loads them in. That way, they will be found when we try * to create links below. * * Note that we don't just call Tcl_EvalObjv() directly because we * do not want absence of the command to be a failure case. */ if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { Tcl_Obj *objv[2]; int result; objv[0] = Tcl_NewStringObj("auto_import", -1); objv[1] = Tcl_NewStringObj(pattern, -1); Tcl_IncrRefCount(objv[0]); Tcl_IncrRefCount(objv[1]); result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(objv[0]); Tcl_DecrRefCount(objv[1]); if (result != TCL_OK) { return TCL_ERROR; } Tcl_ResetResult(interp); } /* * From the pattern, find the namespace from which we are importing * and get the simple pattern (no namespace qualifiers or ::'s) at * the end. */ if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace in import pattern \"", pattern, "\"", (char *) NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { Tcl_AppendResult(interp, "no namespace specified in import pattern \"", pattern, "\"", (char *) NULL); } else { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" tries to import from namespace \"", importNsPtr->name, "\" into itself", (char *) NULL); } return TCL_ERROR; } /* * Scan through the command table in the source namespace and look for * exported commands that match the string pattern. Create an "imported * command" in the current namespace for each imported command; these * commands redirect their invocations to the "real" command. */ if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) { hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern); if (hPtr == NULL) { return TCL_OK; } return DoImport(interp, nsPtr, hPtr, simplePattern, pattern, importNsPtr, allowOverwrite); } for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern) && (TCL_ERROR == DoImport( interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite))) { return TCL_ERROR; } } return TCL_OK; } static int DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) Tcl_Interp *interp; Namespace *nsPtr; Tcl_HashEntry *hPtr; CONST char *cmdName; CONST char *pattern; Namespace *importNsPtr; int allowOverwrite; { int i = 0, exported = 0; Tcl_HashEntry *found; /* * The command cmdName in the source namespace matches the * pattern. Check whether it was exported. If it wasn't, * we ignore it. */ while (!exported && (i < importNsPtr->numExportPatterns)) { exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); } if (!exported) { return TCL_OK; } /* * Unless there is a name clash, create an imported command * in the current namespace that refers to cmdPtr. */ found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); if ((found == NULL) || allowOverwrite) { /* * Create the imported command and its client data. * To create the new command in the current namespace, * generate a fully qualified name for it. */ Tcl_DString ds; Tcl_Command importedCmd; ImportedCmdData *dataPtr = (ImportedCmdData *) NULL; Command *cmdPtr = (Command *) NULL, *importedCmdPtr = (Command *) NULL; ImportRef *refPtr = (ImportRef *) NULL; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != ((Interp *) interp)->globalNsPtr) { Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); /* * Check whether creating the new imported command in the * current namespace would create a cycle of imported * command references. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { Command *overwrite = (Command *) Tcl_GetHashValue(found); Command *link = cmdPtr; while (link->deleteProc == DeleteImportedCmd) { ImportedCmdData *dataPtr; dataPtr = (ImportedCmdData *) link->objClientData; link = dataPtr->realCmdPtr; if (overwrite == link) { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" would create a loop containing ", "command \"", Tcl_DStringValue(&ds), "\"", (char *) NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } } } dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), InvokeImportedCmd, (ClientData) dataPtr, DeleteImportedCmd); importedCmdPtr = (Command *) importedCmd; importedCmdPtr->flags |= CMD_IS_IMPORTED; dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import * command and add it to the import ref list in the "real" * command. */ refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ForgetImport -- * * Deletes commands previously imported into the namespace indicated. The * by namespacePtr, or the current namespace of interp, when * namespacePtr is NULL. The pattern controls which imported commands * are deleted. A simple pattern, one without namespace separators, * matches the current command names of imported commands in the * namespace. Matching imported commands are deleted. A qualified * pattern is interpreted as deletion selection on the basis of where * the command is imported from. The original command and "first link" * command for each imported command are determined, and they are matched * against the pattern. A match leads to deletion of the imported * command. * * Results: * Returns TCL_ERROR and records an error message in the interp * result if a namespace qualified pattern refers to a namespace * that does not exist. Otherwise, returns TCL_OK. * * Side effects: * May delete commands. * *---------------------------------------------------------------------- */ int Tcl_ForgetImport(interp, namespacePtr, pattern) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr; /* Points to the namespace from which * previously imported commands should be * removed. NULL for current namespace. */ CONST char *pattern; /* String pattern indicating which imported * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } /* * Parse the pattern into its namespace-qualification (if any) * and the simple pattern. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace in namespace forget pattern \"", pattern, "\"", (char *) NULL); return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { /* * The pattern is simple. * Delete any imported commands that match it. */ if (TclMatchIsTrivial(simplePattern)) { Command *cmdPtr; hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if ((hPtr != NULL) && (cmdPtr = (Command *) Tcl_GetHashValue(hPtr)) && (cmdPtr->deleteProc == DeleteImportedCmd)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); } return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); } } return TCL_OK; } /* The pattern was namespace-qualified */ for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Tcl_CmdInfo info; Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { continue; /* Not an imported command */ } if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { /* * Original not in namespace we're matching. * Check the first link in the import chain. */ Command *cmdPtr = (Command *) token; ImportedCmdData *dataPtr = (ImportedCmdData *) cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { continue; } Tcl_GetCommandInfoFromToken(firstToken, &info); if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { continue; } origin = firstToken; } if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { Tcl_DeleteCommandFromToken(interp, token); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclGetOriginalCommand -- * * An imported command is created in an namespace when a "real" command * is imported from another namespace. If the specified command is an * imported command, this procedure returns the original command it * refers to. * * Results: * If the command was imported into a sequence of namespaces a, b,...,n * where each successive namespace just imports the command from the * previous namespace, this procedure returns the Tcl_Command token in * the first namespace, a. Otherwise, if the specified command is not * an imported command, the procedure returns NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command TclGetOriginalCommand(command) Tcl_Command command; /* The imported command for which the * original command should be returned. */ { register Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { return (Tcl_Command) NULL; } while (cmdPtr->deleteProc == DeleteImportedCmd) { dataPtr = (ImportedCmdData *) cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * InvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that * was created by Tcl_Import. Finds the "real" command (in another * namespace), and passes control to it. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int InvokeImportedCmd(clientData, interp, objc, objv) ClientData clientData; /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* The argument objects. */ { register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; register Command *realCmdPtr = dataPtr->realCmdPtr; return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, objc, objv); } /* *---------------------------------------------------------------------- * * DeleteImportedCmd -- * * Invoked by Tcl whenever an imported command is deleted. The "real" * command keeps a list of all the imported commands that refer to it, * so those imported commands can be deleted when the real command is * deleted. This procedure removes the imported command reference from * the real command's list, and frees up the memory associated with * the imported command. * * Results: * None. * * Side effects: * Removes the imported command from the real command's import list. * *---------------------------------------------------------------------- */ static void DeleteImportedCmd(clientData) ClientData clientData; /* Points to the imported command's * ImportedCmdData structure. */ { ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; register ImportRef *refPtr, *prevPtr; prevPtr = NULL; for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; refPtr = refPtr->nextPtr) { if (refPtr->importedCmdPtr == selfPtr) { /* * Remove *refPtr from real command's list of imported commands * that refer to it. */ if (prevPtr == NULL) { /* refPtr is first in list */ realCmdPtr->importRefPtr = refPtr->nextPtr; } else { prevPtr->nextPtr = refPtr->nextPtr; } ckfree((char *) refPtr); ckfree((char *) dataPtr); return; } prevPtr = refPtr; } Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); } /* *---------------------------------------------------------------------- * * TclGetNamespaceForQualName -- * * Given a qualified name specifying a command, variable, or namespace, * and a namespace in which to resolve the name, this procedure returns * a pointer to the namespace that contains the item. A qualified name * consists of the "simple" name of an item qualified by the names of * an arbitrary number of containing namespace separated by "::"s. If * the qualified name starts with "::", it is interpreted absolutely * from the global namespace. Otherwise, it is interpreted relative to * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr * is NULL, the name is interpreted relative to the current namespace. * * A relative name like "foo::bar::x" can be found starting in either * the current namespace or in the global namespace. So each search * usually follows two tracks, and two possible namespaces are * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to * NULL, then that path failed. * * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is * sought only in the global :: namespace. The alternate search * (also) starting from the global namespace is ignored and * *altNsPtrPtr is set NULL. * * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified * name is sought only in the namespace specified by cxtNsPtr. The * alternate search starting from the global namespace is ignored and * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and * the search starts from the namespace specified by cxtNsPtr. * * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace * components of the qualified name that cannot be found are * automatically created within their specified parent. This makes sure * that functions like Tcl_CreateCommand always succeed. There is no * alternate search path, so *altNsPtrPtr is set NULL. * * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as a * reference to a namespace, and the entire qualified name is * followed. If the name is relative, the namespace is looked up only * in the current namespace. A pointer to the namespace is stored in * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if * TCL_FIND_ONLY_NS is not specified, only the leading components are * treated as namespace names, and a pointer to the simple name of the * final component is stored in *simpleNamePtr. * * Results: * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible * namespaces which represent the last (containing) namespace in the * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr * to NULL, then the search along that path failed. The procedure also * stores a pointer to the simple name of the final component in * *simpleNamePtr. If the qualified name is "::" or was treated as a * namespace reference (TCL_FIND_ONLY_NS), the procedure stores a pointer * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * * If there is an error, this procedure returns TCL_ERROR. If "flags" * contains TCL_LEAVE_ERR_MSG, an error message is returned in the * interpreter's result object. Otherwise, the interpreter's result * object is left unchanged. * * *actualCxtPtrPtr is set to the actual context namespace. It is * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr * is NULL, it is set to the current namespace context. * * For backwards compatibility with the TclPro byte code loader, * this function always returns TCL_OK. * * Side effects: * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be * created. * *---------------------------------------------------------------------- */ int TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) Tcl_Interp *interp; /* Interpreter in which to find the * namespace containing qualName. */ CONST char *qualName; /* A namespace-qualified name of an * command, variable, or namespace. */ Namespace *cxtNsPtr; /* The namespace in which to start the * search for qualName's namespace. If NULL * start from the current namespace. * Ignored if TCL_GLOBAL_ONLY is set. */ int flags; /* Flags controlling the search: an OR'd * combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, * TCL_CREATE_NS_IF_UNKNOWN, and * TCL_FIND_ONLY_NS. */ Namespace **nsPtrPtr; /* Address where procedure stores a pointer * to containing namespace if qualName is * found starting from *cxtNsPtr or, if * TCL_GLOBAL_ONLY is set, if qualName is * found in the global :: namespace. NULL * is stored otherwise. */ Namespace **altNsPtrPtr; /* Address where procedure stores a pointer * to containing namespace if qualName is * found starting from the global :: * namespace. NULL is stored if qualName * isn't found starting from :: or if the * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_CREATE_NS_IF_UNKNOWN, TCL_FIND_ONLY_NS * flag is set. */ Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer * to the actual namespace from which the * search started. This is either cxtNsPtr, * the :: namespace if TCL_GLOBAL_ONLY was * specified, or the current namespace if * cxtNsPtr was NULL. */ CONST char **simpleNamePtr; /* Address where procedure stores the * simple name at end of the qualName, or * NULL if qualName is "::" or the flag * TCL_FIND_ONLY_NS was specified. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr = cxtNsPtr; Namespace *altNsPtr; Namespace *globalNsPtr = iPtr->globalNsPtr; CONST char *start, *end; CONST char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; int len; /* * Determine the context namespace nsPtr in which to start the primary * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY * was specified, search from the global namespace. Otherwise, use the * namespace given in cxtNsPtr, or if that is NULL, use the current * namespace context. Note that we always treat two or more * adjacent ":"s as a namespace separator. */ if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { if (iPtr->varFramePtr != NULL) { nsPtr = iPtr->varFramePtr->nsPtr; } else { nsPtr = iPtr->globalNsPtr; } } start = qualName; /* pts to start of qualifying namespace */ if ((*qualName == ':') && (*(qualName+1) == ':')) { start = qualName+2; /* skip over the initial :: */ while (*start == ':') { start++; /* skip over a subsequent : */ } nsPtr = globalNsPtr; if (*start == '\0') { /* qualName is just two or more ":"s */ *nsPtrPtr = globalNsPtr; *altNsPtrPtr = NULL; *actualCxtPtrPtr = globalNsPtr; *simpleNamePtr = start; /* points to empty string */ return TCL_OK; } } *actualCxtPtrPtr = nsPtr; /* * Start an alternate search path starting with the global namespace. * However, if the starting context is the global namespace, or if the * flag is set to search only the namespace *cxtNsPtr, ignore the * alternate search path. */ altNsPtr = globalNsPtr; if ((nsPtr == globalNsPtr) || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) { altNsPtr = NULL; } /* * Loop to resolve each namespace qualifier in qualName. */ Tcl_DStringInit(&buffer); end = start; while (*start != '\0') { /* * Find the next namespace qualifier (i.e., a name ending in "::") * or the end of the qualified name (i.e., a name ending in "\0"). * Set len to the number of characters, starting from start, * in the name; set end to point after the "::"s or at the "\0". */ len = 0; for (end = start; *end != '\0'; end++) { if ((*end == ':') && (*(end+1) == ':')) { end += 2; /* skip over the initial :: */ while (*end == ':') { end++; /* skip over the subsequent : */ } break; /* exit for loop; end is after ::'s */ } len++; } if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) { /* * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS * was specified, look this up as a namespace. Otherwise, * start is the name of a cmd or var and we are done. */ if (flags & TCL_FIND_ONLY_NS) { nsName = start; } else { *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; *simpleNamePtr = start; Tcl_DStringFree(&buffer); return TCL_OK; } } else { /* * start points to the beginning of a namespace qualifier ending * in "::". end points to the start of a name in that namespace * that might be empty. Copy the namespace qualifier to a * buffer so it can be null terminated. We can't modify the * incoming qualName since it may be a string constant. */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } /* * Look up the namespace qualifier nsName in the current namespace * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set, * create that qualifying namespace. This is needed for procedures * like Tcl_CreateCommand that cannot fail. */ if (nsPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); if (entryPtr != NULL) { nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame *framePtr; (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); TclPopStackFrame(interp); if (nsPtr == NULL) { Tcl_Panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ nsPtr = NULL; } } /* * Look up the namespace qualifier in the alternate search path too. */ if (altNsPtr != NULL) { entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); if (entryPtr != NULL) { altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else { altNsPtr = NULL; } } /* * If both search paths have failed, return NULL results. */ if ((nsPtr == NULL) && (altNsPtr == NULL)) { *nsPtrPtr = NULL; *altNsPtrPtr = NULL; *simpleNamePtr = NULL; Tcl_DStringFree(&buffer); return TCL_OK; } start = end; } /* * We ignore trailing "::"s in a namespace name, but in a command or * variable name, trailing "::"s refer to the cmd or var named {}. */ if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { *simpleNamePtr = NULL; /* found namespace name */ } else { *simpleNamePtr = end; /* found cmd/var: points to empty string */ } /* * As a special case, if we are looking for a namespace and qualName * is "" and the current active namespace (nsPtr) is not the global * namespace, return NULL (no namespace was found). This is because * namespaces can not have empty names except for the global namespace. */ if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0') && (nsPtr != globalNsPtr)) { nsPtr = NULL; } *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: * Returns a pointer to the namespace if it is found. Otherwise, * returns NULL and leaves an error message in the interpreter's * result object if "flags" contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_FindNamespace(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * namespace. */ CONST char *name; /* Namespace name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set * or if the name starts with "::". * Otherwise, points to namespace in which * to resolve name; if NULL, look up name * in the current namespace. */ register int flags; /* Flags controlling namespace lookup: an * OR'd combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; CONST char *dummy; /* * Find the namespace(s) that contain the specified namespace name. * Add the TCL_FIND_ONLY_NS flag to resolve the name all the way down * to its last component, a namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", (char *) NULL); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_FindCommand -- * * Searches for a command. * * Results: * Returns a token for the command if it is found. Otherwise, if it * can't be found or there is an error, returns NULL and leaves an * error message in the interpreter's result object if "flags" * contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_FindCommand(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * command and to report errors. */ CONST char *name; /* Command's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. * Otherwise, points to namespace in which * to resolve name. If NULL, look up name * in the current namespace. */ int flags; /* An OR'd combination of flags: * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY * (look up only in contextNsPtr, or the * current namespace if contextNsPtr is * NULL), and TCL_LEAVE_ERR_MSG. If both * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY * are given, TCL_GLOBAL_ONLY is * ignored. */ { Interp *iPtr = (Interp*)interp; Namespace *cxtNsPtr; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; CONST char *simpleName; int result; /* * If this namespace has a command resolver, then give it first * crack at the command resolution. If the interpreter has any * command resolvers, consult them next. The command resolver * procedures may return a Tcl_Command value, they may signal * to continue onward, or they may signal an error. */ if (flags & TCL_GLOBAL_ONLY) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_Command cmd; if (cxtNsPtr->cmdResProc) { result = (*cxtNsPtr->cmdResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } else { result = TCL_CONTINUE; } while (result == TCL_CONTINUE && resPtr) { if (resPtr->cmdResProc) { result = (*resPtr->cmdResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { return cmd; } else if (result != TCL_CONTINUE) { return (Tcl_Command) NULL; } } /* * Find the namespace(s) that contain the command. */ cmdPtr = NULL; if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)) { int i; Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if (realNsPtr != NULL && simpleName != NULL) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } /* * Next, check along the path. */ for (i=0 ; icommandPathLength && cmdPtr==NULL ; i++) { pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; if (pathNsPtr == NULL) { continue; } (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if (realNsPtr != NULL && simpleName != NULL) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } /* * If we've still not found the command, look in the global * namespace as a last resort. */ if (cmdPtr == NULL) { (void) TclGetNamespaceForQualName(interp, name, NULL, TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if (realNsPtr != NULL && simpleName != NULL) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } } else { Namespace *nsPtr[2]; register int search; TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. * Be sure to check both possible search paths: from the * specified namespace context and from the global namespace. */ for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } } if (cmdPtr != NULL) { return (Tcl_Command) cmdPtr; } if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown command \"", name, "\"", (char *) NULL); } return (Tcl_Command) NULL; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespaceVar -- * * Searches for a namespace variable, a variable not local to a * procedure. The variable can be either a scalar or an array, but * may not be an element of an array. * * Results: * Returns a token for the variable if it is found. Otherwise, if it * can't be found or there is an error, returns NULL and leaves an * error message in the interpreter's result object if "flags" * contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Var Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * variable. */ CONST char *name; /* Variable's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. * Otherwise, points to namespace in which * to resolve name. If NULL, look up name * in the current namespace. */ int flags; /* An OR'd combination of flags: * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY * (look up only in contextNsPtr, or the * current namespace if contextNsPtr is * NULL), and TCL_LEAVE_ERR_MSG. If both * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY * are given, TCL_GLOBAL_ONLY is * ignored. */ { Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; CONST char *simpleName; Tcl_HashEntry *entryPtr; Var *varPtr; register int search; int result; Tcl_Var var; /* * If this namespace has a variable resolver, then give it first * crack at the variable resolution. It may return a Tcl_Var * value, it may signal to continue onward, or it may signal * an error. */ if ((flags & TCL_GLOBAL_ONLY) != 0) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { result = (*resPtr->varResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { return var; } else if (result != TCL_CONTINUE) { return (Tcl_Var) NULL; } } /* * Find the namespace(s) that contain the variable. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. * Be sure to check both possible search paths: from the specified * namespace context and from the global namespace. */ varPtr = NULL; for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); } } } if (varPtr != NULL) { return (Tcl_Var) varPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown variable \"", name, "\"", (char *) NULL); } return (Tcl_Var) NULL; } /* *---------------------------------------------------------------------- * * TclResetShadowedCmdRefs -- * * Called when a command is added to a namespace to check for existing * command references that the new command may invalidate. Consider the * following cases that could happen when you add a command "foo" to a * namespace "b": * 1. It could shadow a command named "foo" at the global scope. * If it does, all command references in the namespace "b" are * suspect. * 2. Suppose the namespace "b" resides in a namespace "a". * Then to "a" the new command "b::foo" could shadow another * command "b::foo" in the global namespace. If so, then all * command references in "a" are suspect. * The same checks are applied to all parent namespaces, until we * reach the global :: namespace. * * Results: * None. * * Side effects: * If the new command shadows an existing command, the cmdRefEpoch * counter is incremented in each namespace that sees the shadow. * This invalidates all command references that were previously cached * in that namespace. The next time the commands are used, they are * resolved from scratch. * *---------------------------------------------------------------------- */ void TclResetShadowedCmdRefs(interp, newCmdPtr) Tcl_Interp *interp; /* Interpreter containing the new command. */ Command *newCmdPtr; /* Points to the new command. */ { char *cmdName; Tcl_HashEntry *hPtr; register Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); int found, i; /* * This procedure generates an array used to hold the trail list. This * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ Namespace *(trailStorage[NUM_TRAIL_ELEMS]); Namespace **trailPtr = trailStorage; int trailFront = -1; int trailSize = NUM_TRAIL_ELEMS; /* * Start at the namespace containing the new command, and work up * through the list of parents. Stop just before the global namespace, * since the global namespace can't "shadow" its own entries. * * The namespace "trail" list we build consists of the names of each * namespace that encloses the new command, in order from outermost to * innermost: for example, "a" then "b". Each iteration of this loop * eventually extends the trail upwards by one namespace, nsPtr. We use * this trail list to see if nsPtr (e.g. "a" in 2. above) could have * now-invalid cached command references. This will happen if nsPtr * (e.g. "a") contains a sequence of child namespaces (e.g. "b") * such that there is a identically-named sequence of child namespaces * starting from :: (e.g. "::b") whose tail namespace contains a command * also named cmdName. */ cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); for (nsPtr = newCmdPtr->nsPtr; (nsPtr != NULL) && (nsPtr != globalNsPtr); nsPtr = nsPtr->parentPtr) { /* * Find the maximal sequence of child namespaces contained in nsPtr * such that there is a identically-named sequence of child * namespaces starting from ::. shadowNsPtr will be the tail of this * sequence, or the deepest namespace under :: that might contain a * command now shadowed by cmdName. We check below if shadowNsPtr * actually contains a command cmdName. */ found = 1; shadowNsPtr = globalNsPtr; for (i = trailFront; i >= 0; i--) { trailNsPtr = trailPtr[i]; hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, trailNsPtr->name); if (hPtr != NULL) { shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); } else { found = 0; break; } } /* * If shadowNsPtr contains a command named cmdName, we invalidate * all of the command refs cached in nsPtr. As a boundary case, * shadowNsPtr is initially :: and we check for case 1. above. */ if (found) { hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); if (hPtr != NULL) { nsPtr->cmdRefEpoch++; TclInvalidateNsPath(nsPtr); /* * If the shadowed command was compiled to bytecodes, we * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) { nsPtr->resolverEpoch++; } } } /* * Insert nsPtr at the front of the trail list: i.e., at the end * of the trailPtr array. */ trailFront++; if (trailFront == trailSize) { size_t currBytes = trailSize * sizeof(Namespace *); int newSize = 2*trailSize; size_t newBytes = newSize * sizeof(Namespace *); Namespace **newPtr = (Namespace **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } trailPtr = newPtr; trailSize = newSize; } trailPtr[trailFront] = nsPtr; } /* * Free any allocated storage. */ if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } } /* *---------------------------------------------------------------------- * * TclGetNamespaceFromObj -- * * Gets the namespace specified by the name in a Tcl_Obj. * * Results: * Returns TCL_OK if the namespace was resolved successfully, and * stores a pointer to the namespace in the location specified by * nsPtrPtr. If the namespace can't be found, the procedure stores * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, * this procedure returns TCL_ERROR. * * Side effects: * May update the internal representation for the object, caching the * namespace reference. The next time this procedure is called, the * namespace value can be found quickly. * * If anything goes wrong, an error message is left in the * interpreter's result object. * *---------------------------------------------------------------------- */ int TclGetNamespaceFromObj(interp, objPtr, nsPtrPtr) Tcl_Interp *interp; /* The current interpreter. */ Tcl_Obj *objPtr; /* The object to be resolved as the name * of a namespace. */ Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ { Interp *iPtr = (Interp *) interp; register ResolvedNsName *resNamePtr; register Namespace *nsPtr; Namespace *currNsPtr; CallFrame *savedFramePtr; int result = TCL_OK; char *name; /* * If the namespace name is fully qualified, do as if the lookup were * done from the global namespace; this helps avoid repeated lookups * of fully qualified names. */ savedFramePtr = iPtr->varFramePtr; name = TclGetString(objPtr); if ((*name++ == ':') && (*name == ':')) { iPtr->varFramePtr = NULL; } currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); /* * Get the internal representation, converting to a namespace type if * needed. The internal representation is a ResolvedNsName that points * to the actual namespace. */ if (objPtr->typePtr != &tclNsNameType) { result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { goto done; } } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; /* * Check the context namespace of the resolved symbol to make sure that * it is fresh. If not, then force another conversion to the namespace * type, to discard the old rep and create a new one. Note that we * verify that the namespace id of the cached namespace is the same as * the id when we cached it; this insures that the namespace wasn't * deleted and a new one created at the same address. */ nsPtr = NULL; if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr) && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } } if (nsPtr == NULL) { /* try again */ result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { goto done; } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; if (resNamePtr != NULL) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } } } *nsPtrPtr = (Tcl_Namespace *) nsPtr; done: iPtr->varFramePtr = savedFramePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_NamespaceObjCmd -- * * Invoked to implement the "namespace" command that creates, deletes, * or manipulates Tcl namespaces. Handles the following syntax: * * namespace children ?name? ?pattern? * namespace code arg * namespace current * namespace delete ?name name...? * namespace ensemble subcommand ?arg...? * namespace eval name arg ?arg...? * namespace exists name * namespace export ?-clear? ?pattern pattern...? * namespace forget ?pattern pattern...? * namespace import ?-force? ?pattern pattern...? * namespace inscope name arg ?arg...? * namespace origin name * namespace parent ?name? * namespace qualifiers string * namespace tail string * namespace which ?-command? ?-variable? name * * Results: * Returns TCL_OK if the command is successful. Returns TCL_ERROR if * anything goes wrong. * * Side effects: * Based on the subcommand name (e.g., "import"), this procedure * dispatches to a corresponding procedure NamespaceXXXCmd defined * statically in this file. This procedure's side effects depend on * whatever that subcommand procedure does. If there is an error, this * procedure returns an error message in the interpreter's result * object. Otherwise it may return a result in the interpreter's result * object. * *---------------------------------------------------------------------- */ int Tcl_NamespaceObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Arbitrary value passed to cmd. */ Tcl_Interp *interp; /* Current interpreter. */ register int objc; /* Number of arguments. */ register Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { "children", "code", "current", "delete", "ensemble", "eval", "exists", "export", "forget", "import", "inscope", "origin", "parent", "path", "qualifiers", "tail", "which", (char *) NULL }; enum NSSubCmdIdx { NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, NSTailIdx, NSWhichIdx }; int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } /* * Return an index reflecting the particular subcommand. */ result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, "option", /*flags*/ 0, (int *) &index); if (result != TCL_OK) { return result; } switch (index) { case NSChildrenIdx: result = NamespaceChildrenCmd(clientData, interp, objc, objv); break; case NSCodeIdx: result = NamespaceCodeCmd(clientData, interp, objc, objv); break; case NSCurrentIdx: result = NamespaceCurrentCmd(clientData, interp, objc, objv); break; case NSDeleteIdx: result = NamespaceDeleteCmd(clientData, interp, objc, objv); break; case NSEnsembleIdx: result = NamespaceEnsembleCmd(clientData, interp, objc, objv); break; case NSEvalIdx: result = NamespaceEvalCmd(clientData, interp, objc, objv); break; case NSExistsIdx: result = NamespaceExistsCmd(clientData, interp, objc, objv); break; case NSExportIdx: result = NamespaceExportCmd(clientData, interp, objc, objv); break; case NSForgetIdx: result = NamespaceForgetCmd(clientData, interp, objc, objv); break; case NSImportIdx: result = NamespaceImportCmd(clientData, interp, objc, objv); break; case NSInscopeIdx: result = NamespaceInscopeCmd(clientData, interp, objc, objv); break; case NSOriginIdx: result = NamespaceOriginCmd(clientData, interp, objc, objv); break; case NSParentIdx: result = NamespaceParentCmd(clientData, interp, objc, objv); break; case NSPathIdx: result = NamespacePathCmd(clientData, interp, objc, objv); break; case NSQualifiersIdx: result = NamespaceQualifiersCmd(clientData, interp, objc, objv); break; case NSTailIdx: result = NamespaceTailCmd(clientData, interp, objc, objv); break; case NSWhichIdx: result = NamespaceWhichCmd(clientData, interp, objc, objv); break; } return result; } /* *---------------------------------------------------------------------- * * NamespaceChildrenCmd -- * * Invoked to implement the "namespace children" command that returns a * list containing the fully-qualified names of the child namespaces of * a given namespace. Handles the following syntax: * * namespace children ?name? ?pattern? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceChildrenCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); char *pattern = NULL; Tcl_DString buffer; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Obj *listPtr, *elemPtr; /* * Get a pointer to the specified namespace, or the current namespace. */ if (objc == 2) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), "\" in namespace children command", (char *) NULL); return TCL_ERROR; } nsPtr = (Namespace *) namespacePtr; } else { Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); return TCL_ERROR; } /* * Get the glob-style pattern, if any, used to narrow the search. */ Tcl_DStringInit(&buffer); if (objc == 4) { char *name = TclGetString(objv[3]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); if (nsPtr != globalNsPtr) { Tcl_DStringAppend(&buffer, "::", 2); } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); } } /* * Create a list containing the full names of all child namespaces * whose names match the specified pattern, if any. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { if (Tcl_FindHashEntry(&nsPtr->childTable, pattern) != NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(pattern, -1)); } goto searchDone; } entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemPtr); } entryPtr = Tcl_NextHashEntry(&search); } searchDone: Tcl_SetObjResult(interp, listPtr); Tcl_DStringFree(&buffer); return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceCodeCmd -- * * Invoked to implement the "namespace code" command to capture the * namespace context of a command. Handles the following syntax: * * namespace code arg * * Here "arg" can be a list. "namespace code arg" produces a result * equivalent to that produced by the command * * list ::namespace inscope [namespace current] $arg * * However, if "arg" is itself a scoped value starting with * "::namespace inscope", then the result is just "arg". * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceCodeCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; register char *arg, *p; int length; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg"); return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. */ arg = Tcl_GetStringFromObj(objv[2], &length); while (*arg == ':') { arg++; length--; } if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { /* empty body: skip over whitespace */ } if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { Tcl_SetObjResult(interp, objv[2]); return TCL_OK; } } /* * Otherwise, construct a scoped command by building a list with * "namespace inscope", the full name of the current namespace, and * the argument "arg". By constructing a list, we ensure that scoped * commands are interpreted properly when they are executed later, * by the "namespace inscope" command. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("::namespace", -1)); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("inscope", -1)); currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { objPtr = Tcl_NewStringObj("::", -1); } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); Tcl_ListObjAppendElement(interp, listPtr, objv[2]); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceCurrentCmd -- * * Invoked to implement the "namespace current" command which returns * the fully-qualified name of the current namespace. Handles the * following syntax: * * namespace current * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceCurrentCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Namespace *currNsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } /* * The "real" name of the global namespace ("::") is the null string, * but we return "::" for it as a convenience to programmers. Note that * "" and "::" are treated as synonyms by the namespace code so that it * is still easy to do things like: * * namespace [namespace current]::bar { ... } */ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceDeleteCmd -- * * Invoked to implement the "namespace delete" command to delete * namespace(s). Handles the following syntax: * * namespace delete ?name name...? * * Each name identifies a namespace. It may include a sequence of * namespace qualifiers separated by "::"s. If a namespace is found, it * is deleted: all variables and procedures contained in that namespace * are deleted. If that namespace is being used on the call stack, it * is kept alive (but logically deleted) until it is removed from the * call stack: that is, it can no longer be referenced by name but any * currently executing procedure that refers to it is allowed to do so * until the procedure returns. If the namespace can't be found, this * procedure returns an error. If no namespaces are specified, this * command does nothing. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Deletes the specified namespaces. If anything goes wrong, this * procedure returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int NamespaceDeleteCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; char *name; register int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } /* * Destroying one namespace may cause another to be destroyed. Break * this into two passes: first check to make sure that all namespaces on * the command line are valid, and report any errors. */ for (i = 2; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /*flags*/ 0); if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[i]), "\" in namespace delete command", (char *) NULL); return TCL_ERROR; } } /* * Okay, now delete each namespace. */ for (i = 2; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /* flags */ 0); if (namespacePtr) { Tcl_DeleteNamespace(namespacePtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceEvalCmd -- * * Invoked to implement the "namespace eval" command. Executes * commands in a namespace. If the namespace does not already exist, * it is created. Handles the following syntax: * * namespace eval name arg ?arg...? * * If more than one arg argument is specified, the command that is * executed is the result of concatenating the arguments together with * a space between each argument. * * Results: * Returns TCL_OK if the namespace is found and the commands are * executed successfully. Returns TCL_ERROR if anything goes wrong. * * Side effects: * Returns the result of the command in the interpreter's result * object. If anything goes wrong, this procedure returns an error * message as the result. * *---------------------------------------------------------------------- */ static int NamespaceEvalCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; int result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Try to resolve the namespace reference, caching the result in the * namespace object along the way. */ result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } /* * If the namespace wasn't found, try to create it. */ if (namespacePtr == NULL) { char *name = TclGetString(objv[2]); namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (namespacePtr == NULL) { return TCL_ERROR; } } /* * Make the specified namespace the current namespace and evaluate * the command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } framePtr->objc = objc; framePtr->objv = objv; /* ref counts do not need to be incremented here */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete * the object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-3, objv+3); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace eval \"", -1); Tcl_IncrRefCount(errorLine); Tcl_IncrRefCount(msg); TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, ""); Tcl_AppendToObj(msg, "\" script line ", -1); Tcl_AppendObjToObj(msg, errorLine); Tcl_DecrRefCount(errorLine); Tcl_AppendToObj(msg, ")", -1); TclAppendObjToErrorInfo(interp, msg); Tcl_DecrRefCount(msg); } /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * NamespaceExistsCmd -- * * Invoked to implement the "namespace exists" command that returns * true if the given namespace currently exists, and false otherwise. * Handles the following syntax: * * namespace exists name * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExistsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } /* * Check whether the given namespace exists */ if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL)); return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceExportCmd -- * * Invoked to implement the "namespace export" command that specifies * which commands are exported from a namespace. The exported commands * are those that can be imported into another namespace using * "namespace import". Both commands defined in a namespace and * commands the namespace has imported can be exported by a * namespace. This command has the following syntax: * * namespace export ?-clear? ?pattern pattern...? * * Each pattern may contain "string match"-style pattern matching * special characters, but the pattern may not include any namespace * qualifiers: that is, the pattern must specify commands in the * current (exporting) namespace. The specified patterns are appended * onto the namespace's list of export patterns. * * To reset the namespace's export pattern list, specify the "-clear" * flag. * * If there are no export patterns and the "-clear" flag isn't given, * this command returns the namespace's current export list. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExportCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); char *pattern, *string; int resetListFirst = 0; int firstArg, patternCt, i, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } /* * Process the optional "-clear" argument. */ firstArg = 2; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; } } /* * If no pattern arguments are given, and "-clear" isn't specified, * return the namespace's current export pattern list. */ patternCt = (objc - firstArg); if (patternCt == 0) { if (firstArg > 2) { return TCL_OK; } else { /* create list with export patterns */ Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, listPtr); if (result != TCL_OK) { return result; } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } } /* * Add each pattern to the namespace's export pattern list. */ for (i = firstArg; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, ((i == firstArg)? resetListFirst : 0)); if (result != TCL_OK) { return result; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceForgetCmd -- * * Invoked to implement the "namespace forget" command to remove * imported commands from a namespace. Handles the following syntax: * * namespace forget ?pattern pattern...? * * Each pattern is a name like "foo::*" or "a::b::x*". That is, the * pattern may include the special pattern matching characters * recognized by the "string match" command, but only in the command * name at the end of the qualified name; the special pattern * characters may not appear in a namespace name. All of the commands * that match that pattern are checked to see if they have an imported * command in the current namespace that refers to the matched * command. If there is an alias, it is removed. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Imported commands are removed from the current namespace. If * anything goes wrong, this procedure returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceForgetCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *pattern; register int i, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); return TCL_ERROR; } for (i = 2; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); if (result != TCL_OK) { return result; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceImportCmd -- * * Invoked to implement the "namespace import" command that imports * commands into a namespace. Handles the following syntax: * * namespace import ?-force? ?pattern pattern...? * * Each pattern is a namespace-qualified name like "foo::*", * "a::b::x*", or "bar::p". That is, the pattern may include the * special pattern matching characters recognized by the "string match" * command, but only in the command name at the end of the qualified * name; the special pattern characters may not appear in a namespace * name. All of the commands that match the pattern and which are * exported from their namespace are made accessible from the current * namespace context. This is done by creating a new "imported command" * in the current namespace that points to the real command in its * original namespace; when the imported command is called, it invokes * the real command. * * If an imported command conflicts with an existing command, it is * treated as an error. But if the "-force" option is included, then * existing commands are overwritten by the imported commands. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Adds imported commands to the current namespace. If anything goes * wrong, this procedure returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int NamespaceImportCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register int i = 0, result = TCL_OK; int allowOverwrite = 0, returnOrigins = 0, firstArg = 2; char *string = (char *) NULL, *pattern = (char *) NULL; Namespace *currNsPtr = (Namespace*) NULL; Command *command = (Command *) NULL; Tcl_HashSearch search; Tcl_HashEntry *hPtr = (Tcl_HashEntry *) NULL; Tcl_Obj *importedList = (Tcl_Obj *) NULL; *cmdNameObj = (Tcl_Obj *) NULL; Tcl_Command token; if (objc < 2) { Tcl_WrongNumArgs( interp, 2, objv, "?-origins | ?-force? pattern ?pattern...??" ); return TCL_ERROR; } /* * Detect the optional arguments "-force" and "-origins" * as the first argument. */ if (firstArg < objc) { string = TclGetString(objv[firstArg]); if (*string == '-') { if (strcmp(string, "-force") == 0) { if ( objc <= 3 ) { Tcl_WrongNumArgs( interp, 3, objv, NULL ); return TCL_ERROR; } allowOverwrite = 1; firstArg++; } elseif (strcmp(string, "-origins") == 0) { if ( objc != 3 ) { Tcl_WrongNumArgs( interp, 3, objv, NULL ); return TCL_ERROR; } returnOrigins = 1; } else { Tcl_ResetResult( interp ); Tcl_SetAppendResult( interp, "bad option \"", string, "\": must be -force, -origins, or omitted" ); return TCL_ERROR; } } } if ((objc == 2) || ((objc == 3) && (returnOrigins == 1) { /* get the current namespace and the first command of this * namespace */ currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp) hPtr = Tcl_FirstHashEntry(currNsPtr->cmdTable, &search); /* initialize the list of imported commands */ importedList = Tcl_NewObj(); /* loop over the commands of the current namespace * to test if they are imported and than, if so, * to get their absolute (original) names */ for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { token = (Tcl_Command) Tcl_GetHashValue(hPtr); command = (Command *) token; if (command->flags & CMD_IS_IMPORTED) { if (returnOrigins == 1) { /* get the origin of the imported namespace command */ token = TclGetOriginalCommand(token); } /* get the absolute/full name of the imported * namespace command */ cmdNameObj = Tcl_NewObj(); Tcl_GetCommandFullName(interp, token, cmdNameObj); result = Tcl_ListObjAppendElement( interp, importedList, cmdNameObj ); if (result == TCL_ERROR) { Tcl_DecrRefCount( importedList ); return TCL_ERROR; } } } Tcl_SetObjResult(interp, importedList); return TCL_OK; } /* * Handle the imports for each of the patterns. */ for (i = firstArg; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, allowOverwrite); if (result != TCL_OK) { return result; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceInscopeCmd -- * * Invoked to implement the "namespace inscope" command that executes a * script in the context of a particular namespace. This command is not * expected to be used directly by programmers; calls to it are * generated implicitly when programs use "namespace code" commands * to register callback scripts. Handles the following syntax: * * namespace inscope name arg ?arg...? * * The "namespace inscope" command is much like the "namespace eval" * command except that it has lappend semantics and the namespace must * already exist. It treats the first argument as a list, and appends * any arguments after the first onto the end as proper list elements. * For example, * * namespace inscope ::foo a b c d * * is equivalent to * * namespace eval ::foo [concat a [list b c d]] * * This lappend semantics is important because many callback scripts * are actually prefixes. * * Results: * Returns TCL_OK to indicate success, or TCL_ERROR to indicate * failure. * * Side effects: * Returns a result in the Tcl interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceInscopeCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; Tcl_CallFrame *framePtr; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Resolve the namespace reference. */ result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), "\" in inscope namespace command", (char *) NULL); return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } /* * Execute the command. If there is just one argument, just treat it as * a script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr, *cmdObjPtr; listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (i = 4; i < objc; i++) { result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); /* free unneeded obj */ return result; } } concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace inscope \"", -1); Tcl_IncrRefCount(errorLine); Tcl_IncrRefCount(msg); TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, ""); Tcl_AppendToObj(msg, "\" script line ", -1); Tcl_AppendObjToObj(msg, errorLine); Tcl_DecrRefCount(errorLine); Tcl_AppendToObj(msg, ")", -1); TclAppendObjToErrorInfo(interp, msg); Tcl_DecrRefCount(msg); } /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * NamespaceOriginCmd -- * * Invoked to implement the "namespace origin" command to return the * fully-qualified name of the "real" command to which the specified * "imported command" refers. Handles the following syntax: * * namespace origin name * * Results: * An imported command is created in an namespace when that namespace * imports a command from another namespace. If a command is imported * into a sequence of namespaces a, b,...,n where each successive * namespace just imports the command from the previous namespace, this * command returns the fully-qualified name of the original command in * the first namespace, a. If "name" does not refer to an alias, its * fully-qualified name is returned. The returned name is stored in the * interpreter's result object. This procedure returns TCL_OK if * successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error message in * the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceOriginCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Command command, origCommand; Tcl_Obj *resultPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } command = Tcl_GetCommandFromObj(interp, objv[2]); if (command == (Tcl_Command) NULL) { Tcl_AppendResult(interp, "invalid command name \"", TclGetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); resultPtr = Tcl_NewObj(); if (origCommand == (Tcl_Command) NULL) { /* * The specified command isn't an imported command. Return the * command's name qualified by the full name of the namespace it * was defined in. */ Tcl_GetCommandFullName(interp, command, resultPtr); } else { Tcl_GetCommandFullName(interp, origCommand, resultPtr); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceParentCmd -- * * Invoked to implement the "namespace parent" command that returns the * fully-qualified name of the parent namespace for a specified * namespace. Handles the following syntax: * * namespace parent ?name? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceParentCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *nsPtr; int result; if (objc == 2) { nsPtr = Tcl_GetCurrentNamespace(interp); } else if (objc == 3) { result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr); if (result != TCL_OK) { return result; } if (nsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), "\" in namespace parent command", (char *) NULL); return TCL_ERROR; } } else { Tcl_WrongNumArgs(interp, 2, objv, "?name?"); return TCL_ERROR; } /* * Report the parent of the specified namespace. */ if (nsPtr->parentPtr != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( nsPtr->parentPtr->fullName, -1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespacePathCmd -- * * Invoked to implement the "namespace path" command that reads * and writes the current namespace's command resolution path. * Has one optional argument: if present, it is a list of named * namespaces to set the path to, and if absent, the current path * should be returned. Handles the following syntax: * * namespace path ?nsList? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes * wrong (most notably if the namespace list contains the name of * something other than a namespace). In the successful-exit * case, may set the interpreter result to the list of names of * the namespaces on the current namespace's path. * * Side effects: * May update the namespace path (triggering a recomputing of all * command names that depend on the namespace for resolution). * *---------------------------------------------------------------------- */ static int NamespacePathCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); int i, nsObjc, result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; Tcl_Namespace *staticNs[4]; if (objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); return TCL_ERROR; } /* * If no path is given, return the current path. */ if (objc == 2) { /* * Not a very fast way to compute this, but easy to get right. */ for (i=0 ; icommandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { Tcl_AppendElement(interp, nsPtr->commandPathArray[i].nsPtr->fullName); } } return TCL_OK; } /* * There is a path given, so parse it into an array of namespace * pointers. */ if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { if (nsObjc > 4) { namespaceList = (Tcl_Namespace **) ckalloc(sizeof(Tcl_Namespace *) * nsObjc); } else { namespaceList = staticNs; } for (i=0 ; icommandPathSourceList; if (tmpPathArray[i].nextPtr != NULL) { tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i]; } tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i]; } if (nsPtr->commandPathLength != 0) { UnlinkNsPath(nsPtr); } nsPtr->commandPathArray = tmpPathArray; } else { if (nsPtr->commandPathLength != 0) { UnlinkNsPath(nsPtr); } } nsPtr->commandPathLength = pathLength; nsPtr->cmdRefEpoch++; nsPtr->resolverEpoch++; } /* *---------------------------------------------------------------------- * * UnlinkNsPath -- * * Delete the given namespace's command name resolution path. Only * call if the path is non-empty. Caller must reset the counter * containing the path size. * * Results: * nothing * * Side effects: * Deletes the array of path entries and unlinks those path entries * from the target namespace's list of interested namespaces. * *---------------------------------------------------------------------- */ static void UnlinkNsPath(nsPtr) Namespace *nsPtr; { int i; for (i=0 ; icommandPathLength ; i++) { NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; if (nsPathPtr->prevPtr != NULL) { nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; } if (nsPathPtr->nextPtr != NULL) { nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr; } if (nsPathPtr->nsPtr != NULL) { if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; } } } ckfree((char *) nsPtr->commandPathArray); } /* *---------------------------------------------------------------------- * * TclInvalidateNsPath -- * * Invalidate the name resolution caches for all names looked up * in namespaces whose name path includes the given namespace. * * Results: * nothing * * Side effects: * Increments the command reference epoch in each namespace whose * path includes the given namespace. This causes any cached * resolved names whose root cacheing context starts at that * namespace to be recomputed the next time they are used. * *---------------------------------------------------------------------- */ void TclInvalidateNsPath(nsPtr) Namespace *nsPtr; { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; while (nsPathPtr != NULL) { if (nsPathPtr->nsPtr != NULL) { nsPathPtr->creatorNsPtr->cmdRefEpoch++; } nsPathPtr = nsPathPtr->nextPtr; } } /* *---------------------------------------------------------------------- * * NamespaceQualifiersCmd -- * * Invoked to implement the "namespace qualifiers" command that returns * any leading namespace qualifiers in a string. These qualifiers are * namespace names separated by "::"s. For example, for "::foo::p" this * command returns "::foo", and for "::" it returns "". This command * is the complement of the "namespace tail" command. Note that this * command does not check whether the "namespace" names are, in fact, * the names of currently defined namespaces. Handles the following * syntax: * * namespace qualifiers string * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceQualifiersCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register char *name, *p; int length; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find * the start of the last "::" qualifier. */ name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { if ((*p == ':') && (p > name) && (*(p-1) == ':')) { p -= 2; /* back up over the :: */ while ((p >= name) && (*p == ':')) { p--; /* back up over the preceeding : */ } break; } } if (p >= name) { length = p-name+1; Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceTailCmd -- * * Invoked to implement the "namespace tail" command that returns the * trailing name at the end of a string with "::" namespace * qualifiers. These qualifiers are namespace names separated by * "::"s. For example, for "::foo::p" this command returns "p", and for * "::" it returns "". This command is the complement of the "namespace * qualifiers" command. Note that this command does not check whether * the "namespace" names are, in fact, the names of currently defined * namespaces. Handles the following syntax: * * namespace tail string * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceTailCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register char *name, *p; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find the * last "::" qualifier. */ name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p > name) { if ((*p == ':') && (*(p-1) == ':')) { p++; /* just after the last "::" */ break; } } if (p >= name) { Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceWhichCmd -- * * Invoked to implement the "namespace which" command that returns the * fully-qualified name of a command or variable. If the specified * command or variable does not exist, it returns "". Handles the * following syntax: * * namespace which ?-command? ?-variable? name * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything * goes wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceWhichCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *opts[] = { "-command", "-variable", NULL }; int lookupType = 0; Tcl_Obj *resultPtr; if (objc < 3 || objc > 4) { badArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); return TCL_ERROR; } else if (objc == 4) { /* * Look for a flag controlling the lookup. */ if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! */ Tcl_ResetResult(interp); goto badArgs; } } resultPtr = Tcl_NewObj(); switch (lookupType) { case 0: { /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); if (cmd != (Tcl_Command) NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; } case 1: { /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); if (var != (Tcl_Var) NULL) { Tcl_GetVariableFullName(interp, var, resultPtr); } break; } } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * FreeNsNameInternalRep -- * * Frees the resources associated with a nsName object's internal * representation. * * Results: * None. * * Side effects: * Decrements the ref count of any Namespace structure pointed * to by the nsName's internal representation. If there are no more * references to the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep(objPtr) register Tcl_Obj *objPtr; /* nsName object with internal * representation to free */ { register ResolvedNsName *resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; Namespace *nsPtr; /* * Decrement the reference count of the namespace. If there are no * more references, free it up. */ if (resNamePtr != NULL) { resNamePtr->refCount--; if (resNamePtr->refCount == 0) { /* * Decrement the reference count for the cached namespace. If * the namespace is dead, and there are no more references to * it, free it. */ nsPtr = resNamePtr->nsPtr; nsPtr->refCount--; if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } ckfree((char *) resNamePtr); } } } /* *---------------------------------------------------------------------- * * DupNsNameInternalRep -- * * Initializes the internal representation of a nsName object to a copy * of the internal representation of another nsName object. * * Results: * None. * * Side effects: * copyPtr's internal rep is set to refer to the same namespace * referenced by srcPtr's internal rep. Increments the ref count of * the ResolvedNsName structure used to hold the namespace reference. * *---------------------------------------------------------------------- */ static void DupNsNameInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { register ResolvedNsName *resNamePtr = (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; if (resNamePtr != NULL) { resNamePtr->refCount++; } copyPtr->typePtr = &tclNsNameType; } /* *---------------------------------------------------------------------- * * SetNsNameFromAny -- * * Attempt to generate a nsName internal representation for a * Tcl object. * * Results: * Returns TCL_OK if the value could be converted to a proper * namespace reference. Otherwise, it returns TCL_ERROR, along * with an error message in the interpreter's result object. * * Side effects: * If successful, the object is made a nsName object. Its internal rep * is set to point to a ResolvedNsName, which contains a cached pointer * to the Namespace. Reference counts are kept on both the * ResolvedNsName and the Namespace, so we can keep track of their * usage and free them when appropriate. * *---------------------------------------------------------------------- */ static int SetNsNameFromAny(interp, objPtr) Tcl_Interp *interp; /* Points to the namespace in which to * resolve name. Also used for error * reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { char *name; CONST char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; /* * Get the string representation. Make it up-to-date if necessary. */ name = objPtr->bytes; if (name == NULL) { name = TclGetString(objPtr); } /* * Look for the namespace "name" in the current namespace. If there is * an error parsing the (possibly qualified) name, return an error. * If the namespace isn't found, we convert the object to an nsName * object with a NULL ResolvedNsName* internal rep. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ if (nsPtr != NULL) { Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); nsPtr->refCount++; resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; resNamePtr->nsId = nsPtr->nsId; resNamePtr->refNsPtr = currNsPtr; resNamePtr->refCount = 1; } else { resNamePtr = NULL; } /* * Free the old internalRep before setting the new one. * We do this as late as possible to allow the conversion code * (in particular, Tcl_GetStringFromObj) to use that old internalRep. */ TclFreeIntRep(objPtr); objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; objPtr->typePtr = &tclNsNameType; return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfNsName -- * * Updates the string representation for a nsName object. * Note: This procedure does not free an existing old string rep * so storage will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a copy of the fully qualified * namespace name. * *---------------------------------------------------------------------- */ static void UpdateStringOfNsName(objPtr) register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ { ResolvedNsName *resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; register Namespace *nsPtr; char *name = ""; int length; if ((resNamePtr != NULL) && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } if (nsPtr != NULL) { name = nsPtr->fullName; } } /* * The following sets the string rep to an empty string on the heap * if the internal rep is NULL. */ length = strlen(name); if (length == 0) { objPtr->bytes = tclEmptyStringRep; } else { objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); objPtr->bytes[length] = '\0'; } objPtr->length = length; } /* *---------------------------------------------------------------------- * * NamespaceEnsembleCmd -- * * Invoked to implement the "namespace ensemble" command that * creates and manipulates ensembles built on top of namespaces. * Handles the following syntax: * * namespace ensemble name ?dictionary? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Creates the ensemble for the namespace if one did not * previously exist. Alternatively, alters the way that the * ensemble's subcommand => implementation prefix is configured. * *---------------------------------------------------------------------- */ static int NamespaceEnsembleCmd(dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Namespace *nsPtr; Tcl_Command token; static CONST char *subcommands[] = { "configure", "create", "exists", NULL }; enum EnsSubcmds { ENS_CONFIG, ENS_CREATE, ENS_EXISTS }; static CONST char *createOptions[] = { "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL }; enum EnsCreateOpts { CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN }; static CONST char *configOptions[] = { "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL }; enum EnsConfigOpts { CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN }; int index; nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_AppendResult(interp, "tried to manipulate ensemble of deleted namespace", NULL); } return TCL_ERROR; } if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum EnsSubcmds) index) { case ENS_CREATE: { char *name; Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; /* * Defaults */ Tcl_Obj *subcmdObj = NULL; Tcl_Obj *mapObj = NULL; int permitPrefix = 1; Tcl_Obj *unknownObj = NULL; objv += 3; objc -= 3; /* * Work out what name to use for the command to create. If * supplied, it is either fully specified or relative to the * current namespace. If not supplied, it is exactly the name * of the current namespace. */ name = nsPtr->fullName; /* * Parse the option list, applying type checks as we go. Note * that we are not incrementing any reference counts in the * objects at this stage, so the presence of an option * multiple times won't cause any memory leaks. */ for (; objc>1 ; objc-=2,objv+=2 ) { if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); continue; case CRT_SUBCMDS: if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CRT_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; /* * Verify that the map is sensible. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } if (done) { mapObj = NULL; continue; } do { Tcl_Obj **listv; char *cmd; if (Tcl_ListObjGetElements(interp, listObj, &len, &listv) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); } if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } if (len < 1) { Tcl_SetResult(interp, "ensemble subcommand implementations " "must be non-empty lists", TCL_STATIC); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); } if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName, -1); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); } Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); } while (!done); if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } mapObj = (patchedDict ? patchedDict : objv[1]); if (patchedDict) { allocatedMapFlag = 1; } continue; } case CRT_PREFIX: if (Tcl_GetBooleanFromObj(interp, objv[1], &permitPrefix) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } continue; case CRT_UNKNOWN: if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* * Create the ensemble. Note that this might delete another * ensemble linked to the same namespace, so we must be * careful. However, we should be OK because we only link the * namespace into the list once we've created it (and after * any deletions have occurred.) */ token = Tcl_CreateEnsemble(interp, name, NULL, (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); /* * Tricky! Rely on the object result not being shared! */ Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; } case ENS_EXISTS: if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); return TCL_OK; case ENS_CONFIG: if (objc < 4 || (objc != 5 && objc & 1)) { Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); return TCL_ERROR; } token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); if (token == NULL) { return TCL_ERROR; } if (objc == 5) { Tcl_Obj *resultObj; if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; case CONF_MAP: Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; case CONF_NAMESPACE: { Tcl_Namespace *namespacePtr; Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName, TCL_VOLATILE); break; } case CONF_PREFIX: { int flags; Tcl_GetEnsembleFlags(NULL, token, &flags); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); break; } case CONF_UNKNOWN: Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; } return TCL_OK; } else if (objc == 4) { /* * Produce list of all information. */ Tcl_Obj *resultObj, *tmpObj; Tcl_Namespace *namespacePtr; int flags; TclNewObj(resultObj); /* -map option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_MAP], -1)); Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); if (tmpObj != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); } /* -namespace option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, -1)); /* -prefix option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); Tcl_GetEnsembleFlags(NULL, token, &flags); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); /* -subcommands option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); if (tmpObj != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); } /* -unknown option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); if (tmpObj != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } else { Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; /* * Defaults */ Tcl_Obj *subcmdObj, *mapObj, *unknownObj; int permitPrefix, flags; Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); Tcl_GetEnsembleFlags(NULL, token, &flags); permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; objv += 4; objc -= 4; /* * Parse the option list, applying type checks as we go. * Note that we are not incrementing any reference counts * in the objects at this stage, so the presence of an * option multiple times won't cause any memory leaks. */ for (; objc>0 ; objc-=2,objv+=2 ) { if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; /* * Verify that the map is sensible. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } if (done) { mapObj = NULL; continue; } do { Tcl_Obj **listv; char *cmd; if (Tcl_ListObjGetElements(interp, listObj, &len, &listv) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); } if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } if (len < 1) { Tcl_SetResult(interp, "ensemble subcommand implementations " "must be non-empty lists", TCL_STATIC); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); } if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName, -1); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); } Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); } while (!done); if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } mapObj = (patchedDict ? patchedDict : objv[1]); if (patchedDict) { allocatedMapFlag = 1; } continue; } case CONF_NAMESPACE: if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } Tcl_AppendResult(interp, "option -namespace is read-only", NULL); return TCL_ERROR; case CONF_PREFIX: if (Tcl_GetBooleanFromObj(interp, objv[1], &permitPrefix) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } continue; case CONF_UNKNOWN: if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* * Update the namespace now that we've finished the * parsing stage. */ flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX : flags&~TCL_ENSEMBLE_PREFIX); Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj); Tcl_SetEnsembleMappingDict(NULL, token, mapObj); Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj); Tcl_SetEnsembleFlags(NULL, token, flags); return TCL_OK; } default: Tcl_Panic("unexpected ensemble command"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CreateEnsemble -- * * Create a simple ensemble attached to the given namespace. * * Results: * The token for the command created. * * Side effects: * The ensemble is created and marked for compilation. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateEnsemble(interp, name, namespacePtr, flags) Tcl_Interp *interp; CONST char *name; Tcl_Namespace *namespacePtr; int flags; { Namespace *nsPtr = (Namespace *) namespacePtr; EnsembleConfig *ensemblePtr = (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig)); Tcl_Obj *nameObj = NULL; if (nsPtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } /* * Make the name of the ensemble into a fully qualified name. * This might allocate a temporary object. */ if (!(name[0] == ':' && name[1] == ':')) { nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); if (nsPtr->parentPtr == NULL) { Tcl_AppendStringsToObj(nameObj, name, NULL); } else { Tcl_AppendStringsToObj(nameObj, "::", name, NULL); } Tcl_IncrRefCount(nameObj); name = TclGetString(nameObj); } ensemblePtr->nsPtr = nsPtr; ensemblePtr->epoch = 0; Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); ensemblePtr->subcommandArrayPtr = NULL; ensemblePtr->subcmdList = NULL; ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; ensemblePtr->unknownHandler = NULL; ensemblePtr->token = Tcl_CreateObjCommand(interp, name, NsEnsembleImplementationCmd, (ClientData)ensemblePtr, DeleteEnsembleConfig); ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; /* * Trigger an eventual recomputation of the ensemble command * set. Note that this is slightly tricky, as it means that * we are not actually counting the number of namespace export * actions, but it is the simplest way to go! */ nsPtr->exportLookupEpoch++; if (nameObj != NULL) { TclDecrRefCount(nameObj); } return ensemblePtr->token; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleSubcommandList -- * * Set the subcommand list for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble or the subcommand list - if non-NULL - is not a list). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleSubcommandList(interp, token, subcmdList) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj *subcmdList; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } if (subcmdList != NULL) { int length; if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { subcmdList = NULL; } } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; oldList = ensemblePtr->subcmdList; ensemblePtr->subcmdList = subcmdList; if (subcmdList != NULL) { Tcl_IncrRefCount(subcmdList); } if (oldList != NULL) { TclDecrRefCount(oldList); } /* * Trigger an eventual recomputation of the ensemble command * set. Note that this is slightly tricky, as it means that * we are not actually counting the number of namespace export * actions, but it is the simplest way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleMappingDict -- * * Set the mapping dictionary for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble or the mapping - if non-NULL - is not a dict). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleMappingDict(interp, token, mapDict) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj *mapDict; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } if (mapDict != NULL) { int size; if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { return TCL_ERROR; } if (size < 1) { mapDict = NULL; } } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; oldDict = ensemblePtr->subcommandDict; ensemblePtr->subcommandDict = mapDict; if (mapDict != NULL) { Tcl_IncrRefCount(mapDict); } if (oldDict != NULL) { TclDecrRefCount(oldDict); } /* * Trigger an eventual recomputation of the ensemble command * set. Note that this is slightly tricky, as it means that * we are not actually counting the number of namespace export * actions, but it is the simplest way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleUnknownHandler -- * * Set the unknown handler for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble or the unknown handler - if non-NULL - is not a list). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleUnknownHandler(interp, token, unknownList) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj *unknownList; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } if (unknownList != NULL) { int length; if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { unknownList = NULL; } } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; oldList = ensemblePtr->unknownHandler; ensemblePtr->unknownHandler = unknownList; if (unknownList != NULL) { Tcl_IncrRefCount(unknownList); } if (oldList != NULL) { TclDecrRefCount(oldList); } /* * Trigger an eventual recomputation of the ensemble command * set. Note that this is slightly tricky, as it means that * we are not actually counting the number of namespace export * actions, but it is the simplest way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleFlags -- * * Set the flags for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleFlags(interp, token, flags) Tcl_Interp *interp; Tcl_Command token; int flags; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; /* * This API refuses to set the ENS_DEAD flag... */ ensemblePtr->flags &= ENS_DEAD; ensemblePtr->flags |= flags & ~ENS_DEAD; /* * Trigger an eventual recomputation of the ensemble command * set. Note that this is slightly tricky, as it means that * we are not actually counting the number of namespace export * actions, but it is the simplest way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleSubcommandList -- * * Get the list of subcommands associated with a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The list of subcommands is returned by updating the * variable pointed to by the last parameter (NULL if this is to * be derived from the mapping dictionary or the associated * namespace's exported commands). * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleSubcommandList(interp, token, subcmdListPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj **subcmdListPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *subcmdListPtr = ensemblePtr->subcmdList; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleMappingDict -- * * Get the command mapping dictionary associated with a * particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The mapping dict is returned by updating the * variable pointed to by the last parameter (NULL if none is * installed). * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleMappingDict(interp, token, mapDictPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj **mapDictPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *mapDictPtr = ensemblePtr->subcommandDict; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleUnknownHandler -- * * Get the unknown handler associated with a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The unknown handler is returned by updating the * variable pointed to by the last parameter (NULL if no handler * is installed). * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleUnknownHandler(interp, token, unknownListPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj **unknownListPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *unknownListPtr = ensemblePtr->unknownHandler; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleFlags -- * * Get the flags for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The flags are returned by updating the variable * pointed to by the last parameter. * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleFlags(interp, token, flagsPtr) Tcl_Interp *interp; Tcl_Command token; int *flagsPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *flagsPtr = ensemblePtr->flags; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleNamespace -- * * Get the namespace associated with a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). Namespace is returned by updating the variable * pointed to by the last parameter. * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleNamespace(interp, token, namespacePtrPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Namespace **namespacePtrPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FindEnsemble -- * * Given a command name, get the ensemble token for it, allowing * for [namespace import]s. [Bug 1017022] * * Results: * The token for the ensemble command with the given name, or * NULL if the command either does not exist or is not an * ensemble (when an error message will be written into the * interp if thats non-NULL). * * Side effects: * None * *---------------------------------------------------------------------- */ Tcl_Command Tcl_FindEnsemble(interp, cmdNameObj, flags) Tcl_Interp *interp; /* Where to do the lookup, and where * to write the errors if * TCL_LEAVE_ERR_MSG is set in the * flags. */ Tcl_Obj *cmdNameObj; /* Name of command to look up. */ int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other * flags are probably not useful. */ { Command *cmdPtr; cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); if (cmdPtr == NULL) { return NULL; } if (cmdPtr->objProc != NsEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link * chains rather than duplicating it. */ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), "\" is not an ensemble command", NULL); } return NULL; } } return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * Tcl_IsEnsemble -- * * Simple test for ensemble-hood that takes into account imported * ensemble commands as well. * * Results: * Boolean value * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_IsEnsemble(token) Tcl_Command token; { Command *cmdPtr = (Command *) token; if (cmdPtr->objProc == NsEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { return 0; } return 1; } /* *---------------------------------------------------------------------- * * NsEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a * namespace other than the global namespace) as a command with * the same (short) name as the namespace in the parent namespace. * * Results: * A standard Tcl result code. Will be TCL_ERROR if the command * is not an unambiguous prefix of any command exported by the * ensemble's namespace. * * Side effects: * Depends on the command within the namespace that gets executed. * If the ensemble itself returns TCL_ERROR, a descriptive error * message will be placed in the interpreter's result. * *---------------------------------------------------------------------- */ static int NsEnsembleImplementationCmd(clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; /* The ensemble itself. */ Tcl_Obj **tempObjv; /* Space used to construct the list of * arguments to pass to the command * that implements the ensemble * subcommand. */ int result; /* The result of the subcommand * execution. */ Tcl_Obj *prefixObj; /* An object containing the prefix * words of the command that implements * the subcommand. */ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully * specified but not yet cached command * names. */ Tcl_Obj **prefixObjv; /* The list of objects to substitute in * as the target command prefix. */ int prefixObjc; /* Size of prefixObjv of course! */ int reparseCount = 0; /* Number of reparses. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); return TCL_ERROR; } restartEnsembleParse: if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ if (!Tcl_InterpDeleted(interp)) { Tcl_AppendResult(interp, "ensemble activated for deleted namespace", NULL); } return TCL_ERROR; } if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) { ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; BuildEnsembleConfig(ensemblePtr); } else { /* * Table of subcommands is still valid; therefore there might * be a valid cache of discovered information which we can * reuse. Do the check here, and if we're still valid, we can * jump straight to the part where we do the invocation of the * subcommand. */ if (objv[1]->typePtr == &tclEnsembleCmdType) { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objv[1]->internalRep.otherValuePtr; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == ensemblePtr->token) { prefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(prefixObj); goto runResultingSubcommand; } } } /* * Look in the hashtable for the subcommand name; this is the * fastest way of all. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(objv[1])); if (hPtr != NULL) { char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); /* * Cache for later in the subcommand object. */ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Can't find and we are prohibited from using unambiguous prefixes. */ goto unknownOrAmbiguousSubcommand; } else { /* * If we've not already confirmed the command with the hash as * part of building our export table, we need to scan the * sorted array for matches. */ char *subcmdName; /* Name of the subcommand, or unique * prefix of it (will be an error for * a non-unique prefix). */ char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; subcmdName = TclGetString(objv[1]); stringLength = objv[1]->length; for (i=0 ; isubcommandArrayPtr[i], (unsigned)stringLength); if (cmp == 0) { if (fullName != NULL) { /* * Since there's never the exact-match case to * worry about (hash search filters this), getting * here indicates that our subcommand is an * ambiguous prefix of (at least) two exported * subcommands, which is an error case. */ goto unknownOrAmbiguousSubcommand; } fullName = ensemblePtr->subcommandArrayPtr[i]; } else if (cmp < 0) { /* * Because we are searching a sorted table, we can now * stop searching because we have gone past anything * that could possibly match. */ break; } } if (fullName == NULL) { /* * The subcommand is not a prefix of anything, so bail out! */ goto unknownOrAmbiguousSubcommand; } hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); if (hPtr == NULL) { Tcl_Panic("full name %s not found in supposedly synchronized hash", fullName); } prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); /* * Cache for later in the subcommand object. */ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); } /* * Do the real work of execution of the subcommand by building an * array of objects (note that this is potentially not the same * length as the number of arguments to this ensemble command), * populating it and then feeding it back through the main * command-lookup engine. In theory, we could look up the command * in the namespace ourselves, as we already have the namespace in * which it is guaranteed to exist, but we don't do that (the * cacheing of the command object used should help with that.) */ Tcl_IncrRefCount(prefixObj); runResultingSubcommand: { Interp *iPtr = (Interp *) interp; int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 2; iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; } else { int ni = iPtr->ensembleRewrite.numInsertedObjs; if (ni < 2) { iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 1; } else { iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 2; } } tempObjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *)*(objc-2+prefixObjc)); memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, TCL_EVAL_INVOKE); Tcl_DecrRefCount(prefixObj); ckfree((char *)tempObjv); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = NULL; iPtr->ensembleRewrite.numRemovedObjs = 0; iPtr->ensembleRewrite.numInsertedObjs = 0; } return result; } unknownOrAmbiguousSubcommand: /* * Have not been able to match the subcommand asked for with a * real subcommand that we export. See whether a handler has been * registered for dealing with this situation. Will only call (at * most) once for any particular ensemble invocation. */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { int paramc, i; Tcl_Obj **paramv, *unknownCmd, *ensObj; unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); TclNewObj(ensObj); Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); for (i=1 ; iflags & ENS_DEAD) { Tcl_DecrRefCount(prefixObj); Tcl_SetResult(interp, "unknown subcommand handler deleted its ensemble", TCL_STATIC); return TCL_ERROR; } /* * Namespace is still there. Check if the result is a * valid list. If it is, and it is non-empty, that list * is what we are using as our replacement. */ if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { Tcl_DecrRefCount(prefixObj); Tcl_AddErrorInfo(interp, "\n while parsing result of ensemble unknown subcommand handler"); return TCL_ERROR; } if (prefixObjc > 0) { goto runResultingSubcommand; } /* * Namespace alive & empty result => reparse. */ Tcl_DecrRefCount(prefixObj); goto restartEnsembleParse; } if (!Tcl_InterpDeleted(interp)) { if (result != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_SetResult(interp, "unknown subcommand handler returned bad code: ", TCL_STATIC); switch (result) { case TCL_RETURN: Tcl_AppendResult(interp, "return", NULL); break; case TCL_BREAK: Tcl_AppendResult(interp, "break", NULL); break; case TCL_CONTINUE: Tcl_AppendResult(interp, "continue", NULL); break; default: { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%d", result); Tcl_AppendResult(interp, buf, NULL); } } Tcl_AddErrorInfo(interp, "\n result of ensemble unknown subcommand handler: "); Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); } } Tcl_DecrRefCount(unknownCmd); Tcl_Release(ensemblePtr); return TCL_ERROR; } /* * Cannot determine what subcommand to hand off to, so generate a * (standard) failure message. Note the one odd case compared * with standard ensemble-like command, which is where a namespace * has no exported commands at all... */ Tcl_ResetResult(interp); if (ensemblePtr->subcommandTable.numEntries == 0) { Tcl_AppendResult(interp, "unknown subcommand \"", TclGetString(objv[1]), "\": namespace ", ensemblePtr->nsPtr->fullName, " does not export any commands", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "unknown ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); } else { int i; for (i=0 ; isubcommandTable.numEntries-1 ; i++) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[i], ", ", NULL); } Tcl_AppendResult(interp, "or ", ensemblePtr->subcommandArrayPtr[i], NULL); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * MakeCachedEnsembleCommand -- * * Cache what we've computed so far; it's not nice to repeatedly * copy strings about. Note that to do this, we start by * deleting any old representation that there was (though if it * was an out of date ensemble rep, we can skip some of the * deallocation process.) * * Results: * None * * Side effects: * Alters the internal representation of the first object parameter. * *---------------------------------------------------------------------- */ static void MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr) Tcl_Obj *objPtr; EnsembleConfig *ensemblePtr; CONST char *subcommandName; Tcl_Obj *prefixObjPtr; { register EnsembleCmdRep *ensembleCmd; int length; if (objPtr->typePtr == &tclEnsembleCmdType) { ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ensembleCmd->nsPtr->refCount--; if ((ensembleCmd->nsPtr->refCount == 0) && (ensembleCmd->nsPtr->flags & NS_DEAD)) { NamespaceFree(ensembleCmd->nsPtr); } ckfree(ensembleCmd->fullSubcmdName); } else { /* * Kill the old internal rep, and replace it with a brand new * one of our own. */ TclFreeIntRep(objPtr); ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd; objPtr->typePtr = &tclEnsembleCmdType; } /* * Populate the internal rep. */ ensembleCmd->nsPtr = ensemblePtr->nsPtr; ensembleCmd->epoch = ensemblePtr->epoch; ensembleCmd->token = ensemblePtr->token; ensemblePtr->nsPtr->refCount++; ensembleCmd->realPrefixObj = prefixObjPtr; length = strlen(subcommandName)+1; ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); Tcl_IncrRefCount(ensembleCmd->realPrefixObj); } /* *---------------------------------------------------------------------- * * DeleteEnsembleConfig -- * * Destroys the data structure used to represent an ensemble. * This is called when the ensemble's command is deleted (which * happens automatically if the ensemble's namespace is deleted.) * Maintainers should note that ensembles should be deleted by * deleting their commands. * * Results: * None. * * Side effects: * Memory is (eventually) deallocated. * *---------------------------------------------------------------------- */ static void DeleteEnsembleConfig(clientData) ClientData clientData; { EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; Namespace *nsPtr = ensemblePtr->nsPtr; Tcl_HashSearch search; Tcl_HashEntry *hEnt; /* * Unlink from the ensemble chain if it has not been marked as * having been done already. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; if (ensPtr == ensemblePtr) { nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; } else { while (ensPtr != NULL) { if (ensPtr->next == ensemblePtr) { ensPtr->next = ensemblePtr->next; break; } ensPtr = ensPtr->next; } } } /* * Mark the namespace as dead so code that uses Tcl_Preserve() can * tell whether disaster happened anyway. */ ensemblePtr->flags |= ENS_DEAD; /* * Kill the pointer-containing fields. */ if (ensemblePtr->subcommandTable.numEntries != 0) { ckfree((char *)ensemblePtr->subcommandArrayPtr); } hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); while (hEnt != NULL) { Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hEnt); Tcl_DecrRefCount(prefixObj); hEnt = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } if (ensemblePtr->subcommandDict != NULL) { Tcl_DecrRefCount(ensemblePtr->subcommandDict); } if (ensemblePtr->unknownHandler != NULL) { Tcl_DecrRefCount(ensemblePtr->unknownHandler); } /* * Arrange for the structure to be reclaimed. Note that this is * complex because we have to make sure that we can react sensibly * when an ensemble is deleted during the process of initialising * the ensemble (especially the unknown callback.) */ Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * BuildEnsembleConfig -- * * Create the internal data structures that describe how an * ensemble looks, being a hash mapping from the full command * name to the Tcl list that describes the implementation prefix * words, and a sorted array of all the full command names to * allow for reasonably efficient unambiguous prefix handling. * * Results: * None. * * Side effects: * Reallocates and rebuilds the hash table and array stored at * the ensemblePtr argument. For large ensembles or large * namespaces, this is a potentially expensive operation. * *---------------------------------------------------------------------- */ static void BuildEnsembleConfig(ensemblePtr) EnsembleConfig *ensemblePtr; { Tcl_HashSearch search; /* Used for scanning the set of * commands in the namespace that * backs up this ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; if (hash->numEntries != 0) { /* * Remove pre-existing table. */ Tcl_HashSearch search; ckfree((char *)ensemblePtr->subcommandArrayPtr); hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(prefixObj); hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(hash); Tcl_InitHashTable(hash, TCL_STRING_KEYS); } /* * See if we've got an export list. If so, we will only export * exactly those commands, which may be either implemented by the * prefix in the subcommandDict or mapped directly onto the * namespace's commands. */ if (ensemblePtr->subcmdList != NULL) { Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; int subcmdc; Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, &subcmdv); for (i=0 ; isubcommandDict != NULL) { Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], &target); if (target != NULL) { Tcl_SetHashValue(hPtr, (ClientData) target); Tcl_IncrRefCount(target); continue; } } /* * Not there, so map onto the namespace. Note in this * case that we do not guarantee that the command is * actually there; that is the programmer's responsibility * (or [::unknown] of course). */ cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); } else { Tcl_AppendStringsToObj(cmdObj, name, NULL); } cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } else if (ensemblePtr->subcommandDict != NULL) { /* * No subcmd list, but we do have a mapping dictionary so we * should use the keys of that. Convert the dictionary's * contents into the form required for the ensemble's internal * hashtable. */ Tcl_DictSearch dictSearch; Tcl_Obj *keyObj, *valueObj; int done; Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, &keyObj, &valueObj, &done); while (!done) { char *name = TclGetString(keyObj); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); Tcl_SetHashValue(hPtr, (ClientData) valueObj); Tcl_IncrRefCount(valueObj); Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); } } else { /* * Discover what commands are actually exported by the * namespace. What we have is an array of patterns and a hash * table whose keys are the command names exported by the * namespace (the contents do not matter here.) We must find * out what commands are actually exported by filtering each * command in the namespace against each of the patterns in * the export list. Note that we use an intermediate hash * table to make memory management easier, and because that * makes exact matching far easier too. * * Suggestion for future enhancement: compute the unique * prefixes and place them in the hash too, which should make * for even faster matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { char *nsCmdName = /* Name of command in namespace. */ Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); for (i=0 ; insPtr->numExportPatterns ; i++) { if (Tcl_StringMatch(nsCmdName, ensemblePtr->nsPtr->exportArrayPtr[i])) { hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); /* * Remember, hash entries have a full reference to * the substituted part of the command (as a list) * as their content! */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; TclNewObj(cmdObj); Tcl_AppendStringsToObj(cmdObj, ensemblePtr->nsPtr->fullName, (ensemblePtr->nsPtr->parentPtr ? "::" : ""), nsCmdName, NULL); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } break; } } } } if (hash->numEntries == 0) { ensemblePtr->subcommandArrayPtr = NULL; return; } /* * Create a sorted array of all subcommands in the ensemble; hash * tables are all very well for a quick look for an exact match, * but they can't determine things like whether a string is a * prefix of another (not without lots of preparation anyway) and * they're no good for when we're generating the error message * either. * * We do this by filling an array with the names (we use the hash * keys directly to save a copy, since any time we change the * array we change the hash too, and vice versa) and running * quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **) ckalloc(sizeof(char *) * hash->numEntries); /* * Fill array from both ends as this makes us less likely to end * up with performance problems in qsort(), which is good. Note * that doing this makes this code much more opaque, but the naive * alternatve: * * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { * ensemblePtr->subcommandArrayPtr[i] = * Tcl_GetHashKey(hash, &hPtr); * } * * can produce long runs of precisely ordered table entries when * the commands in the namespace are declared in a sorted fashion * (an ordering some people like) and the hashing functions (or * the command names themselves) are fairly unfortunate. By * filling from both ends, it requires active malice (and probably * a debugger) to get qsort() to have awful runtime behaviour. */ i = 0; j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); if (hPtr == NULL) { break; } ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries, sizeof(char *), NsEnsembleStringOrder); } } /* *---------------------------------------------------------------------- * * NsEnsembleStringOrder -- * * Helper function to compare two pointers to two strings for use * with qsort(). * * Results: * -1 if the first string is smaller, 1 if the second string is * smaller, and 0 if they are equal. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int NsEnsembleStringOrder(strPtr1, strPtr2) CONST VOID *strPtr1, *strPtr2; { return strcmp(*(CONST char **)strPtr1, *(CONST char **)strPtr2); } /* *---------------------------------------------------------------------- * * FreeEnsembleCmdRep -- * * Destroys the internal representation of a Tcl_Obj that has been * holding information about a command in an ensemble. * * Results: * None. * * Side effects: * Memory is deallocated. If this held the last reference to a * namespace's main structure, that main structure will also be * destroyed. * *---------------------------------------------------------------------- */ static void FreeEnsembleCmdRep(objPtr) Tcl_Obj *objPtr; { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ckfree(ensembleCmd->fullSubcmdName); ensembleCmd->nsPtr->refCount--; if ((ensembleCmd->nsPtr->refCount == 0) && (ensembleCmd->nsPtr->flags & NS_DEAD)) { NamespaceFree(ensembleCmd->nsPtr); } ckfree((char *)ensembleCmd); } /* *---------------------------------------------------------------------- * * DupEnsembleCmdRep -- * * Makes one Tcl_Obj into a copy of another that is a subcommand * of an ensemble. * * Results: * None. * * Side effects: * Memory is allocated, and the namespace that the ensemble is * built on top of gains another reference. * *---------------------------------------------------------------------- */ static void DupEnsembleCmdRep(objPtr, copyPtr) Tcl_Obj *objPtr, *copyPtr; { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); copyPtr->typePtr = &tclEnsembleCmdType; copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->nsPtr->refCount++; ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(ensembleCopy->realPrefixObj); ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, (unsigned) length+1); } /* *---------------------------------------------------------------------- * * StringOfEnsembleCmdRep -- * * Creates a string representation of a Tcl_Obj that holds a * subcommand of an ensemble. * * Results: * None. * * Side effects: * The object gains a string (UTF-8) representation. * *---------------------------------------------------------------------- */ static void StringOfEnsembleCmdRep(objPtr) Tcl_Obj *objPtr; { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; objPtr->bytes = ckalloc((unsigned) length+1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); }