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