tclinterp.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,256 行 · 第 1/5 页

    Alias *aliasPtr;	
    Tcl_Obj *prefixPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
        return TCL_OK;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
    Tcl_SetObjResult(interp, prefixPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasList --
 *
 *	Computes a list of aliases defined in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
AliasList(interp, slaveInterp)
    Tcl_Interp *interp;		/* Interp for data return. */
    Tcl_Interp *slaveInterp;	/* Interp whose aliases to compute. */
{
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch hashSearch;
    Tcl_Obj *resultPtr;	
    Alias *aliasPtr;
    Slave *slavePtr;

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    resultPtr = Tcl_GetObjResult(interp);

    entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
    for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
        aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
        Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmd --
 *
 *	This is the procedure that services invocations of aliases in a
 *	slave interpreter. One such command exists for each alias. When
 *	invoked, this procedure redirects the invocation to the target
 *	command in the master interpreter as designated by the Alias
 *	record associated with this command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Causes forwarding of the invocation; all possible side effects
 *	may occur as a result of invoking the command to which the
 *	invocation is forwarded.
 *
 *----------------------------------------------------------------------
 */

static int
AliasObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Alias record. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument vector. */	
{
#define ALIAS_CMDV_PREALLOC 10
    Tcl_Interp *targetInterp;	
    Alias *aliasPtr;		
    int result, prefc, cmdc;
    Tcl_Obj **prefv, **cmdv;
    Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
    aliasPtr = (Alias *) clientData;
    targetInterp = aliasPtr->targetInterp;

    /*
     * Append the arguments to the command prefix and invoke the command
     * in the target interp's global namespace.
     */
     
    prefc = aliasPtr->objc;
    prefv = &aliasPtr->objPtr;
    cmdc = prefc + objc - 1;
    if (cmdc <= ALIAS_CMDV_PREALLOC) {
	cmdv = cmdArr;
    } else {
	cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
    }

    prefv = &aliasPtr->objPtr;
    memcpy((VOID *) cmdv, (VOID *) prefv, 
            (size_t) (prefc * sizeof(Tcl_Obj *)));
    memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), 
	    (size_t) ((objc-1) * sizeof(Tcl_Obj *)));

    Tcl_ResetResult(targetInterp);

    if (targetInterp != interp) {
	Tcl_Preserve((ClientData) targetInterp);
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
	TclTransferResult(targetInterp, result, interp);	
	Tcl_Release((ClientData) targetInterp);
    } else {
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
    }

    if (cmdv != cmdArr) {
	ckfree((char *) cmdv);
    }
    return result;        
#undef ALIAS_CMDV_PREALLOC
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *
 *	Is invoked when an alias command is deleted in a slave. Cleans up
 *	all storage associated with this alias.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the alias record and its entry in the alias table for
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
AliasObjCmdDeleteProc(clientData)
    ClientData clientData;	/* The alias record for this alias. */
{
    Alias *aliasPtr;		
    Target *targetPtr;		
    int i;
    Tcl_Obj **objv;

    aliasPtr = (Alias *) clientData;
    
    Tcl_DecrRefCount(aliasPtr->namePtr);
    objv = &aliasPtr->objPtr;
    for (i = 0; i < aliasPtr->objc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);

    targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
    ckfree((char *) targetPtr);
    Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);

    ckfree((char *) aliasPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateSlave --
 *
 *	Creates a slave interpreter. The slavePath argument denotes the
 *	name of the new slave relative to the current interpreter; the
 *	slave is a direct descendant of the one-before-last component of
 *	the path, e.g. it is a descendant of the current interpreter if
 *	the slavePath argument contains only one component. Optionally makes
 *	the slave interpreter safe.
 *
 * Results:
 *	Returns the interpreter structure created, or NULL if an error
 *	occurred.
 *
 * Side effects:
 *	Creates a new interpreter and a new interpreter object command in
 *	the interpreter indicated by the slavePath argument.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateSlave(interp, slavePath, isSafe)
    Tcl_Interp *interp;		/* Interpreter to start search at. */
    CONST char *slavePath;	/* Name of slave to create. */
    int isSafe;			/* Should new slave be "safe" ? */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *slaveInterp;

    pathPtr = Tcl_NewStringObj(slavePath, -1);
    slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
    Tcl_DecrRefCount(pathPtr);

    return slaveInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetSlave --
 *
 *	Finds a slave interpreter by its path name.
 *
 * Results:
 *	Returns a Tcl_Interp * for the named interpreter or NULL if not
 *	found.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_GetSlave(interp, slavePath)
    Tcl_Interp *interp;		/* Interpreter to start search from. */
    CONST char *slavePath;	/* Path of slave to find. */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *slaveInterp;

    pathPtr = Tcl_NewStringObj(slavePath, -1);
    slaveInterp = GetInterp(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);

    return slaveInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMaster --
 *
 *	Finds the master interpreter of a slave interpreter.
 *
 * Results:
 *	Returns a Tcl_Interp * for the master interpreter or NULL if none.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_GetMaster(interp)
    Tcl_Interp *interp;		/* Get the master of this interpreter. */
{
    Slave *slavePtr;		/* Slave record of this interpreter. */

    if (interp == (Tcl_Interp *) NULL) {
        return NULL;
    }
    slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
    return slavePtr->masterInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInterpPath --
 *
 *	Sets the result of the asking interpreter to a proper Tcl list
 *	containing the names of interpreters between the asking and
 *	target interpreters. The target interpreter must be either the
 *	same as the asking interpreter or one of its slaves (including
 *	recursively).
 *
 * Results:
 *	TCL_OK if the target interpreter is the same as, or a descendant
 *	of, the asking interpreter; TCL_ERROR else. This way one can
 *	distinguish between the case where the asking and target interps
 *	are the same (an empty list is the result, and TCL_OK is returned)
 *	and when the target is not a descendant of the asking interpreter
 *	(in which case the Tcl result is an error message and the function
 *	returns TCL_ERROR).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInterpPath(askingInterp, targetInterp)
    Tcl_Interp *askingInterp;	/* Interpreter to start search from. */
    Tcl_Interp *targetInterp;	/* Interpreter to find. */
{
    InterpInfo *iiPtr;
    
    if (targetInterp == askingInterp) {
        return TCL_OK;
    }
    if (targetInterp == NULL) {
	return TCL_ERROR;
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
        return TCL_ERROR;
    }
    Tcl_AppendElement(askingInterp,
	    Tcl_GetHashKey(&iiPtr->master.slaveTable,
		    iiPtr->slave.slaveEntryPtr));
    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, pathPtr)
    Tcl_Interp *interp;		/* Interp. to start search from. */
    Tcl_Obj *pathPtr;		/* List object containing name of interp. to 
				 * be found. */
{
    Tcl_HashEntry *hPtr;	/* Search element. */
    Slave *slavePtr;		/* Interim slave record. */
    Tcl_Obj **objv;
    int objc, i;	
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */
    InterpInfo *masterInfoPtr;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }

    searchInterp = interp;
    for (i = 0; i < objc; i++) {
	masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
        hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
		Tcl_GetString(objv[i]));
        if (hPtr == NULL) {
	    searchInterp = NULL;
	    break;
	}
        slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
        searchInterp = slavePtr->slaveInterp;
        if (searchInterp == NULL) {
	    break;
	}
    }
    if (searchInterp == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"could not find interpreter \"",
                Tcl_GetString(pathPtr), "\"", (char *) NULL);
    }
    return searchInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCreate --
 *
 *	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 *
SlaveCreate(interp, pathPtr, safe)
    Tcl_Interp *interp;		/* Interp. to start search from. */
    Tcl_Obj *pathPtr;		/* Path (name) of slave to create. */
    int safe;			/* Should we make it "safe"? */
{
    Tcl_Interp *masterInterp, *slaveInterp;
    Slave *slavePtr;
    InterpInfo *masterInfoPtr;
    Tcl_HashEntry *hPtr;
    char *path;
    int new, objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }
    if (objc < 2) {
	masterInterp = interp;
	path = Tcl_GetString(pathPtr);
    } else {
	Tcl_Obj *objPtr;
	
	objPtr = Tcl_NewListObj(objc - 1, objv);
	masterInterp = GetInterp(interp, objPtr);
	Tcl_DecrRefCount(objPtr);
	if (masterInterp == NULL) {
	    return NULL;
	}
	path = Tcl_GetString(objv[objc - 1]);
    }
    if (safe == 0) {
	safe = Tcl_IsSafe(masterInterp);
    }

    masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
    hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
    if (new == 0) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "interpreter named \"", path,
		"\" already exists, cannot create", (char *) NULL);
        return NULL;
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,