tclinterp.c

linux系统下的音频通信

    /* 
     * Remove unsafe parts of tcl_platform
     */

    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);

    /*
     * Unset path informations variables
     * (the only one remaining is [info nameofexecutable])
     */

    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
    
    /*
     * Remove the standard channels from the interpreter; safe interpreters
     * do not ordinarily have access to stdin, stdout and stderr.
     *
     * NOTE: These channels are not added to the interpreter by the
     * Tcl_CreateInterp call, but may be added later, by another I/O
     * operation. We want to ensure that the interpreter does not have
     * these channels even if it is being made safe after being used for
     * some time..
     */

    chan = Tcl_GetStdChannel(TCL_STDIN);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDOUT);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDERR);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --
 *
 *	Helper function to find a slave interpreter given a pathname.
 *
 * Results:
 *	Returns the slave interpreter known by that name in the calling
 *	interpreter, or NULL if no interpreter known by that name exists. 
 *
 * Side effects:
 *	Assigns to the pointer variable passed in, if not NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
GetInterp(interp, masterPtr, path, masterPtrPtr)
    Tcl_Interp *interp;		/* Interp. to start search from. */
    Master *masterPtr;		/* Its master record. */
    char *path;			/* The path (name) of interp. to be found. */
    Master **masterPtrPtr;	/* (Return) its master record. */
{
    Tcl_HashEntry *hPtr;	/* Search element. */
    Slave *slavePtr;		/* Interim slave record. */
    char **argv;		/* Split-up path (name) for interp to find. */
    int argc, i;		/* Loop indices. */
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */

    if (masterPtrPtr != (Master **) NULL) {
        *masterPtrPtr = masterPtr;
    }
    
    if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) {
        return (Tcl_Interp *) NULL;
    }

    for (searchInterp = interp, i = 0; i < argc; i++) {
        
        hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]);
        if (hPtr == (Tcl_HashEntry *) NULL) {
            ckfree((char *) argv);
            return (Tcl_Interp *) NULL;
        }
        slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
        searchInterp = slavePtr->slaveInterp;
        if (searchInterp == (Tcl_Interp *) NULL) {
            ckfree((char *) argv);
            return (Tcl_Interp *) NULL;
        }
        masterPtr = (Master *) Tcl_GetAssocData(searchInterp,
                "tclMasterRecord", NULL);
        if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr;
        if (masterPtr == (Master *) NULL) {
            ckfree((char *) argv);
            return (Tcl_Interp *) NULL;
        }
    }
    ckfree((char *) argv);
    return searchInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSlave --
 *
 *	Helper function to do the actual work of creating a slave interp
 *	and new object command. Also optionally makes the new slave
 *	interpreter "safe".
 *
 * Results:
 *	Returns the new Tcl_Interp * if successful or NULL if not. If failed,
 *	the result of the invoking interpreter contains an error message.
 *
 * Side effects:
 *	Creates a new slave interpreter and a new object command.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
CreateSlave(interp, masterPtr, slavePath, safe)
    Tcl_Interp *interp;			/* Interp. to start search from. */
    Master *masterPtr;			/* Master record. */
    char *slavePath;			/* Path (name) of slave to create. */
    int safe;				/* Should we make it "safe"? */
{
    Tcl_Interp *slaveInterp;		/* Ptr to slave interpreter. */
    Tcl_Interp *masterInterp;		/* Ptr to master interp for slave. */
    Slave *slavePtr;			/* Slave record. */
    Tcl_HashEntry *hPtr;		/* Entry into interp hashtable. */
    int new;				/* Indicates whether new entry. */
    int argc;				/* Count of elements in slavePath. */
    char **argv;			/* Elements in slavePath. */
    char *masterPath;			/* Path to its master. */

    if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) {
        return (Tcl_Interp *) NULL;
    }

    if (argc < 2) {
        masterInterp = interp;
        if (argc == 1) {
            slavePath = argv[0];
        }
    } else {
        masterPath = Tcl_Merge(argc-1, argv);
        masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
        if (masterInterp == (Tcl_Interp *) NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "interpreter named \"", masterPath,
                    "\" not found", (char *) NULL);
            ckfree((char *) argv);
            ckfree((char *) masterPath);
            return (Tcl_Interp *) NULL;
        }
        ckfree((char *) masterPath);
        slavePath = argv[argc-1];
        if (!safe) {
            safe = Tcl_IsSafe(masterInterp);
        }
    }
    hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
    if (new == 0) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "interpreter named \"", slavePath,
                "\" already exists, cannot create", (char *) NULL);
        ckfree((char *) argv);
        return (Tcl_Interp *) NULL;
    }
    slaveInterp = Tcl_CreateInterp();
    if (slaveInterp == (Tcl_Interp *) NULL) {
        panic("CreateSlave: out of memory while creating a new interpreter");
    }
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntry = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath,
            SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc);
    Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
    (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
            SlaveRecordDeleteProc, (ClientData) slavePtr);
    Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
    
    /*
     * Inherit the recursion limit.
     */
    ((Interp *)slaveInterp)->maxNestingDepth =
	((Interp *)masterInterp)->maxNestingDepth ;

    if (safe) {
        if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
            goto error;
        }
    } else {
        if (Tcl_Init(slaveInterp) == TCL_ERROR) {
            goto error;
        }
    }

    ckfree((char *) argv);
    return slaveInterp;

error:

    Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *)
            NULL, TCL_GLOBAL_ONLY));
    Tcl_SetVar2(interp, "errorCode", (char *) NULL,
            Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL,
                    TCL_GLOBAL_ONLY),
            TCL_GLOBAL_ONLY);

    Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
    Tcl_ResetResult(slaveInterp);

    (void) Tcl_DeleteCommand(masterInterp, slavePath);

    ckfree((char *) argv);
    return (Tcl_Interp *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateInterpObject -
 *
 *	Helper function to do the actual work of creating a new interpreter
 *	and an object command. 
 *
 * Results:
 *	A Tcl result.
 *
 * Side effects:
 *	See user documentation for details.
 *
 *----------------------------------------------------------------------
 */

static int
CreateInterpObject(interp, masterPtr, objc, objv)
    Tcl_Interp *interp;			/* Invoking interpreter. */
    Master *masterPtr;			/* Master record for same. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* with alias. */
{
    int safe;				/* Create a safe interpreter? */
    int moreFlags;			/* Expecting more flag args? */
    char *string;			/* Local pointer to object string. */
    char *slavePath;			/* Name of slave. */
    char localSlaveName[200];		/* Local area for creating names. */
    int i;				/* Loop counter. */
    int len;				/* Length of option argument. */
    static int interpCounter = 0;	/* Unique id for created names. */

    moreFlags = 1;
    slavePath = NULL;
    safe = Tcl_IsSafe(interp);
    
    if ((objc < 2) || (objc > 5)) {
        Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
        return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
        string = Tcl_GetStringFromObj(objv[i], &len);
        if ((string[0] == '-') && (moreFlags != 0)) {
            if ((string[1] == 's') &&
                (strncmp(string, "-safe", (size_t) len) == 0) &&
                (len > 1)){
                safe = 1;
            } else if ((strncmp(string, "--", (size_t) len) == 0) &&
                       (len > 1)) {
                moreFlags = 0;
            } else {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "bad option \"", string, "\": should be -safe",
                        (char *) NULL);
                return TCL_ERROR;
            }
        } else {
            slavePath = string;
        }
    }
    if (slavePath == (char *) NULL) {

        /*
         * Create an anonymous interpreter -- we choose its name and
         * the name of the command. We check that the command name that
         * we use for the interpreter does not collide with an existing
         * command in the master interpreter.
         */
        
        while (1) {
            Tcl_CmdInfo cmdInfo;
            
            sprintf(localSlaveName, "interp%d", interpCounter);
            interpCounter++;
            if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
                break;
            }
        }
        slavePath = localSlaveName;
    }
    if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1));
        return TCL_OK;
    } else {
        /*
         * CreateSlave already set the result if there was an error,
         * so we do not do it here.
         */
        return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteOneInterpObject --
 *
 *	Helper function for DeleteInterpObject. It deals with deleting one
 *	interpreter at a time.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Deletes an interpreter and its interpreter object command.
 *
 *----------------------------------------------------------------------
 */

static int
DeleteOneInterpObject(interp, masterPtr, path)
    Tcl_Interp *interp;			/* Interpreter for reporting errors. */
    Master *masterPtr;			/* Interim storage for master record.*/
    char *path;				/* Path of interpreter to delete. */
{
    Slave *slavePtr;			/* Interim storage for slave record. */
    Tcl_Interp *masterInterp;		/* Master of interp. to delete. */
    Tcl_HashEntry *hPtr;		/* Search element. */
    int localArgc;			/* Local copy of count of elements in
                                         * path (name) of interp. to delete. */
    char **localArgv;			/* Local copy of path. */
    char *slaveName;			/* Last component in path. */
    char *masterPath;			/* One-before-last component in path.*/

    if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad interpreter path \"", path, "\"", (char *) NULL);
        return TCL_ERROR;
    }
    if (localArgc < 2) {
        masterInterp = interp;
        if (localArgc == 0) {
            slaveName = "";
        } else {
            slaveName = localArgv[0];
        }
    } else {
        masterPath = Tcl_Merge(localArgc-1, localArgv);
        masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
        if (masterInterp == (Tcl_Interp *) NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "interpreter named \"", masterPath, "\" not found",
                    (char *) NULL);
            ckfree((char *) localArgv);
            ckfree((char *) masterPath);
            return TCL_ERROR;
        }
        ckfree((char *) masterPath);
        slaveName = localArgv[localArgc-1];
    }
    hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        ckfree((char *) localArgv);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "interpreter named \"", path, "\" not found", (char *) NULL);
        return TCL_ERROR;
    }
    slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
    if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) {