URL https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclNamesp.c] - Blame information for rev 1780

Go to most recent revision | Details | Compare with Previous | View Log

/*
 * 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 by Scriptics Corporation.
 *
 * Originally implemented by
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
 */
 
#include "tclInt.h"
 
/*
 * Flag passed to TclGetNamespaceForQualName to indicate that it should
 * search for a namespace rather than a command or variable inside a
 * namespace. Note that this flag's value must not conflict with the values
 * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN.
 */
 
#define FIND_ONLY_NS    0x1000
 
/*
 * Initial sise 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;
 
/*
 * 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              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 */
};
 
/*
 * Boolean flag indicating whether or not the namespName object
 * type has been registered with the Tcl compiler.
 */
 
static int nsInitialized = 0;
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitNamespaces --
 *
 *      Called when any interpreter is created to make sure that
 *      things are properly set up for namespaces.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      On the first call, the namespName object type is registered
 *      with the Tcl compiler.
 *
 *----------------------------------------------------------------------
 */
 
void
TclInitNamespaces()
{
    if (!nsInitialized) {
        Tcl_RegisterObjType(&tclNsNameType);
        nsInitialized = 1;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCurrentNamespace --
 *
 *      Returns a pointer to an interpreter's currently active namespace.
 *
 * Results:
 *      Returns a pointer to the interpreter's current namespace.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Namespace *
Tcl_GetCurrentNamespace(interp)
    register Tcl_Interp *interp; /* Interpreter whose current namespace is
                                  * being queried. */
{
    register Interp *iPtr = (Interp *) interp;
    register Namespace *nsPtr;
 
    if (iPtr->varFramePtr != NULL) {
        nsPtr = iPtr->varFramePtr->nsPtr;
    } else {
        nsPtr = iPtr->globalNsPtr;
    }
    return (Tcl_Namespace *) nsPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetGlobalNamespace --
 *
 *      Returns a pointer to an interpreter's global :: namespace.
 *
 * Results:
 *      Returns a pointer to the specified interpreter's global namespace.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Namespace *
Tcl_GetGlobalNamespace(interp)
    register Tcl_Interp *interp; /* Interpreter whose global namespace
                                  * should be returned. */
{
    register Interp *iPtr = (Interp *) interp;
 
    return (Tcl_Namespace *) iPtr->globalNsPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PushCallFrame --
 *
 *      Pushes a new call frame onto the interpreter's Tcl call stack.
 *      Called when executing a Tcl procedure or a "namespace eval" or
 *      "namespace inscope" command.
 *
 * Results:
 *      Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *      message in the interpreter's result object) if something goes wrong.
 *
 * Side effects:
 *      Modifies the interpreter's Tcl call stack.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
    Tcl_Interp *interp;          /* Interpreter in which the new call frame
                                  * is to be pushed. */
    Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to
                                  * push. Storage for this have already been
                                  * allocated by the caller; typically this
                                  * is the address of a CallFrame structure
                                  * allocated on the caller's C stack.  The
                                  * call frame will be initialized by this
                                  * procedure. The caller can pop the frame
                                  * later with Tcl_PopCallFrame, and it is
                                  * responsible for freeing the frame's
                                  * storage. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace in which the
                                  * frame will execute. If NULL, the
                                  * interpreter's current namespace will
                                  * be used. */
    int isProcCallFrame;         /* If nonzero, the frame represents a
                                  * called Tcl procedure and may have local
                                  * vars. Vars will ordinarily be looked up
                                  * in the frame. If new variables are
                                  * created, they will be created in the
                                  * frame. If 0, the frame is for a
                                  * "namespace eval" or "namespace inscope"
                                  * command and var references are treated
                                  * as references to namespace variables. */
{
    Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = (CallFrame *) callFramePtr;
    register Namespace *nsPtr;
 
    if (namespacePtr == NULL) {
        nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
        nsPtr = (Namespace *) namespacePtr;
        if (nsPtr->flags & NS_DEAD) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "namespace \"",
                    nsPtr->fullName, "\" not found in context \"",
                    Tcl_GetCurrentNamespace(interp)->fullName, "\"",
                    (char *) NULL);
            return TCL_ERROR;
        }
    }
 
    nsPtr->activationCount++;
    framePtr->nsPtr = nsPtr;
    framePtr->isProcCallFrame = isProcCallFrame;
    framePtr->objc = 0;
    framePtr->objv = NULL;
    framePtr->callerPtr = iPtr->framePtr;
    framePtr->callerVarPtr = iPtr->varFramePtr;
    if (iPtr->varFramePtr != NULL) {
        framePtr->level = (iPtr->varFramePtr->level + 1);
    } else {
        framePtr->level = 1;
    }
    framePtr->procPtr = NULL;      /* no called procedure */
    framePtr->varTablePtr = NULL;  /* and no local variables */
    framePtr->numCompiledLocals = 0;
    framePtr->compiledLocals = NULL;
 
    /*
     * Push the new call frame onto the interpreter's stack of procedure
     * call frames making it the current frame.
     */
 
    iPtr->framePtr = framePtr;
    iPtr->varFramePtr = framePtr;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PopCallFrame --
 *
 *      Removes a call frame from the Tcl call stack for the interpreter.
 *      Called to remove a frame previously pushed by Tcl_PushCallFrame.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Modifies the call stack of the interpreter. Resets various fields of
 *      the popped call frame. If a namespace has been deleted and
 *      has no more activations on the call stack, the namespace is
 *      destroyed.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_PopCallFrame(interp)
    Tcl_Interp* interp;         /* Interpreter with call frame to pop. */
{
    register Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = iPtr->framePtr;
    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;
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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. */
    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;
    char *simpleName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer1, buffer2;
    int newEntry, result;
 
    /*
     * 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.
         */
 
        result = TclGetNamespaceForQualName(interp, name,
                (Namespace *) NULL,
                /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
                &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
        if (result != TCL_OK) {
            return NULL;
        }
 
        /*
         * 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.
     */
 
    numNsCreated++;
 
    nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
    nsPtr->name            = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
    strcpy(nsPtr->name, simpleName);
    nsPtr->fullName        = NULL;   /* set below */
    nsPtr->clientData      = clientData;
    nsPtr->deleteProc      = deleteProc;
    nsPtr->parentPtr       = parentPtr;
    Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
    nsPtr->nsId            = numNsCreated;
    nsPtr->interp          = interp;
    nsPtr->flags           = 0;
    nsPtr->activationCount = 0;
    nsPtr->refCount        = 0;
    Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
    Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
    nsPtr->exportArrayPtr  = NULL;
    nsPtr->numExportPatterns = 0;
    nsPtr->maxExportPatterns = 0;
    nsPtr->cmdRefEpoch       = 0;
    nsPtr->resolverEpoch     = 0;
    nsPtr->cmdResProc        = NULL;
    nsPtr->varResProc        = NULL;
    nsPtr->compiledVarResProc = NULL;
 
    if (parentPtr != NULL) {
        entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
                &newEntry);
        Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
    }
 
    /*
     * Build the fully qualified name for this namespace.
     */
 
    Tcl_DStringInit(&buffer1);
    Tcl_DStringInit(&buffer2);
    for (ancestorPtr = nsPtr;  ancestorPtr != NULL;
            ancestorPtr = ancestorPtr->parentPtr) {
        if (ancestorPtr != globalNsPtr) {
            Tcl_DStringAppend(&buffer1, "::", 2);
            Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1);
        }
        Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1);
 
        Tcl_DStringSetLength(&buffer2, 0);
        Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1);
        Tcl_DStringSetLength(&buffer1, 0);
    }
 
    name = Tcl_DStringValue(&buffer2);
    nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1));
    strcpy(nsPtr->fullName, name);
 
    Tcl_DStringFree(&buffer1);
    Tcl_DStringFree(&buffer2);
 
    /*
     * Return a pointer to the new namespace.
     */
 
    return (Tcl_Namespace *) nsPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteNamespace --
 *
 *      Deletes a namespace and all of the commands, variables, and other
 *      namespaces within it.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      When a namespace is deleted, it is automatically removed as a
 *      child of its parent namespace. Also, all its commands, variables
 *      and child namespaces are deleted.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_DeleteNamespace(namespacePtr)
    Tcl_Namespace *namespacePtr;   /* Points to the namespace to delete. */
{
    register Namespace *nsPtr = (Namespace *) namespacePtr;
    Interp *iPtr = (Interp *) nsPtr->interp;
    Namespace *globalNsPtr =
            (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
    Tcl_HashEntry *entryPtr;
 
    /*
     * If the namespace is on the call frame stack, it is marked as "dying"
     * (NS_DYING is OR'd into its flags): the namespace can't be looked up
     * by name but its commands and variables are still usable by those
     * active call frames. When all active call frames referring to the
     * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will
     * call this procedure again to delete everything in the namespace.
     * If no nsName objects refer to the namespace (i.e., if its refCount
     * is zero), its commands and variables are deleted and the storage for
     * its namespace structure is freed. Otherwise, if its refCount is
     * nonzero, the namespace's commands and variables are deleted but the
     * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
     * flags to allow the namespace resolution code to recognize that the
     * namespace is "deleted". The structure's storage is freed by
     * FreeNsNameInternalRep when its refCount reaches 0.
     */
 
    if (nsPtr->activationCount > 0) {
        nsPtr->flags |= NS_DYING;
        if (nsPtr->parentPtr != NULL) {
            entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
                    nsPtr->name);
            if (entryPtr != NULL) {
                Tcl_DeleteHashEntry(entryPtr);
            }
        }
        nsPtr->parentPtr = NULL;
    } else {
        /*
         * Delete the namespace and everything in it. If this is the global
         * namespace, then clear it but don't free its storage unless the
         * interpreter is being torn down.
         */
 
        TclTeardownNamespace(nsPtr);
 
        if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
            /*
             * If this is the global namespace, then it may have residual
             * "errorInfo" and "errorCode" variables for errors that
             * occurred while it was being torn down.  Try to clear the
             * variable list one last time.
             */
 
            TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable);
 
            Tcl_DeleteHashTable(&nsPtr->childTable);
            Tcl_DeleteHashTable(&nsPtr->cmdTable);
 
            /*
             * If the reference count is 0, then discard the namespace.
             * Otherwise, mark it as "dead" so that it can't be used.
             */
 
            if (nsPtr->refCount == 0) {
                NamespaceFree(nsPtr);
            } else {
                nsPtr->flags |= NS_DEAD;
            }
        }
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclTeardownNamespace --
 *
 *      Used internally to dismantle and unlink a namespace when it is
 *      deleted. Divorces the namespace from its parent, and deletes all
 *      commands, variables, and child namespaces.
 *
 *      This is kept separate from Tcl_DeleteNamespace so that the global
 *      namespace can be handled specially. Global variables like
 *      "errorInfo" and "errorCode" need to remain intact while other
 *      namespaces and commands are torn down, in case any errors occur.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Removes this namespace from its parent's child namespace hashtable.
 *      Deletes all commands, variables and namespaces in this namespace.
 *      If this is the global namespace, the "errorInfo" and "errorCode"
 *      variables are left alone and deleted later.
 *
 *----------------------------------------------------------------------
 */
 
void
TclTeardownNamespace(nsPtr)
    register Namespace *nsPtr;  /* Points to the namespace to be dismantled
                                 * and unlinked from its parent. */
{
    Interp *iPtr = (Interp *) nsPtr->interp;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Namespace *childNsPtr;
    Tcl_Command cmd;
    Namespace *globalNsPtr =
            (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
    int i;
 
    /*
     * Start by destroying the namespace's variable table,
     * since variables might trigger traces.
     */
 
    if (nsPtr == globalNsPtr) {
        /*
         * This is the global namespace, 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.
         */
 
        char *str, *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;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceFree --
 *
 *      Called after a namespace has been deleted, when its
 *      reference count reaches 0.  Frees the data structure
 *      representing the namespace.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static void
NamespaceFree(nsPtr)
    register Namespace *nsPtr;  /* Points to the namespace to free. */
{
    /*
     * Most of the namespace's contents are freed when the namespace is
     * deleted by Tcl_DeleteNamespace. All that remains is to free its names
     * (for error messages), and the structure itself.
     */
 
    ckfree(nsPtr->name);
    ckfree(nsPtr->fullName);
 
    ckfree((char *) nsPtr);
}
 
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Export --
 *
 *      Makes all the commands matching a pattern available to later be
 *      imported from the namespace specified by contextNsPtr (or the
 *      current namespace if contextNsPtr 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. */
    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
                                  * be overwritten by imported commands.
                                  * 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);
    char *simplePattern, *patternCpy;
    int neededElems, len, i, result;
 
    /*
     * 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.
     */
 
    result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
            /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr,
            &dummyPtr, &simplePattern);
    if (result != TCL_OK) {
        return result;
    }
    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 there is room in the namespace's pattern array for the
     * new pattern.
     */
 
    neededElems = nsPtr->numExportPatterns + 1;
    if (nsPtr->exportArrayPtr == NULL) {
        nsPtr->exportArrayPtr = (char **)
                ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
        nsPtr->numExportPatterns = 0;
        nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
    } else if (neededElems > nsPtr->maxExportPatterns) {
        int numNewElems = 2 * nsPtr->maxExportPatterns;
        size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
        size_t newBytes  = numNewElems * sizeof(char *);
        char **newPtr = (char **) ckalloc((unsigned) newBytes);
 
        memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr,
                currBytes);
        ckfree((char *) nsPtr->exportArrayPtr);
        nsPtr->exportArrayPtr = (char **) newPtr;
        nsPtr->maxExportPatterns = numNewElems;
    }
 
    /*
     * Add the pattern to the namespace's array of export patterns.
     */
 
    len = strlen(pattern);
    patternCpy = (char *) ckalloc((unsigned) (len + 1));
    strcpy(patternCpy, pattern);
 
    nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
    nsPtr->numExportPatterns++;
    return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendExportList --
 *
 *      Appends onto the argument object the list of export patterns for the
 *      specified namespace.
 *
 * Results:
 *      The return value is normally TCL_OK; in this case the object
 *      referenced by objPtr has each export pattern appended to it. If an
 *      error occurs, TCL_ERROR is returned and the interpreter's result
 *      holds an error message.
 *
 * Side effects:
 *      If necessary, the object referenced by objPtr is converted into
 *      a list object.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_AppendExportList(interp, namespacePtr, objPtr)
    Tcl_Interp *interp;          /* Interpreter used for error reporting. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace whose export
                                  * pattern list is appended onto objPtr.
                                  * NULL for the current namespace. */
    Tcl_Obj *objPtr;             /* Points to the Tcl object onto which the
                                  * export pattern list is appended. */
{
    Namespace *nsPtr;
    int i, result;
 
    /*
     * If the specified namespace is NULL, use the current namespace.
     */
 
    if (namespacePtr == NULL) {
        nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
        nsPtr = (Namespace *) namespacePtr;
    }
 
    /*
     * Append the export pattern list onto objPtr.
     */
 
    for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
        result = Tcl_ListObjAppendElement(interp, objPtr,
                Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
        if (result != TCL_OK) {
            return result;
        }
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Import --
 *
 *      Imports all of the commands matching a pattern into the namespace
 *      specified by contextNsPtr (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. */
    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);
    char *simplePattern, *cmdName;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Command *cmdPtr;
    ImportRef *refPtr;
    Tcl_Command autoCmd, importedCmd;
    ImportedCmdData *dataPtr;
    int wasExported, i, result;
 
    /*
     * If the specified namespace is NULL, use the current namespace.
     */
 
    if (namespacePtr == NULL) {
        nsPtr = (Namespace *) currNsPtr;
    } else {
        nsPtr = (Namespace *) namespacePtr;
    }
 
    /*
     * First, invoke the "auto_import" command with the pattern
     * being imported.  This command is part of the Tcl library.
     * It looks for imported commands in autoloaded libraries and
     * loads them in.  That way, they will be found when we try
     * to create links below.
     */
 
    autoCmd = Tcl_FindCommand(interp, "auto_import",
            (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
 
    if (autoCmd != NULL) {
        Tcl_Obj *objv[2];
 
        objv[0] = Tcl_NewStringObj("auto_import", -1);
        Tcl_IncrRefCount(objv[0]);
        objv[1] = Tcl_NewStringObj(pattern, -1);
        Tcl_IncrRefCount(objv[1]);
 
        cmdPtr = (Command *) autoCmd;
        result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
                2, objv);
 
        Tcl_DecrRefCount(objv[0]);
        Tcl_DecrRefCount(objv[1]);
 
        if (result != TCL_OK) {
            return TCL_ERROR;
        }
        Tcl_ResetResult(interp);
    }
 
    /*
     * From the pattern, find the namespace from which we are importing
     * and get the simple pattern (no namespace qualifiers or ::'s) at
     * the end.
     */
 
    if (strlen(pattern) == 0) {
        Tcl_SetStringObj(Tcl_GetObjResult(interp),
                "empty import pattern", -1);
        return TCL_ERROR;
    }
    result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
            /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
            &dummyPtr, &simplePattern);
    if (result != TCL_OK) {
        return TCL_ERROR;
    }
    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);
 
                cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
                dataPtr = (ImportedCmdData *)
                        ckalloc(sizeof(ImportedCmdData));
                importedCmd = Tcl_CreateObjCommand(interp,
                        Tcl_DStringValue(&ds), InvokeImportedCmd,
                        (ClientData) dataPtr, DeleteImportedCmd);
                dataPtr->realCmdPtr = cmdPtr;
                dataPtr->selfPtr = (Command *) importedCmd;
 
                /*
                 * 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;
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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. */
    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;
    char *simplePattern, *cmdName;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Command *cmdPtr;
    int result;
 
    /*
     * 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.
     */
 
    result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
            /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
            &actualCtxPtr, &simplePattern);
    if (result != TCL_OK) {
        return result;
    }
    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;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetOriginalCommand --
 *
 *      An imported command is created in an namespace when it imports a
 *      "real" command from another namespace. If the specified command is a
 *      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 command for which the original
                                 * command should be returned. */
{
    register Command *cmdPtr = (Command *) command;
    ImportedCmdData *dataPtr;
 
    if (cmdPtr->deleteProc != DeleteImportedCmd) {
        return (Tcl_Command) NULL;
    }
 
    while (cmdPtr->deleteProc == DeleteImportedCmd) {
        dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
        cmdPtr = dataPtr->realCmdPtr;
    }
    return (Tcl_Command) cmdPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * InvokeImportedCmd --
 *
 *      Invoked by Tcl whenever the user calls an imported command that
 *      was created by Tcl_Import. Finds the "real" command (in another
 *      namespace), and passes control to it.
 *
 * Results:
 *      Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result object is set to an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
InvokeImportedCmd(clientData, interp, objc, objv)
    ClientData clientData;      /* Points to the imported command's
                                 * ImportedCmdData structure. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* The argument objects. */
{
    register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
    register Command *realCmdPtr = dataPtr->realCmdPtr;
 
    return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
            objc, objv);
}
 
/*
 *----------------------------------------------------------------------
 *
 * DeleteImportedCmd --
 *
 *      Invoked by Tcl whenever an imported command is deleted. The "real"
 *      command keeps a list of all the imported commands that refer to it,
 *      so those imported commands can be deleted when the real command is
 *      deleted. This procedure removes the imported command reference from
 *      the real command's list, and frees up the memory associated with
 *      the imported command.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Removes the imported command from the real command's import list.
 *
 *----------------------------------------------------------------------
 */
 
static void
DeleteImportedCmd(clientData)
    ClientData clientData;      /* Points to the imported command's
                                 * ImportedCmdData structure. */
{
    ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;
    Command *selfPtr = dataPtr->selfPtr;
    register ImportRef *refPtr, *prevPtr;
 
    prevPtr = NULL;
    for (refPtr = realCmdPtr->importRefPtr;  refPtr != NULL;
            refPtr = refPtr->nextPtr) {
        if (refPtr->importedCmdPtr == selfPtr) {
            /*
             * Remove *refPtr from real command's list of imported commands
             * that refer to it.
             */
 
            if (prevPtr == NULL) { /* refPtr is first in list */
                realCmdPtr->importRefPtr = refPtr->nextPtr;
            } else {
                prevPtr->nextPtr = refPtr->nextPtr;
            }
            ckfree((char *) refPtr);
            ckfree((char *) dataPtr);
            return;
        }
        prevPtr = refPtr;
    }
 
    panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceForQualName --
 *
 *      Given a qualified name specifying a command, variable, or namespace,
 *      and a namespace in which to resolve the name, this procedure returns
 *      a pointer to the namespace that contains the item. A qualified name
 *      consists of the "simple" name of an item qualified by the names of
 *      an arbitrary number of containing namespace separated by "::"s. If
 *      the qualified name starts with "::", it is interpreted absolutely
 *      from the global namespace. Otherwise, it is interpreted relative to
 *      the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
 *      is NULL, the name is interpreted relative to the current namespace.
 *
 *      A relative name like "foo::bar::x" can be found starting in either
 *      the current namespace or in the global namespace. So each search
 *      usually follows two tracks, and two possible namespaces are
 *      returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to
 *      NULL, then that path failed.
 *
 *      If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
 *      sought only in the global :: namespace. The alternate search
 *      (also) starting from the global namespace is ignored and
 *      *altNsPtrPtr is set NULL.
 *
 *      If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
 *      name is sought only in the namespace specified by cxtNsPtr. The
 *      alternate search starting from the global namespace is ignored and
 *      *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
 *      TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
 *      the search starts from the namespace specified by cxtNsPtr.
 *
 *      If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace
 *      components of the qualified name that cannot be found are
 *      automatically created within their specified parent. This makes sure
 *      that functions like Tcl_CreateCommand always succeed. There is no
 *      alternate search path, so *altNsPtrPtr is set NULL.
 *
 *      If "flags" contains FIND_ONLY_NS, the qualified name is treated as a
 *      reference to a namespace, and the entire qualified name is
 *      followed. If the name is relative, the namespace is looked up only
 *      in the current namespace. A pointer to the namespace is stored in
 *      *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if
 *      FIND_ONLY_NS is not specified, only the leading components are
 *      treated as namespace names, and a pointer to the simple name of the
 *      final component is stored in *simpleNamePtr.
 *
 * Results:
 *      Ordinarily this procedure returns TCL_OK. 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.
 *
 * Side effects:
 *      If flags contains TCL_LEAVE_ERR_MSG and an error is encountered,
 *      the interpreter's result object will contain an error message.
 *
 *----------------------------------------------------------------------
 */
 
int
TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
        nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
    Tcl_Interp *interp;          /* Interpreter in which to find the
                                  * namespace containing qualName. */
    register 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. */
    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;
    register char *start, *end;
    char *nsName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer;
    int len, result;
 
    /*
     * 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;
 
                result = Tcl_PushCallFrame(interp, &frame,
                        (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
                if (result != TCL_OK) {
                    Tcl_DStringFree(&buffer);
                    return result;
                }
                nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
                        (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
                Tcl_PopCallFrame(interp);
                if (nsPtr == NULL) {
                    Tcl_DStringFree(&buffer);
                    return TCL_ERROR;
                }
            } else {            /* namespace not found and wasn't created */
                nsPtr = NULL;
            }
        }
 
        /*
         * Look up the namespace qualifier in the alternate search path too.
         */
 
        if (altNsPtr != NULL) {
            entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
            if (entryPtr != NULL) {
                altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
            } else {
                altNsPtr = NULL;
            }
        }
 
        /*
         * If both search paths have failed, return NULL results.
         */
 
        if ((nsPtr == NULL) && (altNsPtr == NULL)) {
            *nsPtrPtr      = NULL;
            *altNsPtrPtr   = NULL;
            *simpleNamePtr = NULL;
            Tcl_DStringFree(&buffer);
            return TCL_OK;
        }
 
        start = end;
    }
 
    /*
     * We ignore trailing "::"s in a namespace name, but in a command or
     * variable name, trailing "::"s refer to the cmd or var named {}.
     */
 
    if ((flags & FIND_ONLY_NS)
            || ((end > start ) && (*(end-1) != ':'))) {
        *simpleNamePtr = NULL; /* found namespace name */
    } else {
        *simpleNamePtr = end;  /* found cmd/var: points to empty string */
    }
 
    /*
     * As a special case, if we are looking for a namespace and qualName
     * is "" and the current active namespace (nsPtr) is not the global
     * namespace, return NULL (no namespace was found). This is because
     * namespaces can not have empty names except for the global namespace.
     */
 
    if ((flags & FIND_ONLY_NS) && (*qualName == '\0')
            && (nsPtr != globalNsPtr)) {
        nsPtr = NULL;
    }
 
    *nsPtrPtr    = nsPtr;
    *altNsPtrPtr = altNsPtr;
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespace --
 *
 *      Searches for a namespace.
 *
 * Results:
 *      Returns a pointer to the namespace if it is found. Otherwise,
 *      returns NULL and leaves an error message in the interpreter's
 *      result object if "flags" contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Namespace *
Tcl_FindNamespace(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;          /* The interpreter in which to find the
                                  * namespace. */
    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;
    char *dummy;
    int result;
 
    /*
     * 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.
     */
 
    result = TclGetNamespaceForQualName(interp, name,
            (Namespace *) contextNsPtr, /*flags*/ (flags | FIND_ONLY_NS),
            &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
    if (result != TCL_OK) {
        return NULL;
    }
    if (nsPtr != NULL) {
       return (Tcl_Namespace *) nsPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown namespace \"", name, "\"", (char *) NULL);
    }
    return NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindCommand --
 *
 *      Searches for a command.
 *
 * Results:
 *      Returns a token for the command if it is found. Otherwise, if it
 *      can't be found or there is an error, returns NULL and leaves an
 *      error message in the interpreter's result object if "flags"
 *      contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Command
Tcl_FindCommand(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;         /* The interpreter in which to find the
                                  * command and to report errors. */
    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;
    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.
     */
 
    result = TclGetNamespaceForQualName(interp, name,
            (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1],
            &cxtNsPtr, &simpleName);
    if (result != TCL_OK) {
        return (Tcl_Command) NULL;
    }
 
    /*
     * Look for the command in the command table of its namespace.
     * Be sure to check both possible search paths: from the specified
     * namespace context and from the global namespace.
     */
 
    cmdPtr = NULL;
    for (search = 0;  (search < 2) && (cmdPtr == NULL);  search++) {
        if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
            entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
                    simpleName);
            if (entryPtr != NULL) {
                cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
            }
        }
    }
    if (cmdPtr != NULL) {
        return (Tcl_Command) cmdPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown command \"", name, "\"", (char *) NULL);
    }
 
    return (Tcl_Command) NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespaceVar --
 *
 *      Searches for a namespace variable, a variable not local to a
 *      procedure. The variable can be either a scalar or an array, but
 *      may not be an element of an array.
 *
 * Results:
 *      Returns a token for the variable if it is found. Otherwise, if it
 *      can't be found or there is an error, returns NULL and leaves an
 *      error message in the interpreter's result object if "flags"
 *      contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;          /* The interpreter in which to find the
                                  * variable. */
    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;
    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.
     */
 
    result = TclGetNamespaceForQualName(interp, name,
            (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1],
            &cxtNsPtr, &simpleName);
    if (result != TCL_OK) {
        return (Tcl_Var) NULL;
    }
 
    /*
     * Look for the variable in the variable table of its namespace.
     * Be sure to check both possible search paths: from the specified
     * namespace context and from the global namespace.
     */
 
    varPtr = NULL;
    for (search = 0;  (search < 2) && (varPtr == NULL);  search++) {
        if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
            entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable,
                    simpleName);
            if (entryPtr != NULL) {
                varPtr = (Var *) Tcl_GetHashValue(entryPtr);
            }
        }
    }
    if (varPtr != NULL) {
        return (Tcl_Var) varPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown variable \"", name, "\"", (char *) NULL);
    }
    return (Tcl_Var) NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclResetShadowedCmdRefs --
 *
 *      Called when a command is added to a namespace to check for existing
 *      command references that the new command may invalidate. Consider the
 *      following cases that could happen when you add a command "foo" to a
 *      namespace "b":
 *         1. It could shadow a command named "foo" at the global scope.
 *            If it does, all command references in the namespace "b" are
 *            suspect.
 *         2. Suppose the namespace "b" resides in a namespace "a".
 *            Then to "a" the new command "b::foo" could shadow another
 *            command "b::foo" in the global namespace. If so, then all
 *            command references in "a" are suspect.
 *      The same checks are applied to all parent namespaces, until we
 *      reach the global :: namespace.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      If the new command shadows an existing command, the cmdRefEpoch
 *      counter is incremented in each namespace that sees the shadow.
 *      This invalidates all command references that were previously cached
 *      in that namespace. The next time the commands are used, they are
 *      resolved from scratch.
 *
 *----------------------------------------------------------------------
 */
 
void
TclResetShadowedCmdRefs(interp, newCmdPtr)
    Tcl_Interp *interp;        /* Interpreter containing the new command. */
    Command *newCmdPtr;        /* Points to the new command. */
{
    char *cmdName;
    Tcl_HashEntry *hPtr;
    register Namespace *nsPtr;
    Namespace *trailNsPtr, *shadowNsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    int found, i;
 
    /*
     * This procedure generates an array used to hold the trail list. This
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */
 
    Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
    Namespace **trailPtr = trailStorage;
    int trailFront = -1;
    int trailSize = NUM_TRAIL_ELEMS;
 
    /*
     * Start at the namespace containing the new command, and work up
     * through the list of parents. Stop just before the global namespace,
     * since the global namespace can't "shadow" its own entries.
     *
     * The namespace "trail" list we build consists of the names of each
     * namespace that encloses the new command, in order from outermost to
     * innermost: for example, "a" then "b". Each iteration of this loop
     * eventually extends the trail upwards by one namespace, nsPtr. We use
     * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
     * now-invalid cached command references. This will happen if nsPtr
     * (e.g. "a") contains a sequence of child namespaces (e.g. "b")
     * such that there is a identically-named sequence of child namespaces
     * starting from :: (e.g. "::b") whose tail namespace contains a command
     * also named cmdName.
     */
 
    cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
    for (nsPtr = newCmdPtr->nsPtr;
            (nsPtr != NULL) && (nsPtr != globalNsPtr);
            nsPtr = nsPtr->parentPtr) {
        /*
         * Find the maximal sequence of child namespaces contained in nsPtr
         * such that there is a identically-named sequence of child
         * namespaces starting from ::. shadowNsPtr will be the tail of this
         * sequence, or the deepest namespace under :: that might contain a
         * command now shadowed by cmdName. We check below if shadowNsPtr
         * actually contains a command cmdName.
         */
 
        found = 1;
        shadowNsPtr = globalNsPtr;
 
        for (i = trailFront;  i >= 0;  i--) {
            trailNsPtr = trailPtr[i];
            hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
                    trailNsPtr->name);
            if (hPtr != NULL) {
                shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
            } else {
                found = 0;
                break;
            }
        }
 
        /*
         * If shadowNsPtr contains a command named cmdName, we invalidate
         * all of the command refs cached in nsPtr. As a boundary case,
         * shadowNsPtr is initially :: and we check for case 1. above.
         */
 
        if (found) {
            hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
            if (hPtr != NULL) {
                nsPtr->cmdRefEpoch++;
            }
        }
 
        /*
         * Insert nsPtr at the front of the trail list: i.e., at the end
         * of the trailPtr array.
         */
 
        trailFront++;
        if (trailFront == trailSize) {
            size_t currBytes = trailSize * sizeof(Namespace *);
            int newSize = 2*trailSize;
            size_t newBytes = newSize * sizeof(Namespace *);
            Namespace **newPtr =
                    (Namespace **) ckalloc((unsigned) newBytes);
 
            memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes);
            if (trailPtr != trailStorage) {
                ckfree((char *) trailPtr);
            }
            trailPtr = newPtr;
            trailSize = newSize;
        }
        trailPtr[trailFront] = nsPtr;
    }
 
    /*
     * Free any allocated storage.
     */
 
    if (trailPtr != trailStorage) {
        ckfree((char *) trailPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetNamespaceFromObj --
 *
 *      Returns 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. */
{
    register ResolvedNsName *resNamePtr;
    register Namespace *nsPtr;
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    int result;
 
    /*
     * 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) {
            return TCL_ERROR;
        }
    }
    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) {
            return TCL_ERROR;
        }
        resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
        if (resNamePtr != NULL) {
            nsPtr = resNamePtr->nsPtr;
            if (nsPtr->flags & NS_DEAD) {
                nsPtr = NULL;
            }
        }
    }
    *nsPtrPtr = (Tcl_Namespace *) nsPtr;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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 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 char *subCmds[] = {
            "children", "code", "current", "delete",
            "eval", "export", "forget", "import",
            "inscope", "origin", "parent", "qualifiers",
            "tail", "which", (char *) NULL};
    enum NSSubCmdIdx {
            NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
            NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
            NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
            NSTailIdx, NSWhichIdx
    } index;
    int 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 NSExportIdx:
            result = NamespaceExportCmd(clientData, interp, objc, objv);
            break;
        case NSForgetIdx:
            result = NamespaceForgetCmd(clientData, interp, objc, objv);
            break;
        case NSImportIdx:
            result = NamespaceImportCmd(clientData, interp, objc, objv);
            break;
        case NSInscopeIdx:
            result = NamespaceInscopeCmd(clientData, interp, objc, objv);
            break;
        case NSOriginIdx:
            result = NamespaceOriginCmd(clientData, interp, objc, objv);
            break;
        case NSParentIdx:
            result = NamespaceParentCmd(clientData, interp, objc, objv);
            break;
        case NSQualifiersIdx:
            result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
            break;
        case NSTailIdx:
            result = NamespaceTailCmd(clientData, interp, objc, objv);
            break;
        case NSWhichIdx:
            result = NamespaceWhichCmd(clientData, interp, objc, objv);
            break;
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceChildrenCmd --
 *
 *      Invoked to implement the "namespace children" command that returns a
 *      list containing the fully-qualified names of the child namespaces of
 *      a given namespace. Handles the following syntax:
 *
 *          namespace children ?name? ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceChildrenCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    Namespace *nsPtr, *childNsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    char *pattern = NULL;
    Tcl_DString buffer;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Obj *listPtr, *elemPtr;
 
    /*
     * Get a pointer to the specified namespace, or the current namespace.
     */
 
    if (objc == 2) {
        nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else if ((objc == 3) || (objc == 4)) {
        if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
            return TCL_ERROR;
        }
        if (namespacePtr == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "unknown namespace \"",
                    Tcl_GetStringFromObj(objv[2], (int *) NULL),
                    "\" 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_GetStringFromObj(objv[3], (int *) NULL);
 
        if ((*name == ':') && (*(name+1) == ':')) {
            pattern = name;
        } else {
            Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
            if (nsPtr != globalNsPtr) {
                Tcl_DStringAppend(&buffer, "::", 2);
            }
            Tcl_DStringAppend(&buffer, name, -1);
            pattern = Tcl_DStringValue(&buffer);
        }
    }
 
    /*
     * Create a list containing the full names of all child namespaces
     * whose names match the specified pattern, if any.
     */
 
    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
    while (entryPtr != NULL) {
        childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
        if ((pattern == NULL)
                || Tcl_StringMatch(childNsPtr->fullName, pattern)) {
            elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
            Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
        }
        entryPtr = Tcl_NextHashEntry(&search);
    }
 
    Tcl_SetObjResult(interp, listPtr);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceCodeCmd --
 *
 *      Invoked to implement the "namespace code" command to capture the
 *      namespace context of a command. Handles the following syntax:
 *
 *          namespace code arg
 *
 *      Here "arg" can be a list. "namespace code arg" produces a result
 *      equivalent to that produced by the command
 *
 *          list namespace inscope [namespace current] $arg
 *
 *      However, if "arg" is itself a scoped value starting with
 *      "namespace inscope", then the result is just "arg".
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      If anything goes wrong, this procedure returns an error
 *      message as the result in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceCodeCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Namespace *currNsPtr;
    Tcl_Obj *listPtr, *objPtr;
    register char *arg, *p;
    int length;
 
    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "arg");
        return TCL_ERROR;
    }
 
    /*
     * If "arg" is already a scoped value, then return it directly.
     */
 
    arg = Tcl_GetStringFromObj(objv[2], &length);
    if ((*arg == 'n') && (length > 17)
            && (strncmp(arg, "namespace", 9) == 0)) {
        for (p = (arg + 9);  (*p == ' ');  p++) {
            /* empty body: skip over spaces */
        }
        if ((*p == 'i') && ((p + 7) <= (arg + length))
                && (strncmp(p, "inscope", 7) == 0)) {
            Tcl_SetObjResult(interp, objv[2]);
            return TCL_OK;
        }
    }
 
    /*
     * Otherwise, construct a scoped command by building a list with
     * "namespace inscope", the full name of the current namespace, and
     * the argument "arg". By constructing a list, we ensure that scoped
     * commands are interpreted properly when they are executed later,
     * by the "namespace inscope" command.
     */
 
    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    Tcl_ListObjAppendElement(interp, listPtr,
            Tcl_NewStringObj("namespace", -1));
    Tcl_ListObjAppendElement(interp, listPtr,
            Tcl_NewStringObj("inscope", -1));
 
    currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
        objPtr = Tcl_NewStringObj("::", -1);
    } else {
        objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
    }
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
 
    Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
 
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceCurrentCmd --
 *
 *      Invoked to implement the "namespace current" command which returns
 *      the fully-qualified name of the current namespace. Handles the
 *      following syntax:
 *
 *          namespace current
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceCurrentCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    register Namespace *currNsPtr;
 
    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 2, objv, NULL);
        return TCL_ERROR;
    }
 
    /*
     * The "real" name of the global namespace ("::") is the null string,
     * but we return "::" for it as a convenience to programmers. Note that
     * "" and "::" are treated as synonyms by the namespace code so that it
     * is still easy to do things like:
     *
     *    namespace [namespace current]::bar { ... }
     */
 
    currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
        Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1);
    } else {
        Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceDeleteCmd --
 *
 *      Invoked to implement the "namespace delete" command to delete
 *      namespace(s). Handles the following syntax:
 *
 *          namespace delete ?name name...?
 *
 *      Each name identifies a namespace. It may include a sequence of
 *      namespace qualifiers separated by "::"s. If a namespace is found, it
 *      is deleted: all variables and procedures contained in that namespace
 *      are deleted. If that namespace is being used on the call stack, it
 *      is kept alive (but logically deleted) until it is removed from the
 *      call stack: that is, it can no longer be referenced by name but any
 *      currently executing procedure that refers to it is allowed to do so
 *      until the procedure returns. If the namespace can't be found, this
 *      procedure returns an error. If no namespaces are specified, this
 *      command does nothing.
 *
 * Results:
 *      Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Deletes the specified namespaces. If anything goes wrong, this
 *      procedure returns an error message in the interpreter's
 *      result object.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceDeleteCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    char *name;
    register int i;
 
    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
        return TCL_ERROR;
    }
 
    /*
     * Destroying one namespace may cause another to be destroyed. Break
     * this into two passes: first check to make sure that all namespaces on
     * the command line are valid, and report any errors.
     */
 
    for (i = 2;  i < objc;  i++) {
        name = Tcl_GetStringFromObj(objv[i], (int *) NULL);
        namespacePtr = Tcl_FindNamespace(interp, name,
                (Tcl_Namespace *) NULL, /*flags*/ 0);
        if (namespacePtr == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "unknown namespace \"",
                    Tcl_GetStringFromObj(objv[i], (int *) NULL),
                    "\" in namespace delete command", (char *) NULL);
            return TCL_ERROR;
        }
    }
 
    /*
     * Okay, now delete each namespace.
     */
 
    for (i = 2;  i < objc;  i++) {
        name = Tcl_GetStringFromObj(objv[i], (int *) NULL);
        namespacePtr = Tcl_FindNamespace(interp, name,
            (Tcl_Namespace *) NULL, /* flags */ 0);
        if (namespacePtr) {
            Tcl_DeleteNamespace(namespacePtr);
        }
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceEvalCmd --
 *
 *      Invoked to implement the "namespace eval" command. Executes
 *      commands in a namespace. If the namespace does not already exist,
 *      it is created. Handles the following syntax:
 *
 *          namespace eval name arg ?arg...?
 *
 *      If more than one arg argument is specified, the command that is
 *      executed is the result of concatenating the arguments together with
 *      a space between each argument.
 *
 * Results:
 *      Returns TCL_OK if the namespace is found and the commands are
 *      executed successfully. Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns the result of the command in the interpreter's result
 *      object. If anything goes wrong, this procedure returns an error
 *      message as the result.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceEvalCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    Tcl_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, &frame, namespacePtr,
            /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
        return TCL_ERROR;
    }
 
    if (objc == 4) {
        result = Tcl_EvalObj(interp, objv[3]);
    } else {
        objPtr = Tcl_ConcatObj(objc-3, objv+3);
        result = Tcl_EvalObj(interp, objPtr);
        Tcl_DecrRefCount(objPtr);  /* we're done with the object */
    }
    if (result == TCL_ERROR) {
        char msg[256];
 
        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;
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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_GetStringFromObj(objv[firstArg], (int *) NULL);
        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_GetStringFromObj(objv[i], (int *) NULL);
        result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
                ((i == firstArg)? resetListFirst : 0));
        if (result != TCL_OK) {
            return result;
        }
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceForgetCmd --
 *
 *      Invoked to implement the "namespace forget" command to remove
 *      imported commands from a namespace. Handles the following syntax:
 *
 *          namespace forget ?pattern pattern...?
 *
 *      Each pattern is a name like "foo::*" or "a::b::x*". That is, the
 *      pattern may include the special pattern matching characters
 *      recognized by the "string match" command, but only in the command
 *      name at the end of the qualified name; the special pattern
 *      characters may not appear in a namespace name. All of the commands
 *      that match that pattern are checked to see if they have an imported
 *      command in the current namespace that refers to the matched
 *      command. If there is an alias, it is removed.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Imported commands are removed from the current namespace. If
 *      anything goes wrong, this procedure returns an error message in the
 *      interpreter's result object.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceForgetCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    char *pattern;
    register int i, result;
 
    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
        return TCL_ERROR;
    }
 
    for (i = 2;  i < objc;  i++) {
        pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL);
        result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern);
        if (result != TCL_OK) {
            return result;
        }
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceImportCmd --
 *
 *      Invoked to implement the "namespace import" command that imports
 *      commands into a namespace. Handles the following syntax:
 *
 *          namespace import ?-force? ?pattern pattern...?
 *
 *      Each pattern is a namespace-qualified name like "foo::*",
 *      "a::b::x*", or "bar::p". That is, the pattern may include the
 *      special pattern matching characters recognized by the "string match"
 *      command, but only in the command name at the end of the qualified
 *      name; the special pattern characters may not appear in a namespace
 *      name. All of the commands that match the pattern and which are
 *      exported from their namespace are made accessible from the current
 *      namespace context. This is done by creating a new "imported command"
 *      in the current namespace that points to the real command in its
 *      original namespace; when the imported command is called, it invokes
 *      the real command.
 *
 *      If an imported command conflicts with an existing command, it is
 *      treated as an error. But if the "-force" option is included, then
 *      existing commands are overwritten by the imported commands.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Adds imported commands to the current namespace. If anything goes
 *      wrong, this procedure returns an error message in the interpreter's
 *      result object.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceImportCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    int allowOverwrite = 0;
    char *string, *pattern;
    register int i, result;
    int firstArg;
 
    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 2, objv,
                "?-force? ?pattern pattern...?");
        return TCL_ERROR;
    }
 
    /*
     * Skip over the optional "-force" as the first argument.
     */
 
    firstArg = 2;
    if (firstArg < objc) {
        string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL);
        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_GetStringFromObj(objv[i], (int *) NULL);
        result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern,
                allowOverwrite);
        if (result != TCL_OK) {
            return result;
        }
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceInscopeCmd --
 *
 *      Invoked to implement the "namespace inscope" command that executes a
 *      script in the context of a particular namespace. This command is not
 *      expected to be used directly by programmers; calls to it are
 *      generated implicitly when programs use "namespace code" commands
 *      to register callback scripts. Handles the following syntax:
 *
 *          namespace inscope name arg ?arg...?
 *
 *      The "namespace inscope" command is much like the "namespace eval"
 *      command except that it has lappend semantics and the namespace must
 *      already exist. It treats the first argument as a list, and appends
 *      any arguments after the first onto the end as proper list elements.
 *      For example,
 *
 *          namespace inscope ::foo a b c d
 *
 *      is equivalent to
 *
 *          namespace eval ::foo [concat a [list b c d]]
 *
 *      This lappend semantics is important because many callback scripts
 *      are actually prefixes.
 *
 * Results:
 *      Returns TCL_OK to indicate success, or TCL_ERROR to indicate
 *      failure.
 *
 * Side effects:
 *      Returns a result in the Tcl interpreter's result object.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceInscopeCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    Tcl_CallFrame frame;
    int i, result;
 
    if (objc < 4) {
        Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
        return TCL_ERROR;
    }
 
    /*
     * Resolve the namespace reference.
     */
 
    result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
    if (result != TCL_OK) {
        return result;
    }
    if (namespacePtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown namespace \"",
                Tcl_GetStringFromObj(objv[2], (int *) NULL),
                "\" 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_EvalObj(interp, objv[3]);
    } 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_EvalObj(interp, cmdObjPtr);
 
        Tcl_DecrRefCount(cmdObjPtr);  /* we're done with the cmd object */
        Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }
    if (result == TCL_ERROR) {
        char msg[256];
 
        sprintf(msg,
            "\n    (in namespace inscope \"%.200s\" script line %d)",
            namespacePtr->fullName, interp->errorLine);
        Tcl_AddObjErrorInfo(interp, msg, -1);
    }
 
    /*
     * Restore the previous "current" namespace.
     */
 
    Tcl_PopCallFrame(interp);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceOriginCmd --
 *
 *      Invoked to implement the "namespace origin" command to return the
 *      fully-qualified name of the "real" command to which the specified
 *      "imported command" refers. Handles the following syntax:
 *
 *          namespace origin name
 *
 * Results:
 *      An imported command is created in an namespace when that namespace
 *      imports a command from another namespace. If a command is imported
 *      into a sequence of namespaces a, b,...,n where each successive
 *      namespace just imports the command from the previous namespace, this
 *      command returns the fully-qualified name of the original command in
 *      the first namespace, a. If "name" does not refer to an alias, its
 *      fully-qualified name is returned. The returned name is stored in the
 *      interpreter's result object. This procedure returns TCL_OK if
 *      successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      If anything goes wrong, this procedure returns an error message in
 *      the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceOriginCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Command command, origCommand;
 
    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "name");
        return TCL_ERROR;
    }
 
    command = Tcl_GetCommandFromObj(interp, objv[2]);
    if (command == (Tcl_Command) NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "invalid command name \"",
                Tcl_GetStringFromObj(objv[2], (int *) NULL),
                "\"", (char *) NULL);
        return TCL_ERROR;
    }
    origCommand = TclGetOriginalCommand(command);
    if (origCommand == (Tcl_Command) NULL) {
        /*
         * The specified command isn't an imported command. Return the
         * command's name qualified by the full name of the namespace it
         * was defined in.
         */
 
        Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp));
    } else {
        Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp));
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceParentCmd --
 *
 *      Invoked to implement the "namespace parent" command that returns the
 *      fully-qualified name of the parent namespace for a specified
 *      namespace. Handles the following syntax:
 *
 *          namespace parent ?name?
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceParentCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Namespace *nsPtr;
    int result;
 
    if (objc == 2) {
        nsPtr = Tcl_GetCurrentNamespace(interp);
    } else if (objc == 3) {
        result = GetNamespaceFromObj(interp, objv[2], &nsPtr);
        if (result != TCL_OK) {
            return result;
        }
        if (nsPtr == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "unknown namespace \"",
                    Tcl_GetStringFromObj(objv[2], (int *) NULL),
                    "\" in namespace parent command", (char *) NULL);
            return TCL_ERROR;
        }
    } else {
        Tcl_WrongNumArgs(interp, 2, objv, "?name?");
        return TCL_ERROR;
    }
 
    /*
     * Report the parent of the specified namespace.
     */
 
    if (nsPtr->parentPtr != NULL) {
        Tcl_SetStringObj(Tcl_GetObjResult(interp),
                nsPtr->parentPtr->fullName, -1);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceQualifiersCmd --
 *
 *      Invoked to implement the "namespace qualifiers" command that returns
 *      any leading namespace qualifiers in a string. These qualifiers are
 *      namespace names separated by "::"s. For example, for "::foo::p" this
 *      command returns "::foo", and for "::" it returns "". This command
 *      is the complement of the "namespace tail" command. Note that this
 *      command does not check whether the "namespace" names are, in fact,
 *      the names of currently defined namespaces. Handles the following
 *      syntax:
 *
 *          namespace qualifiers string
 *
 * Results:
 *      Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceQualifiersCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    register char *name, *p;
    int length;
 
    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "string");
        return TCL_ERROR;
    }
 
    /*
     * Find the end of the string, then work backward and find
     * the start of the last "::" qualifier.
     */
 
    name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
    for (p = name;  *p != '\0';  p++) {
        /* empty body */
    }
    while (--p >= name) {
        if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
            p -= 2;             /* back up over the :: */
            while ((p >= name) && (*p == ':')) {
                p--;            /* back up over the preceeding : */
            }
            break;
        }
    }
 
    if (p >= name) {
        length = p-name+1;
        Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceTailCmd --
 *
 *      Invoked to implement the "namespace tail" command that returns the
 *      trailing name at the end of a string with "::" namespace
 *      qualifiers. These qualifiers are namespace names separated by
 *      "::"s. For example, for "::foo::p" this command returns "p", and for
 *      "::" it returns "". This command is the complement of the "namespace
 *      qualifiers" command. Note that this command does not check whether
 *      the "namespace" names are, in fact, the names of currently defined
 *      namespaces. Handles the following syntax:
 *
 *          namespace tail string
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceTailCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    register char *name, *p;
 
    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "string");
        return TCL_ERROR;
    }
 
    /*
     * Find the end of the string, then work backward and find the
     * last "::" qualifier.
     */
 
    name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
    for (p = name;  *p != '\0';  p++) {
        /* empty body */
    }
    while (--p > name) {
        if ((*p == ':') && (*(p-1) == ':')) {
            p++;                /* just after the last "::" */
            break;
        }
    }
 
    if (p >= name) {
        Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceWhichCmd --
 *
 *      Invoked to implement the "namespace which" command that returns the
 *      fully-qualified name of a command or variable. If the specified
 *      command or variable does not exist, it returns "". Handles the
 *      following syntax:
 *
 *          namespace which ?-command? ?-variable? name
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If anything
 *      goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */
 
static int
NamespaceWhichCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];              /* Argument objects. */
{
    register char *arg;
    Tcl_Command cmd;
    Tcl_Var variable;
    int argIndex, lookup;
 
    if (objc < 3) {
        badArgs:
        Tcl_WrongNumArgs(interp, 2, objv,
                "?-command? ?-variable? name");
        return TCL_ERROR;
    }
 
    /*
     * Look for a flag controlling the lookup.
     */
 
    argIndex = 2;
    lookup = 0;                  /* assume command lookup by default */
    arg = Tcl_GetStringFromObj(objv[2], (int *) NULL);
    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_GetStringFromObj(objv[argIndex], (int *) NULL);
        variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL,
                /*flags*/ 0);
        if (variable != (Tcl_Var) NULL) {
            Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
        }
        break;
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * FreeNsNameInternalRep --
 *
 *      Frees the resources associated with a nsName object's internal
 *      representation.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Decrements the ref count of any Namespace structure pointed
 *      to by the nsName's internal representation. If there are no more
 *      references to the namespace, it's structure will be freed.
 *
 *----------------------------------------------------------------------
 */
 
static void
FreeNsNameInternalRep(objPtr)
    register Tcl_Obj *objPtr;   /* nsName object with internal
                                 * representation to free */
{
    register ResolvedNsName *resNamePtr =
        (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
    Namespace *nsPtr;
 
    /*
     * Decrement the reference count of the namespace. If there are no
     * more references, free it up.
     */
 
    if (resNamePtr != NULL) {
        resNamePtr->refCount--;
        if (resNamePtr->refCount == 0) {
 
            /*
             * Decrement the reference count for the cached namespace.  If
             * the namespace is dead, and there are no more references to
             * it, free it.
             */
 
            nsPtr = resNamePtr->nsPtr;
            nsPtr->refCount--;
            if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
                NamespaceFree(nsPtr);
            }
            ckfree((char *) resNamePtr);
        }
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * DupNsNameInternalRep --
 *
 *      Initializes the internal representation of a nsName object to a copy
 *      of the internal representation of another nsName object.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      copyPtr's internal rep is set to refer to the same namespace
 *      referenced by srcPtr's internal rep. Increments the ref count of
 *      the ResolvedNsName structure used to hold the namespace reference.
 *
 *----------------------------------------------------------------------
 */
 
static void
DupNsNameInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;                /* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr;      /* Object with internal rep to set. */
{
    register ResolvedNsName *resNamePtr =
        (ResolvedNsName *) srcPtr->internalRep.otherValuePtr;
 
    copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
    if (resNamePtr != NULL) {
        resNamePtr->refCount++;
    }
    copyPtr->typePtr = &tclNsNameType;
}
 
/*
 *----------------------------------------------------------------------
 *
 * SetNsNameFromAny --
 *
 *      Attempt to generate a nsName internal representation for a
 *      Tcl object.
 *
 * Results:
 *      Returns TCL_OK if the value could be converted to a proper
 *      namespace reference. Otherwise, it returns TCL_ERROR, along
 *      with an error message in the interpreter's result object.
 *
 * Side effects:
 *      If successful, the object is made a nsName object. Its internal rep
 *      is set to point to a ResolvedNsName, which contains a cached pointer
 *      to the Namespace. Reference counts are kept on both the
 *      ResolvedNsName and the Namespace, so we can keep track of their
 *      usage and free them when appropriate.
 *
 *----------------------------------------------------------------------
 */
 
static int
SetNsNameFromAny(interp, objPtr)
    Tcl_Interp *interp;         /* Points to the namespace in which to
                                 * resolve name. Also used for error
                                 * reporting if not NULL. */
    register Tcl_Obj *objPtr;   /* The object to convert. */
{
    register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
    char *name, *dummy;
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    register ResolvedNsName *resNamePtr;
    int flags, result;
 
    /*
     * Get the string representation. Make it up-to-date if necessary.
     */
 
    name = objPtr->bytes;
    if (name == NULL) {
        name = Tcl_GetStringFromObj(objPtr, (int *) NULL);
    }
 
    /*
     * 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.
     */
 
    flags = ((interp != NULL)? TCL_LEAVE_ERR_MSG : 0) | FIND_ONLY_NS;
    result = TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
            flags, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
    if (result != TCL_OK) {
        return result;
    }
 
    /*
     * If we found a namespace, then create a new ResolvedNsName structure
     * that holds a reference to it.
     */
 
    if (nsPtr != NULL) {
        Namespace *currNsPtr =
                (Namespace *) Tcl_GetCurrentNamespace(interp);
 
        nsPtr->refCount++;
        resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
        resNamePtr->nsPtr = nsPtr;
        resNamePtr->nsId = nsPtr->nsId;
        resNamePtr->refNsPtr = currNsPtr;
        resNamePtr->refCount = 1;
    } else {
        resNamePtr = NULL;
    }
 
    /*
     * Free the old internalRep before setting the new one.
     * We do this as late as possible to allow the conversion code
     * (in particular, Tcl_GetStringFromObj) to use that old internalRep.
     */
 
    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
        oldTypePtr->freeIntRepProc(objPtr);
    }
 
    objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
    objPtr->typePtr = &tclNsNameType;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfNsName --
 *
 *      Updates the string representation for a nsName object.
 *      Note: This procedure does not free an existing old string rep
 *      so storage will be lost if this has not already been done.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The object's string is set to a copy of the fully qualified
 *      namespace name.
 *
 *----------------------------------------------------------------------
 */
 
static void
UpdateStringOfNsName(objPtr)
    register Tcl_Obj *objPtr; /* nsName object with string rep to update. */
{
    ResolvedNsName *resNamePtr =
        (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
    register Namespace *nsPtr;
    char *name = "";
    int length;
 
    if ((resNamePtr != NULL)
            && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
        nsPtr = resNamePtr->nsPtr;
        if (nsPtr->flags & NS_DEAD) {
            nsPtr = NULL;
        }
        if (nsPtr != NULL) {
            name = nsPtr->fullName;
        }
    }
 
    /*
     * The following sets the string rep to an empty string on the heap
     * if the internal rep is NULL.
     */
 
    length = strlen(name);
    if (length == 0) {
        objPtr->bytes = tclEmptyStringRep;
    } else {
        objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
        memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length);
        objPtr->bytes[length] = '\0';
    }
    objPtr->length = length;
}
Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclNamesp.c] - Blame information for rev 1780

Line No.	Rev	Author	Line
1	578	markom	`/*`
2			`* tclNamesp.c --`
3			`*`
4			`* Contains support for namespaces, which provide a separate context of`
5			`* commands and global variables. The global :: namespace is the`
6			`* traditional Tcl "global" scope. Other namespaces are created as`
7			`* children of the global namespace. These other namespaces contain`
8			`* special-purpose commands and variables for packages.`
9			`*`
10			`* Copyright (c) 1993-1997 Lucent Technologies.`
11			`* Copyright (c) 1997 Sun Microsystems, Inc.`
12			`* Copyright (c) 1998 by Scriptics Corporation.`
13			`*`
14			`* Originally implemented by`
15			`* Michael J. McLennan`
16			`* Bell Labs Innovations for Lucent Technologies`
17			`* mmclennan@lucent.com`
18			`*`
19			`* See the file "license.terms" for information on usage and redistribution`
20			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
21			`*`
22			`* RCS: @(#) $Id: tclNamesp.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $`
23			`*/`
24
25			`#include "tclInt.h"`
26
27			`/*`
28			`* Flag passed to TclGetNamespaceForQualName to indicate that it should`
29			`* search for a namespace rather than a command or variable inside a`
30			`* namespace. Note that this flag's value must not conflict with the values`
31			`* of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN.`
32			`*/`
33
34			`#define FIND_ONLY_NS 0x1000`
35
36			`/*`
37			`* Initial sise of stack allocated space for tail list - used when resetting`
38			`* shadowed command references in the functin: TclResetShadowedCmdRefs.`
39			`*/`
40