tclinterp.c

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

		    if (index == OPT_SAFE) {
			safe = 1;
			continue;
		    }
		    i++;
		    last = 1;
		}
		if (slavePtr != NULL) {
		    Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
		    return TCL_ERROR;
		}
		slavePtr = objv[i];
	    }
	    buf[0] = '\0';
	    if (slavePtr == 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.
		 */
		
		for (i = 0; ; i++) {
		    Tcl_CmdInfo cmdInfo;
		    
		    sprintf(buf, "interp%d", i);
		    if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
			break;
		    }
		}
		slavePtr = Tcl_NewStringObj(buf, -1);
	    }
	    if (SlaveCreate(interp, slavePtr, safe) == NULL) {
		if (buf[0] != '\0') {
		    Tcl_DecrRefCount(slavePtr);
		}
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, slavePtr);
	    return TCL_OK;
	}
	case OPT_DELETE: {
	    int i;
	    InterpInfo *iiPtr;
	    Tcl_Interp *slaveInterp;
	    
	    for (i = 2; i < objc; i++) {
		slaveInterp = GetInterp(interp, objv[i]);
		if (slaveInterp == NULL) {
		    return TCL_ERROR;
		} else if (slaveInterp == interp) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			    "cannot delete the current interpreter",
			    (char *) NULL);
		    return TCL_ERROR;
		}
		iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
		Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
			iiPtr->slave.interpCmd);
	    }
	    return TCL_OK;
	}
	case OPT_EVAL: {
	    Tcl_Interp *slaveInterp;

	    if (objc < 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_EXISTS: {
	    int exists;
	    Tcl_Interp *slaveInterp;

	    exists = 1;
	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		if (objc > 3) {
		    return TCL_ERROR;
		}
		Tcl_ResetResult(interp);
		exists = 0;
	    }
	    Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
	    return TCL_OK;
	}
	case OPT_EXPOSE: {
	    Tcl_Interp *slaveInterp;

	    if ((objc < 4) || (objc > 5)) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path hiddenCmdName ?cmdName?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_HIDE: {
	    Tcl_Interp *slaveInterp;		/* A slave. */

	    if ((objc < 4) || (objc > 5)) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path cmdName ?hiddenCmdName?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_HIDDEN: {
	    Tcl_Interp *slaveInterp;		/* A slave. */

	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveHidden(interp, slaveInterp);
	}
	case OPT_ISSAFE: {
	    Tcl_Interp *slaveInterp;

	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
	    return TCL_OK;
	}
	case OPT_INVOKEHID: {
	    int i, index, global;
	    Tcl_Interp *slaveInterp;
	    static CONST char *hiddenOptions[] = {
		"-global",	"--",		NULL
	    };
	    enum hiddenOption {
		OPT_GLOBAL,	OPT_LAST
	    };

	    global = 0;
	    for (i = 3; i < objc; i++) {
		if (Tcl_GetString(objv[i])[0] != '-') {
		    break;
		}
		if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
			"option", 0, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (index == OPT_GLOBAL) {
		    global = 1;
		} else {
		    i++;
		    break;
		}
	    }
	    if (objc - i < 1) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path ?-global? ?--? cmd ?arg ..?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
		    objv + i);
	}
	case OPT_MARKTRUSTED: {
	    Tcl_Interp *slaveInterp;

	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "path");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveMarkTrusted(interp, slaveInterp);
	}
	case OPT_RECLIMIT: {
	    Tcl_Interp *slaveInterp;

	    if (objc != 3 && objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_SLAVES: {
	    Tcl_Interp *slaveInterp;
	    InterpInfo *iiPtr;
	    Tcl_Obj *resultPtr;
	    Tcl_HashEntry *hPtr;
	    Tcl_HashSearch hashSearch;
	    char *string;
	    
	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	    resultPtr = Tcl_GetObjResult(interp);
	    hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
	    for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
		string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
		Tcl_ListObjAppendElement(NULL, resultPtr,
			Tcl_NewStringObj(string, -1));
	    }
	    return TCL_OK;
	}
	case OPT_SHARE: {
	    Tcl_Interp *slaveInterp;		/* A slave. */
	    Tcl_Interp *masterInterp;		/* Its master. */
	    Tcl_Channel chan;

	    if (objc != 5) {
		Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
		return TCL_ERROR;
	    }
	    masterInterp = GetInterp(interp, objv[2]);
	    if (masterInterp == NULL) {
		return TCL_ERROR;
	    }
	    chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
		    NULL);
	    if (chan == NULL) {
		TclTransferResult(masterInterp, TCL_OK, interp);
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[4]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_RegisterChannel(slaveInterp, chan);
	    return TCL_OK;
	}
	case OPT_TARGET: {
	    Tcl_Interp *slaveInterp;
	    InterpInfo *iiPtr;
	    Tcl_HashEntry *hPtr;	
	    Alias *aliasPtr;		
	    char *aliasName;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path alias");
		return TCL_ERROR;
	    }

	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }

	    aliasName = Tcl_GetString(objv[3]);

	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
	    if (hPtr == NULL) {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			"alias \"", aliasName, "\" in path \"",
			Tcl_GetString(objv[2]), "\" not found",
			(char *) NULL);
		return TCL_ERROR;
	    }
	    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
	    if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
		Tcl_ResetResult(interp);
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			"target interpreter for alias \"", aliasName,
			"\" in path \"", Tcl_GetString(objv[2]),
			"\" is not my descendant", (char *) NULL);
		return TCL_ERROR;
	    }
	    return TCL_OK;
	}
	case OPT_TRANSFER: {
	    Tcl_Interp *slaveInterp;		/* A slave. */
	    Tcl_Interp *masterInterp;		/* Its master. */
	    Tcl_Channel chan;
		    
	    if (objc != 5) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"srcPath channelId destPath");
		return TCL_ERROR;
	    }
	    masterInterp = GetInterp(interp, objv[2]);
	    if (masterInterp == NULL) {
		return TCL_ERROR;
	    }
	    chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
	    if (chan == NULL) {
		TclTransferResult(masterInterp, TCL_OK, interp);
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[4]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_RegisterChannel(slaveInterp, chan);
	    if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
		TclTransferResult(masterInterp, TCL_OK, interp);
		return TCL_ERROR;
	    }
	    return TCL_OK;
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInterp2 --
 *
 *	Helper function for Tcl_InterpObjCmd() to convert the interp name
 *	potentially specified on the command line to an Tcl_Interp.
 *
 * Results:
 *	The return value is the interp specified on the command line,
 *	or the interp argument itself if no interp was specified on the
 *	command line.  If the interp could not be found or the wrong
 *	number of arguments was specified on the command line, the return
 *	value is NULL and an error message is left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
static Tcl_Interp *
GetInterp2(interp, objc, objv)
    Tcl_Interp *interp;		/* Default interp if no interp was specified
				 * on the command line. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    if (objc == 2) {
	return interp;
    } else if (objc == 3) {
	return GetInterp(interp, objv[2]);
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?path?");
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateAlias --
 *
 *	Creates an alias between two interpreters.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates a new alias, manipulates the result field of slaveInterp.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
    Tcl_Interp *slaveInterp;	/* Interpreter for source command. */
    CONST char *slaveCmd;	/* Command to install in slave. */
    Tcl_Interp *targetInterp;	/* Interpreter for target command. */
    CONST char *targetCmd;	/* Name of target command. */
    int argc;			/* How many additional arguments? */
    CONST char * CONST *argv;	/* These are the additional args. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    int i;
    int result;
    
    objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
        objv[i] = Tcl_NewStringObj(argv[i], -1);
        Tcl_IncrRefCount(objv[i]);
    }
    
    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
	    targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    ckfree((char *) objv);
    Tcl_DecrRefCount(targetObjPtr);
    Tcl_DecrRefCount(slaveObjPtr);

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateAliasObj --
 *
 *	Object version: Creates an alias between two interpreters.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates a new alias.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
    Tcl_Interp *slaveInterp;	/* Interpreter for source command. */
    CONST char *slaveCmd;	/* Command to install in slave. */
    Tcl_Interp *targetInterp;	/* Interpreter for target command. */
    CONST char *targetCmd;	/* Name of target command. */
    int objc;			/* How many additional arguments? */
    Tcl_Obj *CONST objv[];	/* Argument vector. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    int result;

    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,