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