tclnamesp.c

linux系统下的音频通信

/*
 * 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
 *   [e-mail]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tclNamesp.c 1.7 98/08/13 13:43:41
 */

#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);