sl@0: /* sl@0: * tclInterp.c -- sl@0: * sl@0: * This file implements the "interp" command which allows creation sl@0: * and manipulation of Tcl interpreters from within Tcl scripts. sl@0: * sl@0: * Copyright (c) 1995-1997 Sun Microsystems, Inc. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclInterp.c,v 1.20.2.3 2006/11/28 22:20:02 andreas_kupries Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #include sl@0: sl@0: /* sl@0: * Counter for how many aliases were created (global) sl@0: */ sl@0: sl@0: static int aliasCounter = 0; sl@0: TCL_DECLARE_MUTEX(cntMutex) sl@0: sl@0: /* sl@0: * struct Alias: sl@0: * sl@0: * Stores information about an alias. Is stored in the slave interpreter sl@0: * and used by the source command to find the target command in the master sl@0: * when the source command is invoked. sl@0: */ sl@0: sl@0: typedef struct Alias { sl@0: Tcl_Obj *namePtr; /* Name of alias command in slave interp. */ sl@0: Tcl_Interp *targetInterp; /* Interp in which target command will be sl@0: * invoked. */ sl@0: Tcl_Command slaveCmd; /* Source command in slave interpreter, sl@0: * bound to command that invokes the target sl@0: * command in the target interpreter. */ sl@0: Tcl_HashEntry *aliasEntryPtr; sl@0: /* Entry for the alias hash table in slave. sl@0: * This is used by alias deletion to remove sl@0: * the alias from the slave interpreter sl@0: * alias table. */ sl@0: Tcl_HashEntry *targetEntryPtr; sl@0: /* Entry for target command in master. sl@0: * This is used in the master interpreter to sl@0: * map back from the target command to aliases sl@0: * redirecting to it. Random access to this sl@0: * hash table is never required - we are using sl@0: * a hash table only for convenience. */ sl@0: int objc; /* Count of Tcl_Obj in the prefix of the sl@0: * target command to be invoked in the sl@0: * target interpreter. Additional arguments sl@0: * specified when calling the alias in the sl@0: * slave interp will be appended to the prefix sl@0: * before the command is invoked. */ sl@0: Tcl_Obj *objPtr; /* The first actual prefix object - the target sl@0: * command name; this has to be at the end of the sl@0: * structure, which will be extended to accomodate sl@0: * the remaining objects in the prefix. */ sl@0: } Alias; sl@0: sl@0: /* sl@0: * sl@0: * struct Slave: sl@0: * sl@0: * Used by the "interp" command to record and find information about slave sl@0: * interpreters. Maps from a command name in the master to information about sl@0: * a slave interpreter, e.g. what aliases are defined in it. sl@0: */ sl@0: sl@0: typedef struct Slave { sl@0: Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ sl@0: Tcl_HashEntry *slaveEntryPtr; sl@0: /* Hash entry in masters slave table for sl@0: * this slave interpreter. Used to find sl@0: * this record, and used when deleting the sl@0: * slave interpreter to delete it from the sl@0: * master's table. */ sl@0: Tcl_Interp *slaveInterp; /* The slave interpreter. */ sl@0: Tcl_Command interpCmd; /* Interpreter object command. */ sl@0: Tcl_HashTable aliasTable; /* Table which maps from names of commands sl@0: * in slave interpreter to struct Alias sl@0: * defined below. */ sl@0: } Slave; sl@0: sl@0: /* sl@0: * struct Target: sl@0: * sl@0: * Maps from master interpreter commands back to the source commands in slave sl@0: * interpreters. This is needed because aliases can be created between sibling sl@0: * interpreters and must be deleted when the target interpreter is deleted. In sl@0: * case they would not be deleted the source interpreter would be left with a sl@0: * "dangling pointer". One such record is stored in the Master record of the sl@0: * master interpreter (in the targetTable hashtable, see below) with the sl@0: * master for each alias which directs to a command in the master. These sl@0: * records are used to remove the source command for an from a slave if/when sl@0: * the master is deleted. sl@0: */ sl@0: sl@0: typedef struct Target { sl@0: Tcl_Command slaveCmd; /* Command for alias in slave interp. */ sl@0: Tcl_Interp *slaveInterp; /* Slave Interpreter. */ sl@0: } Target; sl@0: sl@0: /* sl@0: * struct Master: sl@0: * sl@0: * This record is used for two purposes: First, slaveTable (a hashtable) sl@0: * maps from names of commands to slave interpreters. This hashtable is sl@0: * used to store information about slave interpreters of this interpreter, sl@0: * to map over all slaves, etc. The second purpose is to store information sl@0: * about all aliases in slaves (or siblings) which direct to target commands sl@0: * in this interpreter (using the targetTable hashtable). sl@0: * sl@0: * NB: the flags field in the interp structure, used with SAFE_INTERP sl@0: * mask denotes whether the interpreter is safe or not. Safe sl@0: * interpreters have restricted functionality, can only create safe slave sl@0: * interpreters and can only load safe extensions. sl@0: */ sl@0: sl@0: typedef struct Master { sl@0: Tcl_HashTable slaveTable; /* Hash table for slave interpreters. sl@0: * Maps from command names to Slave records. */ sl@0: Tcl_HashTable targetTable; /* Hash table for Target Records. Contains sl@0: * all Target records which denote aliases sl@0: * from slaves or sibling interpreters that sl@0: * direct to commands in this interpreter. This sl@0: * table is used to remove dangling pointers sl@0: * from the slave (or sibling) interpreters sl@0: * when this interpreter is deleted. */ sl@0: } Master; sl@0: sl@0: /* sl@0: * The following structure keeps track of all the Master and Slave information sl@0: * on a per-interp basis. sl@0: */ sl@0: sl@0: typedef struct InterpInfo { sl@0: Master master; /* Keeps track of all interps for which this sl@0: * interp is the Master. */ sl@0: Slave slave; /* Information necessary for this interp to sl@0: * function as a slave. */ sl@0: } InterpInfo; sl@0: sl@0: /* sl@0: * Prototypes for local static procedures: sl@0: */ sl@0: sl@0: static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, sl@0: Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, Tcl_Obj *namePtr)); sl@0: static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); sl@0: static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp)); sl@0: static int AliasObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *currentInterp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static void AliasObjCmdDeleteProc _ANSI_ARGS_(( sl@0: ClientData clientData)); sl@0: sl@0: static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *pathPtr)); sl@0: static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static void InterpInfoDeleteProc _ANSI_ARGS_(( sl@0: ClientData clientData, Tcl_Interp *interp)); sl@0: static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *pathPtr, int safe)); sl@0: static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp)); sl@0: static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, int global, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp)); sl@0: static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( sl@0: ClientData clientData)); sl@0: static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Interp *slaveInterp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclInterpInit -- sl@0: * sl@0: * Initializes the invoking interpreter for using the master, slave sl@0: * and safe interp facilities. This is called from inside sl@0: * Tcl_CreateInterp(). sl@0: * sl@0: * Results: sl@0: * Always returns TCL_OK for backwards compatibility. sl@0: * sl@0: * Side effects: sl@0: * Adds the "interp" command to an interpreter and initializes the sl@0: * interpInfoPtr field of the invoking interpreter. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclInterpInit(interp) sl@0: Tcl_Interp *interp; /* Interpreter to initialize. */ sl@0: { sl@0: InterpInfo *interpInfoPtr; sl@0: Master *masterPtr; sl@0: Slave *slavePtr; sl@0: sl@0: interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); sl@0: ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; sl@0: sl@0: masterPtr = &interpInfoPtr->master; sl@0: Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); sl@0: Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS); sl@0: sl@0: slavePtr = &interpInfoPtr->slave; sl@0: slavePtr->masterInterp = NULL; sl@0: slavePtr->slaveEntryPtr = NULL; sl@0: slavePtr->slaveInterp = interp; sl@0: slavePtr->interpCmd = NULL; sl@0: Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); sl@0: sl@0: Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); sl@0: sl@0: Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * InterpInfoDeleteProc -- sl@0: * sl@0: * Invoked when an interpreter is being deleted. It releases all sl@0: * storage used by the master/slave/safe interpreter facilities. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Cleans up storage. Sets the interpInfoPtr field of the interp sl@0: * to NULL. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: InterpInfoDeleteProc(clientData, interp) sl@0: ClientData clientData; /* Ignored. */ sl@0: Tcl_Interp *interp; /* Interp being deleted. All commands for sl@0: * slave interps should already be deleted. */ sl@0: { sl@0: InterpInfo *interpInfoPtr; sl@0: Slave *slavePtr; sl@0: Master *masterPtr; sl@0: Tcl_HashSearch hSearch; sl@0: Tcl_HashEntry *hPtr; sl@0: Target *targetPtr; sl@0: sl@0: interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; sl@0: sl@0: /* sl@0: * There shouldn't be any commands left. sl@0: */ sl@0: sl@0: masterPtr = &interpInfoPtr->master; sl@0: if (masterPtr->slaveTable.numEntries != 0) { sl@0: panic("InterpInfoDeleteProc: still exist commands"); sl@0: } sl@0: Tcl_DeleteHashTable(&masterPtr->slaveTable); sl@0: sl@0: /* sl@0: * Tell any interps that have aliases to this interp that they should sl@0: * delete those aliases. If the other interp was already dead, it sl@0: * would have removed the target record already. sl@0: */ sl@0: sl@0: hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch); sl@0: while (hPtr != NULL) { sl@0: targetPtr = (Target *) Tcl_GetHashValue(hPtr); sl@0: Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, sl@0: targetPtr->slaveCmd); sl@0: hPtr = Tcl_NextHashEntry(&hSearch); sl@0: } sl@0: Tcl_DeleteHashTable(&masterPtr->targetTable); sl@0: sl@0: slavePtr = &interpInfoPtr->slave; sl@0: if (slavePtr->interpCmd != NULL) { sl@0: /* sl@0: * Tcl_DeleteInterp() was called on this interpreter, rather sl@0: * "interp delete" or the equivalent deletion of the command in the sl@0: * master. First ensure that the cleanup callback doesn't try to sl@0: * delete the interp again. sl@0: */ sl@0: sl@0: slavePtr->slaveInterp = NULL; sl@0: Tcl_DeleteCommandFromToken(slavePtr->masterInterp, sl@0: slavePtr->interpCmd); sl@0: } sl@0: sl@0: /* sl@0: * There shouldn't be any aliases left. sl@0: */ sl@0: sl@0: if (slavePtr->aliasTable.numEntries != 0) { sl@0: panic("InterpInfoDeleteProc: still exist aliases"); sl@0: } sl@0: Tcl_DeleteHashTable(&slavePtr->aliasTable); sl@0: sl@0: ckfree((char *) interpInfoPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_InterpObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "interp" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_InterpObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Unused. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int index; sl@0: static CONST char *options[] = { sl@0: "alias", "aliases", "create", "delete", sl@0: "eval", "exists", "expose", "hide", sl@0: "hidden", "issafe", "invokehidden", "marktrusted", sl@0: "recursionlimit", "slaves", "share", sl@0: "target", "transfer", sl@0: NULL sl@0: }; sl@0: enum option { sl@0: OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE, sl@0: OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, sl@0: OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED, sl@0: OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, sl@0: OPT_TARGET, OPT_TRANSFER sl@0: }; sl@0: sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum option) index) { sl@0: case OPT_ALIAS: { sl@0: Tcl_Interp *slaveInterp, *masterInterp; sl@0: sl@0: if (objc < 4) { sl@0: aliasArgs: sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (objc == 4) { sl@0: return AliasDescribe(interp, slaveInterp, objv[3]); sl@0: } sl@0: if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { sl@0: return AliasDelete(interp, slaveInterp, objv[3]); sl@0: } sl@0: if (objc > 5) { sl@0: masterInterp = GetInterp(interp, objv[4]); sl@0: if (masterInterp == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetString(objv[5])[0] == '\0') { sl@0: if (objc == 6) { sl@0: return AliasDelete(interp, slaveInterp, objv[3]); sl@0: } sl@0: } else { sl@0: return AliasCreate(interp, slaveInterp, masterInterp, sl@0: objv[3], objv[5], objc - 6, objv + 6); sl@0: } sl@0: } sl@0: goto aliasArgs; sl@0: } sl@0: case OPT_ALIASES: { sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: slaveInterp = GetInterp2(interp, objc, objv); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return AliasList(interp, slaveInterp); sl@0: } sl@0: case OPT_CREATE: { sl@0: int i, last, safe; sl@0: Tcl_Obj *slavePtr; sl@0: char buf[16 + TCL_INTEGER_SPACE]; sl@0: static CONST char *options[] = { sl@0: "-safe", "--", NULL sl@0: }; sl@0: enum option { sl@0: OPT_SAFE, OPT_LAST sl@0: }; sl@0: sl@0: safe = Tcl_IsSafe(interp); sl@0: sl@0: /* sl@0: * Weird historical rules: "-safe" is accepted at the end, too. sl@0: */ sl@0: sl@0: slavePtr = NULL; sl@0: last = 0; sl@0: for (i = 2; i < objc; i++) { sl@0: if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", sl@0: 0, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index == OPT_SAFE) { sl@0: safe = 1; sl@0: continue; sl@0: } sl@0: i++; sl@0: last = 1; sl@0: } sl@0: if (slavePtr != NULL) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (i < objc) { sl@0: slavePtr = objv[i]; sl@0: } sl@0: } sl@0: buf[0] = '\0'; sl@0: if (slavePtr == NULL) { sl@0: /* sl@0: * Create an anonymous interpreter -- we choose its name and sl@0: * the name of the command. We check that the command name sl@0: * that we use for the interpreter does not collide with an sl@0: * existing command in the master interpreter. sl@0: */ sl@0: sl@0: for (i = 0; ; i++) { sl@0: Tcl_CmdInfo cmdInfo; sl@0: sl@0: sprintf(buf, "interp%d", i); sl@0: if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { sl@0: break; sl@0: } sl@0: } sl@0: slavePtr = Tcl_NewStringObj(buf, -1); sl@0: } sl@0: if (SlaveCreate(interp, slavePtr, safe) == NULL) { sl@0: if (buf[0] != '\0') { sl@0: Tcl_DecrRefCount(slavePtr); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, slavePtr); sl@0: return TCL_OK; sl@0: } sl@0: case OPT_DELETE: { sl@0: int i; sl@0: InterpInfo *iiPtr; sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: for (i = 2; i < objc; i++) { sl@0: slaveInterp = GetInterp(interp, objv[i]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } else if (slaveInterp == interp) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "cannot delete the current interpreter", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; sl@0: Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, sl@0: iiPtr->slave.interpCmd); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: case OPT_EVAL: { sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); sl@0: } sl@0: case OPT_EXISTS: { sl@0: int exists; sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: exists = 1; sl@0: slaveInterp = GetInterp2(interp, objc, objv); sl@0: if (slaveInterp == NULL) { sl@0: if (objc > 3) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_ResetResult(interp); sl@0: exists = 0; sl@0: } sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), exists); sl@0: return TCL_OK; sl@0: } sl@0: case OPT_EXPOSE: { sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: if ((objc < 4) || (objc > 5)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "path hiddenCmdName ?cmdName?"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); sl@0: } sl@0: case OPT_HIDE: { sl@0: Tcl_Interp *slaveInterp; /* A slave. */ sl@0: sl@0: if ((objc < 4) || (objc > 5)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "path cmdName ?hiddenCmdName?"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); sl@0: } sl@0: case OPT_HIDDEN: { sl@0: Tcl_Interp *slaveInterp; /* A slave. */ sl@0: sl@0: slaveInterp = GetInterp2(interp, objc, objv); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveHidden(interp, slaveInterp); sl@0: } sl@0: case OPT_ISSAFE: { sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: slaveInterp = GetInterp2(interp, objc, objv); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp)); sl@0: return TCL_OK; sl@0: } sl@0: case OPT_INVOKEHID: { sl@0: int i, index, global; sl@0: Tcl_Interp *slaveInterp; sl@0: static CONST char *hiddenOptions[] = { sl@0: "-global", "--", NULL sl@0: }; sl@0: enum hiddenOption { sl@0: OPT_GLOBAL, OPT_LAST sl@0: }; sl@0: sl@0: global = 0; sl@0: for (i = 3; i < objc; i++) { sl@0: if (Tcl_GetString(objv[i])[0] != '-') { sl@0: break; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, sl@0: "option", 0, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index == OPT_GLOBAL) { sl@0: global = 1; sl@0: } else { sl@0: i++; sl@0: break; sl@0: } sl@0: } sl@0: if (objc - i < 1) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "path ?-global? ?--? cmd ?arg ..?"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveInvokeHidden(interp, slaveInterp, global, objc - i, sl@0: objv + i); sl@0: } sl@0: case OPT_MARKTRUSTED: { sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "path"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveMarkTrusted(interp, slaveInterp); sl@0: } sl@0: case OPT_RECLIMIT: { sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: if (objc != 3 && objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); sl@0: } sl@0: case OPT_SLAVES: { sl@0: Tcl_Interp *slaveInterp; sl@0: InterpInfo *iiPtr; sl@0: Tcl_Obj *resultPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch hashSearch; sl@0: char *string; sl@0: sl@0: slaveInterp = GetInterp2(interp, objc, objv); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); sl@0: for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { sl@0: string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); sl@0: Tcl_ListObjAppendElement(NULL, resultPtr, sl@0: Tcl_NewStringObj(string, -1)); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: case OPT_SHARE: { sl@0: Tcl_Interp *slaveInterp; /* A slave. */ sl@0: Tcl_Interp *masterInterp; /* Its master. */ sl@0: Tcl_Channel chan; sl@0: sl@0: if (objc != 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); sl@0: return TCL_ERROR; sl@0: } sl@0: masterInterp = GetInterp(interp, objv[2]); sl@0: if (masterInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), sl@0: NULL); sl@0: if (chan == NULL) { sl@0: TclTransferResult(masterInterp, TCL_OK, interp); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[4]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_RegisterChannel(slaveInterp, chan); sl@0: return TCL_OK; sl@0: } sl@0: case OPT_TARGET: { sl@0: Tcl_Interp *slaveInterp; sl@0: InterpInfo *iiPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Alias *aliasPtr; sl@0: char *aliasName; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "path alias"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: slaveInterp = GetInterp(interp, objv[2]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: aliasName = Tcl_GetString(objv[3]); sl@0: sl@0: iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; sl@0: hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); sl@0: if (hPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "alias \"", aliasName, "\" in path \"", sl@0: Tcl_GetString(objv[2]), "\" not found", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); sl@0: if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "target interpreter for alias \"", aliasName, sl@0: "\" in path \"", Tcl_GetString(objv[2]), sl@0: "\" is not my descendant", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: case OPT_TRANSFER: { sl@0: Tcl_Interp *slaveInterp; /* A slave. */ sl@0: Tcl_Interp *masterInterp; /* Its master. */ sl@0: Tcl_Channel chan; sl@0: sl@0: if (objc != 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "srcPath channelId destPath"); sl@0: return TCL_ERROR; sl@0: } sl@0: masterInterp = GetInterp(interp, objv[2]); sl@0: if (masterInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); sl@0: if (chan == NULL) { sl@0: TclTransferResult(masterInterp, TCL_OK, interp); sl@0: return TCL_ERROR; sl@0: } sl@0: slaveInterp = GetInterp(interp, objv[4]); sl@0: if (slaveInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_RegisterChannel(slaveInterp, chan); sl@0: if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { sl@0: TclTransferResult(masterInterp, TCL_OK, interp); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * GetInterp2 -- sl@0: * sl@0: * Helper function for Tcl_InterpObjCmd() to convert the interp name sl@0: * potentially specified on the command line to an Tcl_Interp. sl@0: * sl@0: * Results: sl@0: * The return value is the interp specified on the command line, sl@0: * or the interp argument itself if no interp was specified on the sl@0: * command line. If the interp could not be found or the wrong sl@0: * number of arguments was specified on the command line, the return sl@0: * value is NULL and an error message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Interp * sl@0: GetInterp2(interp, objc, objv) sl@0: Tcl_Interp *interp; /* Default interp if no interp was specified sl@0: * on the command line. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: if (objc == 2) { sl@0: return interp; sl@0: } else if (objc == 3) { sl@0: return GetInterp(interp, objv[2]); sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?path?"); sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateAlias -- sl@0: * sl@0: * Creates an alias between two interpreters. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates a new alias, manipulates the result field of slaveInterp. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) sl@0: Tcl_Interp *slaveInterp; /* Interpreter for source command. */ sl@0: CONST char *slaveCmd; /* Command to install in slave. */ sl@0: Tcl_Interp *targetInterp; /* Interpreter for target command. */ sl@0: CONST char *targetCmd; /* Name of target command. */ sl@0: int argc; /* How many additional arguments? */ sl@0: CONST char * CONST *argv; /* These are the additional args. */ sl@0: { sl@0: Tcl_Obj *slaveObjPtr, *targetObjPtr; sl@0: Tcl_Obj **objv; sl@0: int i; sl@0: int result; sl@0: sl@0: objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); sl@0: for (i = 0; i < argc; i++) { sl@0: objv[i] = Tcl_NewStringObj(argv[i], -1); sl@0: Tcl_IncrRefCount(objv[i]); sl@0: } sl@0: sl@0: slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); sl@0: Tcl_IncrRefCount(slaveObjPtr); sl@0: sl@0: targetObjPtr = Tcl_NewStringObj(targetCmd, -1); sl@0: Tcl_IncrRefCount(targetObjPtr); sl@0: sl@0: result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, sl@0: targetObjPtr, argc, objv); sl@0: sl@0: for (i = 0; i < argc; i++) { sl@0: Tcl_DecrRefCount(objv[i]); sl@0: } sl@0: ckfree((char *) objv); sl@0: Tcl_DecrRefCount(targetObjPtr); sl@0: Tcl_DecrRefCount(slaveObjPtr); sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateAliasObj -- sl@0: * sl@0: * Object version: Creates an alias between two interpreters. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Creates a new alias. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) sl@0: Tcl_Interp *slaveInterp; /* Interpreter for source command. */ sl@0: CONST char *slaveCmd; /* Command to install in slave. */ sl@0: Tcl_Interp *targetInterp; /* Interpreter for target command. */ sl@0: CONST char *targetCmd; /* Name of target command. */ sl@0: int objc; /* How many additional arguments? */ sl@0: Tcl_Obj *CONST objv[]; /* Argument vector. */ sl@0: { sl@0: Tcl_Obj *slaveObjPtr, *targetObjPtr; sl@0: int result; sl@0: sl@0: slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); sl@0: Tcl_IncrRefCount(slaveObjPtr); sl@0: sl@0: targetObjPtr = Tcl_NewStringObj(targetCmd, -1); sl@0: Tcl_IncrRefCount(targetObjPtr); sl@0: sl@0: result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, sl@0: targetObjPtr, objc, objv); sl@0: sl@0: Tcl_DecrRefCount(slaveObjPtr); sl@0: Tcl_DecrRefCount(targetObjPtr); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetAlias -- sl@0: * sl@0: * Gets information about an alias. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, sl@0: argvPtr) sl@0: Tcl_Interp *interp; /* Interp to start search from. */ sl@0: CONST char *aliasName; /* Name of alias to find. */ sl@0: Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ sl@0: CONST char **targetNamePtr; /* (Return) name of target command. */ sl@0: int *argcPtr; /* (Return) count of addnl args. */ sl@0: CONST char ***argvPtr; /* (Return) additional arguments. */ sl@0: { sl@0: InterpInfo *iiPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Alias *aliasPtr; sl@0: int i, objc; sl@0: Tcl_Obj **objv; sl@0: sl@0: iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; sl@0: hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); sl@0: if (hPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "alias \"", aliasName, "\" not found", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); sl@0: objc = aliasPtr->objc; sl@0: objv = &aliasPtr->objPtr; sl@0: sl@0: if (targetInterpPtr != NULL) { sl@0: *targetInterpPtr = aliasPtr->targetInterp; sl@0: } sl@0: if (targetNamePtr != NULL) { sl@0: *targetNamePtr = Tcl_GetString(objv[0]); sl@0: } sl@0: if (argcPtr != NULL) { sl@0: *argcPtr = objc - 1; sl@0: } sl@0: if (argvPtr != NULL) { sl@0: *argvPtr = (CONST char **) sl@0: ckalloc((unsigned) sizeof(CONST char *) * (objc - 1)); sl@0: for (i = 1; i < objc; i++) { sl@0: *argvPtr[i - 1] = Tcl_GetString(objv[i]); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetAliasObj -- sl@0: * sl@0: * Object version: Gets information about an alias. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, sl@0: objvPtr) sl@0: Tcl_Interp *interp; /* Interp to start search from. */ sl@0: CONST char *aliasName; /* Name of alias to find. */ sl@0: Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ sl@0: CONST char **targetNamePtr; /* (Return) name of target command. */ sl@0: int *objcPtr; /* (Return) count of addnl args. */ sl@0: Tcl_Obj ***objvPtr; /* (Return) additional args. */ sl@0: { sl@0: InterpInfo *iiPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Alias *aliasPtr; sl@0: int objc; sl@0: Tcl_Obj **objv; sl@0: sl@0: iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; sl@0: hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); sl@0: if (hPtr == (Tcl_HashEntry *) NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "alias \"", aliasName, "\" not found", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); sl@0: objc = aliasPtr->objc; sl@0: objv = &aliasPtr->objPtr; sl@0: sl@0: if (targetInterpPtr != (Tcl_Interp **) NULL) { sl@0: *targetInterpPtr = aliasPtr->targetInterp; sl@0: } sl@0: if (targetNamePtr != (CONST char **) NULL) { sl@0: *targetNamePtr = Tcl_GetString(objv[0]); sl@0: } sl@0: if (objcPtr != (int *) NULL) { sl@0: *objcPtr = objc - 1; sl@0: } sl@0: if (objvPtr != (Tcl_Obj ***) NULL) { sl@0: *objvPtr = objv + 1; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclPreventAliasLoop -- sl@0: * sl@0: * When defining an alias or renaming a command, prevent an alias sl@0: * loop from being formed. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * If TCL_ERROR is returned, the function also stores an error message sl@0: * in the interpreter's result object. sl@0: * sl@0: * NOTE: sl@0: * This function is public internal (instead of being static to sl@0: * this file) because it is also used from TclRenameCommand. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclPreventAliasLoop(interp, cmdInterp, cmd) sl@0: Tcl_Interp *interp; /* Interp in which to report errors. */ sl@0: Tcl_Interp *cmdInterp; /* Interp in which the command is sl@0: * being defined. */ sl@0: Tcl_Command cmd; /* Tcl command we are attempting sl@0: * to define. */ sl@0: { sl@0: Command *cmdPtr = (Command *) cmd; sl@0: Alias *aliasPtr, *nextAliasPtr; sl@0: Tcl_Command aliasCmd; sl@0: Command *aliasCmdPtr; sl@0: sl@0: /* sl@0: * If we are not creating or renaming an alias, then it is sl@0: * always OK to create or rename the command. sl@0: */ sl@0: sl@0: if (cmdPtr->objProc != AliasObjCmd) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * OK, we are dealing with an alias, so traverse the chain of aliases. sl@0: * If we encounter the alias we are defining (or renaming to) any in sl@0: * the chain then we have a loop. sl@0: */ sl@0: sl@0: aliasPtr = (Alias *) cmdPtr->objClientData; sl@0: nextAliasPtr = aliasPtr; sl@0: while (1) { sl@0: Tcl_Obj *cmdNamePtr; sl@0: sl@0: /* sl@0: * If the target of the next alias in the chain is the same as sl@0: * the source alias, we have a loop. sl@0: */ sl@0: sl@0: if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { sl@0: /* sl@0: * The slave interpreter can be deleted while creating the alias. sl@0: * [Bug #641195] sl@0: */ sl@0: sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "cannot define or rename alias \"", sl@0: Tcl_GetString(aliasPtr->namePtr), sl@0: "\": interpreter deleted", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: cmdNamePtr = nextAliasPtr->objPtr; sl@0: aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, sl@0: Tcl_GetString(cmdNamePtr), sl@0: Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), sl@0: /*flags*/ 0); sl@0: if (aliasCmd == (Tcl_Command) NULL) { sl@0: return TCL_OK; sl@0: } sl@0: aliasCmdPtr = (Command *) aliasCmd; sl@0: if (aliasCmdPtr == cmdPtr) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "cannot define or rename alias \"", sl@0: Tcl_GetString(aliasPtr->namePtr), sl@0: "\": would create a loop", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Otherwise, follow the chain one step further. See if the target sl@0: * command is an alias - if so, follow the loop to its target sl@0: * command. Otherwise we do not have a loop. sl@0: */ sl@0: sl@0: if (aliasCmdPtr->objProc != AliasObjCmd) { sl@0: return TCL_OK; sl@0: } sl@0: nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; sl@0: } sl@0: sl@0: /* NOTREACHED */ sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AliasCreate -- sl@0: * sl@0: * Helper function to do the work to actually create an alias. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * An alias command is created and entered into the alias table sl@0: * for the slave interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, sl@0: objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error reporting. */ sl@0: Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from sl@0: * which alias will be deleted. */ sl@0: Tcl_Interp *masterInterp; /* Interp in which target command will be sl@0: * invoked. */ sl@0: Tcl_Obj *namePtr; /* Name of alias cmd. */ sl@0: Tcl_Obj *targetNamePtr; /* Name of target cmd. */ sl@0: int objc; /* Additional arguments to store */ sl@0: Tcl_Obj *CONST objv[]; /* with alias. */ sl@0: { sl@0: Alias *aliasPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Target *targetPtr; sl@0: Slave *slavePtr; sl@0: Master *masterPtr; sl@0: Tcl_Obj **prefv; sl@0: int new, i; sl@0: sl@0: aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) sl@0: + objc * sizeof(Tcl_Obj *))); sl@0: aliasPtr->namePtr = namePtr; sl@0: Tcl_IncrRefCount(aliasPtr->namePtr); sl@0: aliasPtr->targetInterp = masterInterp; sl@0: sl@0: aliasPtr->objc = objc + 1; sl@0: prefv = &aliasPtr->objPtr; sl@0: sl@0: *prefv = targetNamePtr; sl@0: Tcl_IncrRefCount(targetNamePtr); sl@0: for (i = 0; i < objc; i++) { sl@0: *(++prefv) = objv[i]; sl@0: Tcl_IncrRefCount(objv[i]); sl@0: } sl@0: sl@0: Tcl_Preserve(slaveInterp); sl@0: Tcl_Preserve(masterInterp); sl@0: sl@0: aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, sl@0: Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr, sl@0: AliasObjCmdDeleteProc); sl@0: sl@0: if (TclPreventAliasLoop(interp, slaveInterp, sl@0: aliasPtr->slaveCmd) != TCL_OK) { sl@0: /* sl@0: * Found an alias loop! The last call to Tcl_CreateObjCommand made sl@0: * the alias point to itself. Delete the command and its alias sl@0: * record. Be careful to wipe out its client data first, so the sl@0: * command doesn't try to delete itself. sl@0: */ sl@0: sl@0: Command *cmdPtr; sl@0: sl@0: Tcl_DecrRefCount(aliasPtr->namePtr); sl@0: Tcl_DecrRefCount(targetNamePtr); sl@0: for (i = 0; i < objc; i++) { sl@0: Tcl_DecrRefCount(objv[i]); sl@0: } sl@0: sl@0: cmdPtr = (Command *) aliasPtr->slaveCmd; sl@0: cmdPtr->clientData = NULL; sl@0: cmdPtr->deleteProc = NULL; sl@0: cmdPtr->deleteData = NULL; sl@0: Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); sl@0: sl@0: ckfree((char *) aliasPtr); sl@0: sl@0: /* sl@0: * The result was already set by TclPreventAliasLoop. sl@0: */ sl@0: sl@0: Tcl_Release(slaveInterp); sl@0: Tcl_Release(masterInterp); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make an entry in the alias table. If it already exists delete sl@0: * the alias command. Then retry. sl@0: */ sl@0: sl@0: slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; sl@0: while (1) { sl@0: Alias *oldAliasPtr; sl@0: char *string; sl@0: sl@0: string = Tcl_GetString(namePtr); sl@0: hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new); sl@0: if (new != 0) { sl@0: break; sl@0: } sl@0: sl@0: oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); sl@0: Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd); sl@0: } sl@0: sl@0: aliasPtr->aliasEntryPtr = hPtr; sl@0: Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); sl@0: sl@0: /* sl@0: * Create the new command. We must do it after deleting any old command, sl@0: * because the alias may be pointing at a renamed alias, as in: sl@0: * sl@0: * interp alias {} foo {} bar # Create an alias "foo" sl@0: * rename foo zop # Now rename the alias sl@0: * interp alias {} foo {} zop # Now recreate "foo"... sl@0: */ sl@0: sl@0: targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); sl@0: targetPtr->slaveCmd = aliasPtr->slaveCmd; sl@0: targetPtr->slaveInterp = slaveInterp; sl@0: sl@0: Tcl_MutexLock(&cntMutex); sl@0: masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master; sl@0: do { sl@0: hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable, sl@0: (char *) aliasCounter, &new); sl@0: aliasCounter++; sl@0: } while (new == 0); sl@0: Tcl_MutexUnlock(&cntMutex); sl@0: sl@0: Tcl_SetHashValue(hPtr, (ClientData) targetPtr); sl@0: aliasPtr->targetEntryPtr = hPtr; sl@0: sl@0: Tcl_SetObjResult(interp, namePtr); sl@0: sl@0: Tcl_Release(slaveInterp); sl@0: Tcl_Release(masterInterp); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AliasDelete -- sl@0: * sl@0: * Deletes the given alias from the slave interpreter given. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Deletes the alias from the slave interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: AliasDelete(interp, slaveInterp, namePtr) sl@0: Tcl_Interp *interp; /* Interpreter for result & errors. */ sl@0: Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ sl@0: Tcl_Obj *namePtr; /* Name of alias to delete. */ sl@0: { sl@0: Slave *slavePtr; sl@0: Alias *aliasPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: /* sl@0: * If the alias has been renamed in the slave, the master can still use sl@0: * the original name (with which it was created) to find the alias to sl@0: * delete it. sl@0: */ sl@0: sl@0: slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; sl@0: hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); sl@0: if (hPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"", sl@0: Tcl_GetString(namePtr), "\" not found", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); sl@0: Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AliasDescribe -- sl@0: * sl@0: * Sets the interpreter's result object to a Tcl list describing sl@0: * the given alias in the given interpreter: its target command sl@0: * and the additional arguments to prepend to any invocation sl@0: * of the alias. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: AliasDescribe(interp, slaveInterp, namePtr) sl@0: Tcl_Interp *interp; /* Interpreter for result & errors. */ sl@0: Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ sl@0: Tcl_Obj *namePtr; /* Name of alias to describe. */ sl@0: { sl@0: Slave *slavePtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Alias *aliasPtr; sl@0: Tcl_Obj *prefixPtr; sl@0: sl@0: /* sl@0: * If the alias has been renamed in the slave, the master can still use sl@0: * the original name (with which it was created) to find the alias to sl@0: * describe it. sl@0: */ sl@0: sl@0: slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; sl@0: hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); sl@0: if (hPtr == NULL) { sl@0: return TCL_OK; sl@0: } sl@0: aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); sl@0: prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); sl@0: Tcl_SetObjResult(interp, prefixPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AliasList -- sl@0: * sl@0: * Computes a list of aliases defined in a slave interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: AliasList(interp, slaveInterp) sl@0: Tcl_Interp *interp; /* Interp for data return. */ sl@0: Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */ sl@0: { sl@0: Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch hashSearch; sl@0: Tcl_Obj *resultPtr; sl@0: Alias *aliasPtr; sl@0: Slave *slavePtr; sl@0: sl@0: slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); sl@0: for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { sl@0: aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); sl@0: Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AliasObjCmd -- sl@0: * sl@0: * This is the procedure that services invocations of aliases in a sl@0: * slave interpreter. One such command exists for each alias. When sl@0: * invoked, this procedure redirects the invocation to the target sl@0: * command in the master interpreter as designated by the Alias sl@0: * record associated with this command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Causes forwarding of the invocation; all possible side effects sl@0: * may occur as a result of invoking the command to which the sl@0: * invocation is forwarded. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: AliasObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Alias record. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument vector. */ sl@0: { sl@0: #define ALIAS_CMDV_PREALLOC 10 sl@0: Tcl_Interp *targetInterp; sl@0: Alias *aliasPtr; sl@0: int result, prefc, cmdc, i; sl@0: Tcl_Obj **prefv, **cmdv; sl@0: Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; sl@0: aliasPtr = (Alias *) clientData; sl@0: targetInterp = aliasPtr->targetInterp; sl@0: sl@0: /* sl@0: * Append the arguments to the command prefix and invoke the command sl@0: * in the target interp's global namespace. sl@0: */ sl@0: sl@0: prefc = aliasPtr->objc; sl@0: prefv = &aliasPtr->objPtr; sl@0: cmdc = prefc + objc - 1; sl@0: if (cmdc <= ALIAS_CMDV_PREALLOC) { sl@0: cmdv = cmdArr; sl@0: } else { sl@0: cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *))); sl@0: } sl@0: sl@0: prefv = &aliasPtr->objPtr; sl@0: memcpy((VOID *) cmdv, (VOID *) prefv, sl@0: (size_t) (prefc * sizeof(Tcl_Obj *))); sl@0: memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), sl@0: (size_t) ((objc-1) * sizeof(Tcl_Obj *))); sl@0: sl@0: Tcl_ResetResult(targetInterp); sl@0: sl@0: for (i=0; inamePtr); sl@0: objv = &aliasPtr->objPtr; sl@0: for (i = 0; i < aliasPtr->objc; i++) { sl@0: Tcl_DecrRefCount(objv[i]); sl@0: } sl@0: Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); sl@0: sl@0: targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr); sl@0: ckfree((char *) targetPtr); sl@0: Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr); sl@0: sl@0: ckfree((char *) aliasPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateSlave -- sl@0: * sl@0: * Creates a slave interpreter. The slavePath argument denotes the sl@0: * name of the new slave relative to the current interpreter; the sl@0: * slave is a direct descendant of the one-before-last component of sl@0: * the path, e.g. it is a descendant of the current interpreter if sl@0: * the slavePath argument contains only one component. Optionally makes sl@0: * the slave interpreter safe. sl@0: * sl@0: * Results: sl@0: * Returns the interpreter structure created, or NULL if an error sl@0: * occurred. sl@0: * sl@0: * Side effects: sl@0: * Creates a new interpreter and a new interpreter object command in sl@0: * the interpreter indicated by the slavePath argument. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Interp * sl@0: Tcl_CreateSlave(interp, slavePath, isSafe) sl@0: Tcl_Interp *interp; /* Interpreter to start search at. */ sl@0: CONST char *slavePath; /* Name of slave to create. */ sl@0: int isSafe; /* Should new slave be "safe" ? */ sl@0: { sl@0: Tcl_Obj *pathPtr; sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: pathPtr = Tcl_NewStringObj(slavePath, -1); sl@0: slaveInterp = SlaveCreate(interp, pathPtr, isSafe); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: sl@0: return slaveInterp; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetSlave -- sl@0: * sl@0: * Finds a slave interpreter by its path name. sl@0: * sl@0: * Results: sl@0: * Returns a Tcl_Interp * for the named interpreter or NULL if not sl@0: * found. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Interp * sl@0: Tcl_GetSlave(interp, slavePath) sl@0: Tcl_Interp *interp; /* Interpreter to start search from. */ sl@0: CONST char *slavePath; /* Path of slave to find. */ sl@0: { sl@0: Tcl_Obj *pathPtr; sl@0: Tcl_Interp *slaveInterp; sl@0: sl@0: pathPtr = Tcl_NewStringObj(slavePath, -1); sl@0: slaveInterp = GetInterp(interp, pathPtr); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: sl@0: return slaveInterp; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetMaster -- sl@0: * sl@0: * Finds the master interpreter of a slave interpreter. sl@0: * sl@0: * Results: sl@0: * Returns a Tcl_Interp * for the master interpreter or NULL if none. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Interp * sl@0: Tcl_GetMaster(interp) sl@0: Tcl_Interp *interp; /* Get the master of this interpreter. */ sl@0: { sl@0: Slave *slavePtr; /* Slave record of this interpreter. */ sl@0: sl@0: if (interp == (Tcl_Interp *) NULL) { sl@0: return NULL; sl@0: } sl@0: slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; sl@0: return slavePtr->masterInterp; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetInterpPath -- sl@0: * sl@0: * Sets the result of the asking interpreter to a proper Tcl list sl@0: * containing the names of interpreters between the asking and sl@0: * target interpreters. The target interpreter must be either the sl@0: * same as the asking interpreter or one of its slaves (including sl@0: * recursively). sl@0: * sl@0: * Results: sl@0: * TCL_OK if the target interpreter is the same as, or a descendant sl@0: * of, the asking interpreter; TCL_ERROR else. This way one can sl@0: * distinguish between the case where the asking and target interps sl@0: * are the same (an empty list is the result, and TCL_OK is returned) sl@0: * and when the target is not a descendant of the asking interpreter sl@0: * (in which case the Tcl result is an error message and the function sl@0: * returns TCL_ERROR). sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetInterpPath(askingInterp, targetInterp) sl@0: Tcl_Interp *askingInterp; /* Interpreter to start search from. */ sl@0: Tcl_Interp *targetInterp; /* Interpreter to find. */ sl@0: { sl@0: InterpInfo *iiPtr; sl@0: sl@0: if (targetInterp == askingInterp) { sl@0: return TCL_OK; sl@0: } sl@0: if (targetInterp == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; sl@0: if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_AppendElement(askingInterp, sl@0: Tcl_GetHashKey(&iiPtr->master.slaveTable, sl@0: iiPtr->slave.slaveEntryPtr)); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetInterp -- sl@0: * sl@0: * Helper function to find a slave interpreter given a pathname. sl@0: * sl@0: * Results: sl@0: * Returns the slave interpreter known by that name in the calling sl@0: * interpreter, or NULL if no interpreter known by that name exists. sl@0: * sl@0: * Side effects: sl@0: * Assigns to the pointer variable passed in, if not NULL. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Interp * sl@0: GetInterp(interp, pathPtr) sl@0: Tcl_Interp *interp; /* Interp. to start search from. */ sl@0: Tcl_Obj *pathPtr; /* List object containing name of interp. to sl@0: * be found. */ sl@0: { sl@0: Tcl_HashEntry *hPtr; /* Search element. */ sl@0: Slave *slavePtr; /* Interim slave record. */ sl@0: Tcl_Obj **objv; sl@0: int objc, i; sl@0: Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ sl@0: InterpInfo *masterInfoPtr; sl@0: sl@0: if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: sl@0: searchInterp = interp; sl@0: for (i = 0; i < objc; i++) { sl@0: masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; sl@0: hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, sl@0: Tcl_GetString(objv[i])); sl@0: if (hPtr == NULL) { sl@0: searchInterp = NULL; sl@0: break; sl@0: } sl@0: slavePtr = (Slave *) Tcl_GetHashValue(hPtr); sl@0: searchInterp = slavePtr->slaveInterp; sl@0: if (searchInterp == NULL) { sl@0: break; sl@0: } sl@0: } sl@0: if (searchInterp == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "could not find interpreter \"", sl@0: Tcl_GetString(pathPtr), "\"", (char *) NULL); sl@0: } sl@0: return searchInterp; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveCreate -- sl@0: * sl@0: * Helper function to do the actual work of creating a slave interp sl@0: * and new object command. Also optionally makes the new slave sl@0: * interpreter "safe". sl@0: * sl@0: * Results: sl@0: * Returns the new Tcl_Interp * if successful or NULL if not. If failed, sl@0: * the result of the invoking interpreter contains an error message. sl@0: * sl@0: * Side effects: sl@0: * Creates a new slave interpreter and a new object command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Interp * sl@0: SlaveCreate(interp, pathPtr, safe) sl@0: Tcl_Interp *interp; /* Interp. to start search from. */ sl@0: Tcl_Obj *pathPtr; /* Path (name) of slave to create. */ sl@0: int safe; /* Should we make it "safe"? */ sl@0: { sl@0: Tcl_Interp *masterInterp, *slaveInterp; sl@0: Slave *slavePtr; sl@0: InterpInfo *masterInfoPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: char *path; sl@0: int new, objc; sl@0: Tcl_Obj **objv; sl@0: sl@0: if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: if (objc < 2) { sl@0: masterInterp = interp; sl@0: path = Tcl_GetString(pathPtr); sl@0: } else { sl@0: Tcl_Obj *objPtr; sl@0: sl@0: objPtr = Tcl_NewListObj(objc - 1, objv); sl@0: masterInterp = GetInterp(interp, objPtr); sl@0: Tcl_DecrRefCount(objPtr); sl@0: if (masterInterp == NULL) { sl@0: return NULL; sl@0: } sl@0: path = Tcl_GetString(objv[objc - 1]); sl@0: } sl@0: if (safe == 0) { sl@0: safe = Tcl_IsSafe(masterInterp); sl@0: } sl@0: sl@0: masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; sl@0: hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new); sl@0: if (new == 0) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "interpreter named \"", path, sl@0: "\" already exists, cannot create", (char *) NULL); sl@0: return NULL; sl@0: } sl@0: sl@0: slaveInterp = Tcl_CreateInterp(); sl@0: slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; sl@0: slavePtr->masterInterp = masterInterp; sl@0: slavePtr->slaveEntryPtr = hPtr; sl@0: slavePtr->slaveInterp = slaveInterp; sl@0: slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, sl@0: SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); sl@0: Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); sl@0: Tcl_SetHashValue(hPtr, (ClientData) slavePtr); sl@0: Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); sl@0: sl@0: /* sl@0: * Inherit the recursion limit. sl@0: */ sl@0: ((Interp *) slaveInterp)->maxNestingDepth = sl@0: ((Interp *) masterInterp)->maxNestingDepth ; sl@0: sl@0: if (safe) { sl@0: if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { sl@0: goto error; sl@0: } sl@0: } else { sl@0: if (Tcl_Init(slaveInterp) == TCL_ERROR) { sl@0: goto error; sl@0: } sl@0: /* sl@0: * This will create the "memory" command in slave interpreters sl@0: * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing. sl@0: */ sl@0: Tcl_InitMemory(slaveInterp); sl@0: } sl@0: return slaveInterp; sl@0: sl@0: error: sl@0: TclTransferResult(slaveInterp, TCL_ERROR, interp); sl@0: Tcl_DeleteInterp(slaveInterp); sl@0: sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveObjCmd -- sl@0: * sl@0: * Command to manipulate an interpreter, e.g. to send commands to it sl@0: * to be evaluated. One such command exists for each slave interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See user documentation for details. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Slave interpreter. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Interp *slaveInterp; sl@0: int index; sl@0: static CONST char *options[] = { sl@0: "alias", "aliases", "eval", "expose", sl@0: "hide", "hidden", "issafe", "invokehidden", sl@0: "marktrusted", "recursionlimit", NULL sl@0: }; sl@0: enum options { sl@0: OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE, sl@0: OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, sl@0: OPT_MARKTRUSTED, OPT_RECLIMIT sl@0: }; sl@0: sl@0: slaveInterp = (Tcl_Interp *) clientData; sl@0: if (slaveInterp == NULL) { sl@0: panic("SlaveObjCmd: interpreter has been deleted"); sl@0: } sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: switch ((enum options) index) { sl@0: case OPT_ALIAS: { sl@0: if (objc > 2) { sl@0: if (objc == 3) { sl@0: return AliasDescribe(interp, slaveInterp, objv[2]); sl@0: } sl@0: if (Tcl_GetString(objv[3])[0] == '\0') { sl@0: if (objc == 4) { sl@0: return AliasDelete(interp, slaveInterp, objv[2]); sl@0: } sl@0: } else { sl@0: return AliasCreate(interp, slaveInterp, interp, objv[2], sl@0: objv[3], objc - 4, objv + 4); sl@0: } sl@0: } sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "aliasName ?targetName? ?args..?"); sl@0: return TCL_ERROR; sl@0: } sl@0: case OPT_ALIASES: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return AliasList(interp, slaveInterp); sl@0: } sl@0: case OPT_EVAL: { sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); sl@0: } sl@0: case OPT_EXPOSE: { sl@0: if ((objc < 3) || (objc > 4)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); sl@0: } sl@0: case OPT_HIDE: { sl@0: if ((objc < 3) || (objc > 4)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); sl@0: } sl@0: case OPT_HIDDEN: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveHidden(interp, slaveInterp); sl@0: } sl@0: case OPT_ISSAFE: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp)); sl@0: return TCL_OK; sl@0: } sl@0: case OPT_INVOKEHIDDEN: { sl@0: int global, i, index; sl@0: static CONST char *hiddenOptions[] = { sl@0: "-global", "--", NULL sl@0: }; sl@0: enum hiddenOption { sl@0: OPT_GLOBAL, OPT_LAST sl@0: }; sl@0: global = 0; sl@0: for (i = 2; i < objc; i++) { sl@0: if (Tcl_GetString(objv[i])[0] != '-') { sl@0: break; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, sl@0: "option", 0, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index == OPT_GLOBAL) { sl@0: global = 1; sl@0: } else { sl@0: i++; sl@0: break; sl@0: } sl@0: } sl@0: if (objc - i < 1) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "?-global? ?--? cmd ?arg ..?"); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveInvokeHidden(interp, slaveInterp, global, objc - i, sl@0: objv + i); sl@0: } sl@0: case OPT_MARKTRUSTED: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveMarkTrusted(interp, slaveInterp); sl@0: } sl@0: case OPT_RECLIMIT: { sl@0: if (objc != 2 && objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); sl@0: return TCL_ERROR; sl@0: } sl@0: return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); sl@0: } sl@0: } sl@0: sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveObjCmdDeleteProc -- sl@0: * sl@0: * Invoked when an object command for a slave interpreter is deleted; sl@0: * cleans up all state associated with the slave interpreter and destroys sl@0: * the slave interpreter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Cleans up all state associated with the slave interpreter and sl@0: * destroys the slave interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: SlaveObjCmdDeleteProc(clientData) sl@0: ClientData clientData; /* The SlaveRecord for the command. */ sl@0: { sl@0: Slave *slavePtr; /* Interim storage for Slave record. */ sl@0: Tcl_Interp *slaveInterp; /* And for a slave interp. */ sl@0: sl@0: slaveInterp = (Tcl_Interp *) clientData; sl@0: slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; sl@0: sl@0: /* sl@0: * Unlink the slave from its master interpreter. sl@0: */ sl@0: sl@0: Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); sl@0: sl@0: /* sl@0: * Set to NULL so that when the InterpInfo is cleaned up in the slave sl@0: * it does not try to delete the command causing all sorts of grief. sl@0: * See SlaveRecordDeleteProc(). sl@0: */ sl@0: sl@0: slavePtr->interpCmd = NULL; sl@0: sl@0: if (slavePtr->slaveInterp != NULL) { sl@0: Tcl_DeleteInterp(slavePtr->slaveInterp); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveEval -- sl@0: * sl@0: * Helper function to evaluate a command in a slave interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Whatever the command does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveEval(interp, slaveInterp, objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error return. */ sl@0: Tcl_Interp *slaveInterp; /* The slave interpreter in which command sl@0: * will be evaluated. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int result; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: Tcl_Preserve((ClientData) slaveInterp); sl@0: Tcl_AllowExceptions(slaveInterp); sl@0: sl@0: if (objc == 1) { sl@0: #ifndef TCL_TIP280 sl@0: result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); sl@0: #else sl@0: /* TIP #280 : Make invoker available to eval'd script */ sl@0: Interp* iPtr = (Interp*) interp; sl@0: result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0); sl@0: #endif sl@0: } else { sl@0: objPtr = Tcl_ConcatObj(objc, objv); sl@0: Tcl_IncrRefCount(objPtr); sl@0: result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); sl@0: Tcl_DecrRefCount(objPtr); sl@0: } sl@0: TclTransferResult(slaveInterp, result, interp); sl@0: sl@0: Tcl_Release((ClientData) slaveInterp); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveExpose -- sl@0: * sl@0: * Helper function to expose a command in a slave interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * After this call scripts in the slave will be able to invoke sl@0: * the newly exposed command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveExpose(interp, slaveInterp, objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error return. */ sl@0: Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings. */ sl@0: { sl@0: char *name; sl@0: sl@0: if (Tcl_IsSafe(interp)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "permission denied: safe interpreter cannot expose commands", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); sl@0: if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]), sl@0: name) != TCL_OK) { sl@0: TclTransferResult(slaveInterp, TCL_ERROR, interp); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveRecursionLimit -- sl@0: * sl@0: * Helper function to set/query the Recursion limit of an interp sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * When (objc == 1), slaveInterp will be set to a new recursion sl@0: * limit of objv[0]. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveRecursionLimit(interp, slaveInterp, objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error return. */ sl@0: Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */ sl@0: int objc; /* Set or Query. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings. */ sl@0: { sl@0: Interp *iPtr; sl@0: int limit; sl@0: sl@0: if (objc) { sl@0: if (Tcl_IsSafe(interp)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "permission denied: ", sl@0: "safe interpreters cannot change recursion limit", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (limit <= 0) { sl@0: Tcl_SetObjResult(interp, Tcl_NewStringObj( sl@0: "recursion limit must be > 0", -1)); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetRecursionLimit(slaveInterp, limit); sl@0: iPtr = (Interp *) slaveInterp; sl@0: if (interp == slaveInterp && iPtr->numLevels > limit) { sl@0: Tcl_SetObjResult(interp, Tcl_NewStringObj( sl@0: "falling back due to new recursion limit", -1)); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, objv[0]); sl@0: return TCL_OK; sl@0: } else { sl@0: limit = Tcl_SetRecursionLimit(slaveInterp, 0); sl@0: Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveHide -- sl@0: * sl@0: * Helper function to hide a command in a slave interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * After this call scripts in the slave will no longer be able sl@0: * to invoke the named command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveHide(interp, slaveInterp, objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error return. */ sl@0: Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings. */ sl@0: { sl@0: char *name; sl@0: sl@0: if (Tcl_IsSafe(interp)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "permission denied: safe interpreter cannot hide commands", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); sl@0: if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), sl@0: name) != TCL_OK) { sl@0: TclTransferResult(slaveInterp, TCL_ERROR, interp); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveHidden -- sl@0: * sl@0: * Helper function to compute list of hidden commands in a slave sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveHidden(interp, slaveInterp) sl@0: Tcl_Interp *interp; /* Interp for data return. */ sl@0: Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */ sl@0: { sl@0: Tcl_Obj *listObjPtr; /* Local object pointer. */ sl@0: Tcl_HashTable *hTblPtr; /* For local searches. */ sl@0: Tcl_HashEntry *hPtr; /* For local searches. */ sl@0: Tcl_HashSearch hSearch; /* For local searches. */ sl@0: sl@0: listObjPtr = Tcl_GetObjResult(interp); sl@0: hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; sl@0: if (hTblPtr != (Tcl_HashTable *) NULL) { sl@0: for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); sl@0: hPtr != (Tcl_HashEntry *) NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: sl@0: Tcl_ListObjAppendElement(NULL, listObjPtr, sl@0: Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveInvokeHidden -- sl@0: * sl@0: * Helper function to invoke a hidden command in a slave interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Whatever the hidden command does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveInvokeHidden(interp, slaveInterp, global, objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error return. */ sl@0: Tcl_Interp *slaveInterp; /* The slave interpreter in which command sl@0: * will be invoked. */ sl@0: int global; /* Non-zero to invoke in global namespace. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int result; sl@0: sl@0: if (Tcl_IsSafe(interp)) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), sl@0: "not allowed to invoke hidden commands from safe interpreter", sl@0: -1); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_Preserve((ClientData) slaveInterp); sl@0: Tcl_AllowExceptions(slaveInterp); sl@0: sl@0: if (global) { sl@0: result = TclObjInvokeGlobal(slaveInterp, objc, objv, sl@0: TCL_INVOKE_HIDDEN); sl@0: } else { sl@0: result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); sl@0: } sl@0: sl@0: TclTransferResult(slaveInterp, result, interp); sl@0: sl@0: Tcl_Release((ClientData) slaveInterp); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SlaveMarkTrusted -- sl@0: * sl@0: * Helper function to mark a slave interpreter as trusted (unsafe). sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * After this call the hard-wired security checks in the core no sl@0: * longer prevent the slave from performing certain operations. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SlaveMarkTrusted(interp, slaveInterp) sl@0: Tcl_Interp *interp; /* Interp for error return. */ sl@0: Tcl_Interp *slaveInterp; /* The slave interpreter which will be sl@0: * marked trusted. */ sl@0: { sl@0: if (Tcl_IsSafe(interp)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "permission denied: safe interpreter cannot mark trusted", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_IsSafe -- sl@0: * sl@0: * Determines whether an interpreter is safe sl@0: * sl@0: * Results: sl@0: * 1 if it is safe, 0 if it is not. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_IsSafe(interp) sl@0: Tcl_Interp *interp; /* Is this interpreter "safe" ? */ sl@0: { sl@0: Interp *iPtr; sl@0: sl@0: if (interp == (Tcl_Interp *) NULL) { sl@0: return 0; sl@0: } sl@0: iPtr = (Interp *) interp; sl@0: sl@0: return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_MakeSafe -- sl@0: * sl@0: * Makes its argument interpreter contain only functionality that is sl@0: * defined to be part of Safe Tcl. Unsafe commands are hidden, the sl@0: * env array is unset, and the standard channels are removed. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Hides commands in its argument interpreter, and removes settings sl@0: * and channels. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_MakeSafe(interp) sl@0: Tcl_Interp *interp; /* Interpreter to be made safe. */ sl@0: { sl@0: Tcl_Channel chan; /* Channel to remove from sl@0: * safe interpreter. */ sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: TclHideUnsafeCommands(interp); sl@0: sl@0: iPtr->flags |= SAFE_INTERP; sl@0: sl@0: /* sl@0: * Unsetting variables : (which should not have been set sl@0: * in the first place, but...) sl@0: */ sl@0: sl@0: /* sl@0: * No env array in a safe slave. sl@0: */ sl@0: sl@0: Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); sl@0: sl@0: /* sl@0: * Remove unsafe parts of tcl_platform sl@0: */ sl@0: sl@0: Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); sl@0: Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); sl@0: Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); sl@0: Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); sl@0: sl@0: /* sl@0: * Unset path informations variables sl@0: * (the only one remaining is [info nameofexecutable]) sl@0: */ sl@0: sl@0: Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); sl@0: Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); sl@0: Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); sl@0: sl@0: /* sl@0: * Remove the standard channels from the interpreter; safe interpreters sl@0: * do not ordinarily have access to stdin, stdout and stderr. sl@0: * sl@0: * NOTE: These channels are not added to the interpreter by the sl@0: * Tcl_CreateInterp call, but may be added later, by another I/O sl@0: * operation. We want to ensure that the interpreter does not have sl@0: * these channels even if it is being made safe after being used for sl@0: * some time.. sl@0: */ sl@0: sl@0: chan = Tcl_GetStdChannel(TCL_STDIN); sl@0: if (chan != (Tcl_Channel) NULL) { sl@0: Tcl_UnregisterChannel(interp, chan); sl@0: } sl@0: chan = Tcl_GetStdChannel(TCL_STDOUT); sl@0: if (chan != (Tcl_Channel) NULL) { sl@0: Tcl_UnregisterChannel(interp, chan); sl@0: } sl@0: chan = Tcl_GetStdChannel(TCL_STDERR); sl@0: if (chan != (Tcl_Channel) NULL) { sl@0: Tcl_UnregisterChannel(interp, chan); sl@0: } sl@0: sl@0: return TCL_OK; sl@0: }