diff options
Diffstat (limited to 'generic/tclInterp.c')
| -rw-r--r-- | generic/tclInterp.c | 4508 |
1 files changed, 1525 insertions, 2983 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c index bdf4f72..a5e7563 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,7 +9,7 @@ * 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.4 1999/02/03 02:58:40 stanton Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.5 1999/04/16 00:46:49 stanton Exp $ */ #include <stdio.h> @@ -21,6 +21,42 @@ */ 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_Obj *prefixPtr; /* Tcl list making up 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_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. */ +} Alias; /* * @@ -31,13 +67,14 @@ static int aliasCounter = 0; * a slave interpreter, e.g. what aliases are defined in it. */ -typedef struct { +typedef struct Slave { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ - Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for - * this slave interpreter. Used to find + 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 - * masters table. */ + * 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 @@ -46,33 +83,6 @@ typedef struct { } Slave; /* - * 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 { - char *aliasName; /* Name of alias command. */ - char *targetName; /* Name of target command in master interp. */ - Tcl_Interp *targetInterp; /* Master interpreter. */ - int objc; /* Count of additional args to pass. */ - Tcl_Obj **objv; /* Actual additional args to pass. */ - Tcl_HashEntry *aliasEntry; /* 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 *targetEntry; /* 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. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter. */ -} Alias; - -/* * struct Target: * * Maps from master interpreter commands back to the source commands in slave @@ -86,7 +96,7 @@ typedef struct { * the master is deleted. */ -typedef struct { +typedef struct Target { Tcl_Command slaveCmd; /* Command for alias in slave interp. */ Tcl_Interp *slaveInterp; /* Slave Interpreter. */ } Target; @@ -107,7 +117,7 @@ typedef struct { * interpreters and can only load safe extensions. */ -typedef struct { +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 @@ -120,718 +130,978 @@ typedef struct { } 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 AliasCmd _ANSI_ARGS_((ClientData dummy, +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 AliasCmdDeleteProc _ANSI_ARGS_(( +static void AliasObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); -static int AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp, - Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, - Master *masterPtr, char *aliasName, - char *targetName, int objc, + +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 int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *slavePath, int safe)); -static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, char *aliasName)); -static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, char *aliasName)); -static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *path)); -static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *path, - Master **masterPtrPtr)); -static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, - char *aliasName)); -static int InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpInvokeHiddenHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpMarkTrustedHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp)); -static void MasterRecordDeleteProc _ANSI_ARGS_(( +static void InterpInfoDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); -static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveIsSafeHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Interp *slaveInterp, - Slave *slavePtr, int objc, Tcl_Obj *CONST objv[])); -static int SlaveInvokeHiddenHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Interp *slaveInterp, - Slave *slavePtr, int objc, Tcl_Obj *CONST objv[])); -static int SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, +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 SlaveObjectDeleteProc _ANSI_ARGS_(( +static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); -static void SlaveRecordDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclPreventAliasLoop -- + * TclInterpInit -- * - * When defining an alias or renaming a command, prevent an alias - * loop from being formed. + * Initializes the invoking interpreter for using the master, slave + * and safe interp facilities. This is called from inside + * Tcl_CreateInterp(). * * Results: - * A standard Tcl object result. + * Always returns TCL_OK for backwards compatibility. * * Side effects: - * If TCL_ERROR is returned, the function also stores an error message - * in the interpreter's result object. + * Adds the "interp" command to an interpreter and initializes the + * interpInfoPtr field of the invoking interpreter. * - * 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. */ +TclInterpInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ { - 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 != AliasCmd) { - 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) { + InterpInfo *interpInfoPtr; + Master *masterPtr; + Slave *slavePtr; - /* - * If the target of the next alias in the chain is the same as - * the source alias, we have a loop. - */ + interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); + ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; - aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, - nextAliasPtr->targetName, - 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 \"", aliasPtr->aliasName, - "\": would create a loop", (char *) NULL); - return TCL_ERROR; - } + masterPtr = &interpInfoPtr->master; + Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS); - /* - * 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. - */ + slavePtr = &interpInfoPtr->slave; + slavePtr->masterInterp = NULL; + slavePtr->slaveEntryPtr = NULL; + slavePtr->slaveInterp = interp; + slavePtr->interpCmd = NULL; + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - if (aliasCmdPtr->objProc != AliasCmd) { - return TCL_OK; - } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; - } + Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); - /* NOTREACHED */ + Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); + return TCL_OK; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * MarkTrusted -- + * InterpInfoDeleteProc -- * - * Mark an interpreter as unsafe (i.e. remove the "safe" mark). + * Invoked when an interpreter is being deleted. It releases all + * storage used by the master/slave/safe interpreter facilities. * * Results: - * A standard Tcl result. + * None. * * Side effects: - * Removes the "safe" mark from an interpreter. + * Cleans up storage. Sets the interpInfoPtr field of the interp + * to NULL. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -MarkTrusted(interp) - Tcl_Interp *interp; /* Interpreter to be marked unsafe. */ +static void +InterpInfoDeleteProc(clientData, interp) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* Interp being deleted. All commands for + * slave interps should already be deleted. */ { - Interp *iPtr = (Interp *) interp; + InterpInfo *interpInfoPtr; + Slave *slavePtr; + Master *masterPtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + Target *targetPtr; - iPtr->flags &= ~SAFE_INTERP; - return TCL_OK; + 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_MakeSafe -- + * Tcl_InterpObjCmd -- * - * 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. + * This procedure is invoked to process the "interp" Tcl command. + * See the user documentation for details on what it does. * * Results: - * None. + * A standard Tcl result. * * Side effects: - * Hides commands in its argument interpreter, and removes settings - * and channels. + * See the user documentation. * *---------------------------------------------------------------------- */ - + /* ARGSUSED */ int -Tcl_MakeSafe(interp) - Tcl_Interp *interp; /* Interpreter to be made safe. */ +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. */ { - Tcl_Channel chan; /* Channel to remove from - * safe interpreter. */ - Interp *iPtr = (Interp *) interp; + int index; + static char *options[] = { + "alias", "aliases", "create", "delete", + "eval", "exists", "expose", "hide", + "hidden", "issafe", "invokehidden", "marktrusted", + "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_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER + }; - TclHideUnsafeCommands(interp); - - iPtr->flags |= SAFE_INTERP; - /* - * Unsetting variables : (which should not have been set - * in the first place, but...) - */ + 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; - /* - * No env array in a safe slave. - */ + 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; - Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); + 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 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; + } + 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; - /* - * Remove unsafe parts of tcl_platform - */ + 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; - 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); + 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. */ - /* - * Unset path informations variables - * (the only one remaining is [info nameofexecutable]) - */ + 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. */ - 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.. - */ + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + } + case OPT_ISSAFE: { + Tcl_Interp *slaveInterp; - 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); - } + 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 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_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; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * GetInterp -- + * GetInterp2 -- * - * Helper function to find a slave interpreter given a pathname. + * Helper function for Tcl_InterpObjCmd() to convert the interp name + * potentially specified on the command line to an Tcl_Interp. * * Results: - * Returns the slave interpreter known by that name in the calling - * interpreter, or NULL if no interpreter known by that name exists. + * 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: - * Assigns to the pointer variable passed in, if not NULL. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - + static Tcl_Interp * -GetInterp(interp, masterPtr, path, masterPtrPtr) - Tcl_Interp *interp; /* Interp. to start search from. */ - Master *masterPtr; /* Its master record. */ - char *path; /* The path (name) of interp. to be found. */ - Master **masterPtrPtr; /* (Return) its master record. */ +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. */ { - Tcl_HashEntry *hPtr; /* Search element. */ - Slave *slavePtr; /* Interim slave record. */ - char **argv; /* Split-up path (name) for interp to find. */ - int argc, i; /* Loop indices. */ - Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - - if (masterPtrPtr != (Master **) NULL) { - *masterPtrPtr = masterPtr; - } - - if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { - return (Tcl_Interp *) NULL; - } - - for (searchInterp = interp, i = 0; i < argc; i++) { - - hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); - if (hPtr == (Tcl_HashEntry *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; - if (searchInterp == (Tcl_Interp *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(searchInterp, - "tclMasterRecord", NULL); - if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; - if (masterPtr == (Master *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } + if (objc == 2) { + return interp; + } else if (objc == 3) { + return GetInterp(interp, objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return NULL; } - ckfree((char *) argv); - return searchInterp; } /* *---------------------------------------------------------------------- * - * CreateSlave -- + * Tcl_CreateAlias -- * - * Helper function to do the actual work of creating a slave interp - * and new object command. Also optionally makes the new slave - * interpreter "safe". + * Creates an alias between two interpreters. * * Results: - * Returns the new Tcl_Interp * if successful or NULL if not. If failed, - * the result of the invoking interpreter contains an error message. + * A standard Tcl result. * * Side effects: - * Creates a new slave interpreter and a new object command. + * Creates a new alias, manipulates the result field of slaveInterp. * *---------------------------------------------------------------------- */ -static Tcl_Interp * -CreateSlave(interp, masterPtr, slavePath, safe) - Tcl_Interp *interp; /* Interp. to start search from. */ - Master *masterPtr; /* Master record. */ - char *slavePath; /* Path (name) of slave to create. */ - int safe; /* Should we make it "safe"? */ +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int argc; /* How many additional arguments? */ + char **argv; /* These are the additional args. */ { - Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ - Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ - Slave *slavePtr; /* Slave record. */ - Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ - int new; /* Indicates whether new entry. */ - int argc; /* Count of elements in slavePath. */ - char **argv; /* Elements in slavePath. */ - char *masterPath; /* Path to its master. */ - - if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { - return (Tcl_Interp *) NULL; - } - - if (argc < 2) { - masterInterp = interp; - if (argc == 1) { - slavePath = argv[0]; - } - } else { - masterPath = Tcl_Merge(argc-1, argv); - masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", masterPath, - "\" not found", (char *) NULL); - ckfree((char *) argv); - ckfree((char *) masterPath); - return (Tcl_Interp *) NULL; - } - ckfree((char *) masterPath); - slavePath = argv[argc-1]; - if (!safe) { - safe = Tcl_IsSafe(masterInterp); - } - } - hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); - if (new == 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", slavePath, - "\" already exists, cannot create", (char *) NULL); - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - slaveInterp = Tcl_CreateInterp(); - if (slaveInterp == (Tcl_Interp *) NULL) { - panic("CreateSlave: out of memory while creating a new interpreter"); + 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]); } - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); - slavePtr->masterInterp = masterInterp; - slavePtr->slaveEntry = hPtr; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath, - SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", - SlaveRecordDeleteProc, (ClientData) slavePtr); - Tcl_SetHashValue(hPtr, (ClientData) slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* - * Inherit the recursion limit. - */ - ((Interp *)slaveInterp)->maxNestingDepth = - ((Interp *)masterInterp)->maxNestingDepth ; + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); + Tcl_IncrRefCount(slaveObjPtr); - if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { - goto error; - } - } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { - goto error; - } + 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); - ckfree((char *) argv); - return slaveInterp; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAliasObj -- + * + * Object version: Creates an alias between two interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a new alias. + * + *---------------------------------------------------------------------- + */ -error: +int +Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int objc; /* How many additional arguments? */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ +{ + Tcl_Obj *slaveObjPtr, *targetObjPtr; + int result; - Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) - NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); + Tcl_IncrRefCount(slaveObjPtr); - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + targetObjPtr = Tcl_NewStringObj(targetCmd, -1); + Tcl_IncrRefCount(targetObjPtr); - (void) Tcl_DeleteCommand(masterInterp, slavePath); + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + targetObjPtr, objc, objv); - ckfree((char *) argv); - return (Tcl_Interp *) NULL; + Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(targetObjPtr); + return result; } /* *---------------------------------------------------------------------- * - * CreateInterpObject - + * Tcl_GetAlias -- * - * Helper function to do the actual work of creating a new interpreter - * and an object command. + * Gets information about an alias. * * Results: - * A Tcl result. + * A standard Tcl result. * * Side effects: - * See user documentation for details. + * None. * *---------------------------------------------------------------------- */ -static int -CreateInterpObject(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Invoking interpreter. */ - Master *masterPtr; /* Master record for same. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* with alias. */ +int +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, + argvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *argcPtr; /* (Return) count of addnl args. */ + char ***argvPtr; /* (Return) additional arguments. */ { - int safe; /* Create a safe interpreter? */ - int moreFlags; /* Expecting more flag args? */ - char *string; /* Local pointer to object string. */ - char *slavePath; /* Name of slave. */ - char localSlaveName[200]; /* Local area for creating names. */ - int i; /* Loop counter. */ - int len; /* Length of option argument. */ - static int interpCounter = 0; /* Unique id for created names. */ - - moreFlags = 1; - slavePath = NULL; - safe = Tcl_IsSafe(interp); + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + int i, objc; + Tcl_Obj **objv; - if ((objc < 2) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); - return TCL_ERROR; - } - for (i = 2; i < objc; i++) { - string = Tcl_GetStringFromObj(objv[i], &len); - if ((string[0] == '-') && (moreFlags != 0)) { - if ((string[1] == 's') && - (strncmp(string, "-safe", (size_t) len) == 0) && - (len > 1)){ - safe = 1; - } else if ((strncmp(string, "--", (size_t) len) == 0) && - (len > 1)) { - moreFlags = 0; - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", string, "\": should be -safe", - (char *) NULL); - return TCL_ERROR; - } - } else { - slavePath = string; - } + 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; } - if (slavePath == (char *) NULL) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); - /* - * Create an anonymous interpreter -- we choose its name and - * the name of the command. We check that the command name that - * we use for the interpreter does not collide with an existing - * command in the master interpreter. - */ - - while (1) { - Tcl_CmdInfo cmdInfo; - - sprintf(localSlaveName, "interp%d", interpCounter); - interpCounter++; - if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) { - break; - } - } - slavePath = localSlaveName; + if (targetInterpPtr != NULL) { + *targetInterpPtr = aliasPtr->targetInterp; } - if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1)); - return TCL_OK; - } else { - /* - * CreateSlave already set the result if there was an error, - * so we do not do it here. - */ - return TCL_ERROR; + if (targetNamePtr != NULL) { + *targetNamePtr = Tcl_GetString(objv[0]); + } + if (argcPtr != NULL) { + *argcPtr = objc - 1; + } + if (argvPtr != NULL) { + *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1)); + for (i = 1; i < objc; i++) { + *argvPtr[i - 1] = Tcl_GetString(objv[i]); + } } + return TCL_OK; } /* *---------------------------------------------------------------------- * - * DeleteOneInterpObject -- + * Tcl_ObjGetAlias -- * - * Helper function for DeleteInterpObject. It deals with deleting one - * interpreter at a time. + * Object version: Gets information about an alias. * * Results: * A standard Tcl result. * * Side effects: - * Deletes an interpreter and its interpreter object command. + * None. * *---------------------------------------------------------------------- */ -static int -DeleteOneInterpObject(interp, masterPtr, path) - Tcl_Interp *interp; /* Interpreter for reporting errors. */ - Master *masterPtr; /* Interim storage for master record.*/ - char *path; /* Path of interpreter to delete. */ +int +Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, + objvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *objcPtr; /* (Return) count of addnl args. */ + Tcl_Obj ***objvPtr; /* (Return) additional args. */ { - Slave *slavePtr; /* Interim storage for slave record. */ - Tcl_Interp *masterInterp; /* Master of interp. to delete. */ - Tcl_HashEntry *hPtr; /* Search element. */ - int localArgc; /* Local copy of count of elements in - * path (name) of interp. to delete. */ - char **localArgv; /* Local copy of path. */ - char *slaveName; /* Last component in path. */ - char *masterPath; /* One-before-last component in path.*/ - - if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + 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), - "bad interpreter path \"", path, "\"", (char *) NULL); + "alias \"", aliasName, "\" not found", (char *) NULL); return TCL_ERROR; } - if (localArgc < 2) { - masterInterp = interp; - if (localArgc == 0) { - slaveName = ""; - } else { - slaveName = localArgv[0]; - } - } else { - masterPath = Tcl_Merge(localArgc-1, localArgv); - masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", masterPath, "\" not found", - (char *) NULL); - ckfree((char *) localArgv); - ckfree((char *) masterPath); - return TCL_ERROR; - } - ckfree((char *) masterPath); - slaveName = localArgv[localArgc-1]; + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); + + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; } - hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); - if (hPtr == (Tcl_HashEntry *) NULL) { - ckfree((char *) localArgv); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", path, "\" not found", (char *) NULL); - return TCL_ERROR; + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = Tcl_GetString(objv[0]); } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) { - ckfree((char *) localArgv); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", path, "\" not found", (char *) NULL); - return TCL_ERROR; + if (objcPtr != (int *) NULL) { + *objcPtr = objc - 1; + } + if (objvPtr != (Tcl_Obj ***) NULL) { + *objvPtr = objv + 1; } - ckfree((char *) localArgv); - return TCL_OK; } /* *---------------------------------------------------------------------- * - * DeleteInterpObject -- + * TclPreventAliasLoop -- * - * Helper function to do the work of deleting zero or more - * interpreters and their interpreter object commands. + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. * * Results: - * A standard Tcl result. + * A standard Tcl object result. * * Side effects: - * Deletes interpreters and their interpreter object command. + * 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. * *---------------------------------------------------------------------- */ -static int -DeleteInterpObject(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Interpreter start search from. */ - Master *masterPtr; /* Interim storage for master record.*/ - int objc; /* Number of arguments in vector. */ - Tcl_Obj *CONST objv[]; /* with alias. */ +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. */ { - int i; - int len; + 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. + */ - for (i = 2; i < objc; i++) { - if (DeleteOneInterpObject(interp, masterPtr, - Tcl_GetStringFromObj(objv[i], &len)) - != TCL_OK) { + 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) { + int objc; + Tcl_Obj **objv; + + /* + * If the target of the next alias in the chain is the same as + * the source alias, we have a loop. + */ + + Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv); + aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, + Tcl_GetString(objv[0]), + 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; } - return TCL_OK; + + /* NOTREACHED */ } /* *---------------------------------------------------------------------- * - * AliasCreationHelper -- + * AliasCreate -- * - * Helper function to do the work to actually create an alias or - * delete an alias. + * Helper function to do the work to actually create an alias. * * Results: * A standard Tcl result. @@ -844,98 +1114,56 @@ DeleteInterpObject(interp, masterPtr, objc, objv) */ static int -AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, - aliasName, targetName, objc, objv) - Tcl_Interp *curInterp; /* Interp that invoked this proc. */ - Tcl_Interp *slaveInterp; /* Interp where alias cmd will live - * or from which alias will be - * deleted. */ - Tcl_Interp *masterInterp; /* Interp where target cmd will be. */ - Master *masterPtr; /* Master record for target interp. */ - char *aliasName; /* Name of alias cmd. */ - char *targetName; /* Name of target cmd. */ - int objc; /* Additional arguments to store */ - Tcl_Obj *CONST objv[]; /* with alias. */ +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; /* Storage for alias data. */ - Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ - Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ - int i; /* Loop index. */ - int new; /* Is it a new hash entry? */ - Target *targetPtr; /* Maps from target command in master - * to source command in slave. */ - Slave *slavePtr; /* Maps from source command in slave - * to target command in master. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); - - /* - * Slave record should be always present because it is created when - * the interpreter is created. - */ - - if (slavePtr == (Slave *) NULL) { - panic("AliasCreationHelper: could not find slave record"); - } - - if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { - if (objc != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp), - "malformed command: should be", - " \"alias ", aliasName, " {}\"", (char *) NULL); - return TCL_ERROR; - } + Alias *aliasPtr; + Tcl_HashEntry *hPtr; + int new; + Target *targetPtr; + Slave *slavePtr; + Master *masterPtr; - return DeleteAlias(curInterp, slaveInterp, aliasName); - } - aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); - aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); - aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); - strcpy(aliasPtr->aliasName, aliasName); - strcpy(aliasPtr->targetName, targetName); - aliasPtr->targetInterp = masterInterp; - - aliasPtr->objv = NULL; - aliasPtr->objc = objc; - - if (aliasPtr->objc > 0) { - aliasPtr->objv = - (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * - aliasPtr->objc); - for (i = 0; i < objc; i++) { - aliasPtr->objv[i] = objv[i]; - Tcl_IncrRefCount(objv[i]); - } - } - - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName, - AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc); - - if (TclPreventAliasLoop(curInterp, slaveInterp, - aliasPtr->slaveCmd) != TCL_OK) { - + aliasPtr->namePtr = namePtr; + Tcl_IncrRefCount(aliasPtr->namePtr); + aliasPtr->targetInterp = masterInterp; + aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr); + Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv); + Tcl_IncrRefCount(aliasPtr->prefixPtr); + + 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. - */ + * 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; - Command *cmdPtr = (Command*) aliasPtr->slaveCmd; + Tcl_DecrRefCount(aliasPtr->namePtr); + Tcl_DecrRefCount(aliasPtr->prefixPtr); + + cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - for (i = 0; i < objc; i++) { - Tcl_DecrRefCount(aliasPtr->objv[i]); - } - if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) { - ckfree((char *) aliasPtr->objv); - } - ckfree(aliasPtr->aliasName); - ckfree(aliasPtr->targetName); ckfree((char *) aliasPtr); /* @@ -950,21 +1178,22 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, * the alias command. Then retry. */ - do { - hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); - if (!new) { - tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommandFromToken(slaveInterp, - tmpAliasPtr->slaveCmd); - - /* - * The hash entry should be deleted by the Tcl_DeleteCommand - * above, in its command deletion callback (most likely this - * will be AliasCmdDeleteProc, which does the deletion). - */ - } - } while (new == 0); - aliasPtr->aliasEntry = hPtr; + 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); /* @@ -980,435 +1209,145 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, targetPtr->slaveCmd = aliasPtr->slaveCmd; targetPtr->slaveInterp = slaveInterp; + Tcl_MutexLock(&cntMutex); + masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master; do { - hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable, (char *) aliasCounter, &new); aliasCounter++; } while (new == 0); + Tcl_MutexUnlock(&cntMutex); Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + aliasPtr->targetEntryPtr = hPtr; - aliasPtr->targetEntry = hPtr; - - /* - * Make sure we clear out the object result when setting the string - * result. - */ - - Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1)); - + Tcl_SetObjResult(interp, namePtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InterpAliasesHelper -- + * AliasDelete -- * - * Computes a list of aliases defined in an interpreter. + * Deletes the given alias from the slave interpreter given. * * Results: * A standard Tcl result. * * Side effects: - * None. + * Deletes the alias from the slave interpreter. * *---------------------------------------------------------------------- */ static int -InterpAliasesHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Invoking interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* Actual arguments. */ +AliasDelete(interp, slaveInterp, namePtr) + Tcl_Interp *interp; /* Interpreter for result & errors. */ + Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ + Tcl_Obj *namePtr; /* Name of alias to describe. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - Slave *slavePtr; /* Record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Tcl_HashSearch hSearch; /* Iteration variable. */ - int len; /* Dummy length variable. */ - Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */ - - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } else { - slaveInterp = interp; - } - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, - "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - return TCL_OK; - } + Slave *slavePtr; + Alias *aliasPtr; + Tcl_HashEntry *hPtr; /* - * Build a list to return the aliases: + * 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. */ - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - elemObjPtr = Tcl_NewStringObj( - Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1); - Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr); - } - Tcl_SetObjResult(interp, listObjPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpAliasHelper - - * - * Handles the different forms of the "interp alias" command: - * - interp alias slavePath aliasName - * Describes an alias. - * - interp alias slavePath aliasName {} - * Deletes an alias. - * - interp alias slavePath srcCmd masterPath targetCmd args... - * Creates an alias. - * - * Results: - * A Tcl result. - * - * Side effects: - * See user documentation for details. - * - *---------------------------------------------------------------------- - */ - -static int -InterpAliasHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp, /* Interpreters used when */ - *masterInterp; /* creating an alias btn siblings. */ - Master *masterMasterPtr; /* Master record for master interp. */ - int len; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd masterPath masterCmd ?args ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not find interpreter \"", - Tcl_GetStringFromObj(objv[2], &len), "\"", - (char *) NULL); - return TCL_ERROR; - } - if (objc == 4) { - return DescribeAlias(interp, slaveInterp, - Tcl_GetStringFromObj(objv[3], &len)); - } - if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) { - return DeleteAlias(interp, slaveInterp, - Tcl_GetStringFromObj(objv[3], &len)); - } - if (objc < 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd masterPath masterCmd ?args ..?"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not find interpreter \"", - Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL); - return TCL_ERROR; - } - return AliasCreationHelper(interp, slaveInterp, masterInterp, - masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len), - Tcl_GetStringFromObj(objv[5], &len), - objc-6, objv+6); -} - -/* - *---------------------------------------------------------------------- - * - * InterpExistsHelper -- - * - * Computes whether a named interpreter exists or not. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -InterpExistsHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Obj *objPtr; - int len; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + 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; } - if (objc == 3) { - if (GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL) == - (Tcl_Interp *) NULL) { - objPtr = Tcl_NewIntObj(0); - } else { - objPtr = Tcl_NewIntObj(1); - } - } else { - objPtr = Tcl_NewIntObj(1); - } - Tcl_SetObjResult(interp, objPtr); - + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InterpEvalHelper -- + * AliasDescribe -- * - * Helper function to handle all the details of evaluating a - * command in another interpreter. + * 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: - * Whatever the command itself does. + * None. * *---------------------------------------------------------------------- */ static int -InterpEvalHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +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. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - Interp *iPtr; /* Internal data type for slave. */ - int len; /* Dummy length variable. */ - int result; - Tcl_Obj *namePtr, *objPtr; /* Local object pointer. */ - char *string; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - objPtr = Tcl_ConcatObj(objc-3, objv+3); - Tcl_IncrRefCount(objPtr); - - Tcl_Preserve((ClientData) slaveInterp); - result = Tcl_EvalObj(slaveInterp, objPtr); - - Tcl_DecrRefCount(objPtr); + Slave *slavePtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. + * 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. */ - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - - } - Tcl_Release((ClientData) slaveInterp); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * InterpExposeHelper -- - * - * Helper function to handle the details of exposing a command in - * another interpreter. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Exposes a command. From now on the command can be called by scripts - * in the interpreter in which it was exposed. - * - *---------------------------------------------------------------------- - */ - -static int -InterpExposeHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ - - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot expose commands", - (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_ExposeCommand(slaveInterp, - Tcl_GetStringFromObj(objv[3], &len), - (objc == 5 ? - Tcl_GetStringFromObj(objv[4], &len) : - Tcl_GetStringFromObj(objv[3], &len))) - == TCL_ERROR) { - if (interp != slaveInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - } - return TCL_ERROR; + 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); + Tcl_SetObjResult(interp, aliasPtr->prefixPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InterpHideHelper -- + * AliasList -- * - * Helper function that handles the details of hiding a command in - * another interpreter. + * Computes a list of aliases defined in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: - * Hides a command. From now on the command cannot be called by - * scripts in that interpreter. + * None. * *---------------------------------------------------------------------- */ static int -InterpHideHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +AliasList(interp, slaveInterp) + Tcl_Interp *interp; /* Interp for data return. */ + Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ + Tcl_HashEntry *entryPtr; + Tcl_HashSearch hashSearch; + Tcl_Obj *resultPtr; + Alias *aliasPtr; + Slave *slavePtr; - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot hide commands", - (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len), - (objc == 5 ? - Tcl_GetStringFromObj(objv[4], &len) : - Tcl_GetStringFromObj(objv[3], &len))) - == TCL_ERROR) { - if (interp != slaveInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - } - return TCL_ERROR; + 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; } @@ -1416,524 +1355,186 @@ InterpHideHelper(interp, masterPtr, objc, objv) /* *---------------------------------------------------------------------- * - * InterpHiddenHelper -- + * AliasObjCmd -- * - * Computes the list of hidden commands in a named interpreter. + * 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: - * None. + * 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 -InterpHiddenHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +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. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - int len; - Tcl_HashTable *hTblPtr; /* Hidden command table. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Tcl_HashSearch hSearch; /* Iteration variable. */ - Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_Interp *targetInterp; + Alias *aliasPtr; + int result, prefc, cmdc; + Tcl_Obj *cmdPtr; + Tcl_Obj **prefv, **cmdv; + + aliasPtr = (Alias *) clientData; + targetInterp = aliasPtr->targetInterp; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), - &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } else { - slaveInterp = interp; - } - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp, - "tclHiddenCmds", NULL); - if (hTblPtr != (Tcl_HashTable *) NULL) { - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_Preserve((ClientData) targetInterp); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); - } - } - Tcl_SetObjResult(interp, listObjPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpInvokeHiddenHelper -- - * - * Helper routine to handle the details of invoking a hidden - * command in another interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Whatever the hidden command does. - * - *---------------------------------------------------------------------- - */ + ((Interp *) targetInterp)->numLevels++; -static int -InterpInvokeHiddenHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - int doGlobal = 0; - int len; - int result; - Tcl_Obj *namePtr, *objPtr; - Tcl_Interp *slaveInterp; - Interp *iPtr; - char *string; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-global? cmd ?arg ..?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "not allowed to invoke hidden commands from safe interpreter", - (char *) NULL); - return TCL_ERROR; - } - if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) { - doGlobal = 1; - if (objc < 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-global? cmd ?arg ..?"); - return TCL_ERROR; - } - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - Tcl_Preserve((ClientData) slaveInterp); - if (doGlobal) { - result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4, - TCL_INVOKE_HIDDEN); - } else { - result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN); - } + Tcl_ResetResult(targetInterp); + Tcl_AllowExceptions(targetInterp); /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. + * Append the arguments to the command prefix and invoke the command + * in the target interp's global namespace. */ + + Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv); + cmdPtr = Tcl_NewListObj(prefc, prefv); + Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1); + Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv); + result = TclObjInvoke(targetInterp, cmdc, cmdv, + TCL_INVOKE_NO_TRACEBACK); + Tcl_DecrRefCount(cmdPtr); + + ((Interp *) targetInterp)->numLevels--; + + /* + * Check if we are at the bottom of the stack for the target interpreter. + * If so, check for special return codes. + */ + + if (((Interp *) targetInterp)->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo((Interp *) targetInterp); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult(targetInterp); + if (result == TCL_BREAK) { + Tcl_SetObjResult(targetInterp, + Tcl_NewStringObj("invoked \"break\" outside of a loop", + -1)); + } else if (result == TCL_CONTINUE) { + Tcl_SetObjResult(targetInterp, + Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", + -1)); + } else { + char buf[32 + TCL_INTEGER_SPACE]; - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - } - - /* - * Move the result object from the slave to the master. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + sprintf(buf, "command returned bad code: %d", result); + Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); + } + result = TCL_ERROR; + } } - Tcl_Release((ClientData) slaveInterp); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * InterpMarkTrustedHelper -- - * - * Helper function to handle the details of marking another - * interpreter as trusted (unsafe). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Henceforth the hard-wired checks for safety will not prevent - * this interpreter from performing certain operations. - * - *---------------------------------------------------------------------- - */ -static int -InterpMarkTrustedHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "path"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "\"", Tcl_GetStringFromObj(objv[0], &len), - " marktrusted\" can only", - " be invoked from a trusted interpreter", - (char *) NULL); - return TCL_ERROR; - } + TclTransferResult(targetInterp, result, interp); - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - return MarkTrusted(slaveInterp); + Tcl_Release((ClientData) targetInterp); + return result; } /* *---------------------------------------------------------------------- * - * InterpIsSafeHelper -- + * AliasObjCmdDeleteProc -- * - * Computes whether a named interpreter is safe. + * Is invoked when an alias command is deleted in a slave. Cleans up + * all storage associated with this alias. * * Results: - * A standard Tcl result. - * - * Side effects: * None. * - *---------------------------------------------------------------------- - */ - -static int -InterpIsSafeHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ - Tcl_Obj *objPtr; /* Local object pointer. */ - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", - Tcl_GetStringFromObj(objv[2], &len), "\" not found", - (char *) NULL); - return TCL_ERROR; - } - objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); - } else { - objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp)); - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpSlavesHelper -- - * - * Computes a list of slave interpreters of a named interpreter. - * - * Results: - * A standard Tcl result. - * * Side effects: - * None. + * Deletes the alias record and its entry in the alias table for + * the interpreter. * *---------------------------------------------------------------------- */ -static int -InterpSlavesHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +static void +AliasObjCmdDeleteProc(clientData) + ClientData clientData; /* The alias record for this alias. */ { - int len; - Tcl_HashEntry *hPtr; /* Search variable. */ - Tcl_HashSearch hSearch; /* Iteration variable. */ - Tcl_Obj *listObjPtr; /* Local object pointers. */ + Alias *aliasPtr; + Target *targetPtr; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - if (GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr) == - (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } + aliasPtr = (Alias *) clientData; + + Tcl_DecrRefCount(aliasPtr->namePtr); + Tcl_DecrRefCount(aliasPtr->prefixPtr); + Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr); + ckfree((char *) targetPtr); + Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj( - Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1)); - } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; + ckfree((char *) aliasPtr); } /* *---------------------------------------------------------------------- * - * InterpShareHelper -- + * Tcl_CreateSlave -- * - * Helper function to handle the details of sharing a channel between - * interpreters. + * 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: - * A standard Tcl result. + * Returns the interpreter structure created, or NULL if an error + * occurred. * * Side effects: - * After this call the named channel will be shared between the - * interpreters named in the arguments. + * Creates a new interpreter and a new interpreter object command in + * the interpreter indicated by the slavePath argument. * *---------------------------------------------------------------------- */ -static int -InterpShareHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_Interp * +Tcl_CreateSlave(interp, slavePath, isSafe) + Tcl_Interp *interp; /* Interpreter to start search at. */ + char *slavePath; /* Name of slave to create. */ + int isSafe; /* Should new slave be "safe" ? */ { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - int len; - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[4], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[4], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len), - NULL); - if (chan == (Tcl_Channel) NULL) { - if (interp != masterInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpTargetHelper -- - * - * Helper function to compute the target of an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + Tcl_Obj *pathPtr; + Tcl_Interp *slaveInterp; -static int -InterpTargetHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - int len; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path alias"); - return TCL_ERROR; - } - return GetTarget(interp, - Tcl_GetStringFromObj(objv[2], &len), - Tcl_GetStringFromObj(objv[3], &len)); -} - -/* - *---------------------------------------------------------------------- - * - * InterpTransferHelper -- - * - * Helper function to handle the details of transferring ownership - * of a channel between interpreters. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * After the call, the named channel will be registered in the target - * interpreter and no longer available for use in the source interpreter. - * - *---------------------------------------------------------------------- - */ + pathPtr = Tcl_NewStringObj(slavePath, -1); + slaveInterp = SlaveCreate(interp, pathPtr, isSafe); + Tcl_DecrRefCount(pathPtr); -static int -InterpTransferHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - int len; - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[4], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[4], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, - Tcl_GetStringFromObj(objv[3], &len), NULL); - if (chan == (Tcl_Channel) NULL) { - if (interp != masterInterp) { - - /* - * After fixing objresult, this code will change to: - * Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - if (interp != masterInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - return TCL_OK; + return slaveInterp; } /* *---------------------------------------------------------------------- * - * DescribeAlias -- + * Tcl_GetSlave -- * - * 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. + * Finds a slave interpreter by its path name. * * Results: - * A standard Tcl result. + * Returns a Tcl_Interp * for the named interpreter or NULL if not + * found. * * Side effects: * None. @@ -1941,103 +1542,48 @@ InterpTransferHelper(interp, masterPtr, objc, objv) *---------------------------------------------------------------------- */ -static int -DescribeAlias(interp, slaveInterp, aliasName) - Tcl_Interp *interp; /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ - char *aliasName; /* Name of alias to describe. */ +Tcl_Interp * +Tcl_GetSlave(interp, slavePath) + Tcl_Interp *interp; /* Interpreter to start search from. */ + char *slavePath; /* Path of slave to find. */ { - Slave *slavePtr; /* Slave interp slave record. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Alias *aliasPtr; /* Structure describing alias. */ - int i; /* Loop variable. */ - Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_Obj *pathPtr; + Tcl_Interp *slaveInterp; - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); + pathPtr = Tcl_NewStringObj(slavePath, -1); + slaveInterp = GetInterp(interp, pathPtr); + Tcl_DecrRefCount(pathPtr); - /* - * The slave record should always be present because it is created - * by Tcl_CreateInterp. - */ - - if (slavePtr == (Slave *) NULL) { - panic("DescribeAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - return TCL_OK; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(aliasPtr->targetName, -1)); - for (i = 0; i < aliasPtr->objc; i++) { - Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]); - } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; + return slaveInterp; } /* *---------------------------------------------------------------------- * - * DeleteAlias -- + * Tcl_GetMaster -- * - * Deletes the given alias from the slave interpreter given. + * Finds the master interpreter of a slave interpreter. * * Results: - * A standard Tcl result. + * Returns a Tcl_Interp * for the master interpreter or NULL if none. * * Side effects: - * Deletes the alias from the slave interpreter. + * None. * *---------------------------------------------------------------------- */ -static int -DeleteAlias(interp, slaveInterp, aliasName) - Tcl_Interp *interp; /* Interpreter for result and errors. */ - Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ - char *aliasName; /* Name of alias to delete. */ +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ { - Slave *slavePtr; /* Slave record for slave interpreter. */ - Alias *aliasPtr; /* Points at alias structure to delete. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "alias \"", aliasName, "\" not found", (char *) NULL); - return TCL_ERROR; - } - - /* - * Get the alias from the alias table, then delete the command. The - * deleteProc on the alias command will take care of removing the entry - * from the alias table. - */ + Slave *slavePtr; /* Slave record of this interpreter. */ - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "alias \"", aliasName, "\" not found", (char *) NULL); - return TCL_ERROR; + if (interp == (Tcl_Interp *) NULL) { + return NULL; } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - /* - * NOTE: The deleteProc for this command will delete the - * alias from the hash table. The deleteProc will also - * delete the target information from the master interpreter - * target table. - */ - - (void) Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - - return TCL_OK; + slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; + return slavePtr->masterInterp; } /* @@ -2071,316 +1617,378 @@ Tcl_GetInterpPath(askingInterp, targetInterp) Tcl_Interp *askingInterp; /* Interpreter to start search from. */ Tcl_Interp *targetInterp; /* Interpreter to find. */ { - Master *masterPtr; /* Interim storage for Master record. */ - Slave *slavePtr; /* Interim storage for Slave record. */ + InterpInfo *iiPtr; if (targetInterp == askingInterp) { return TCL_OK; } - if (targetInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - return TCL_ERROR; + if (targetInterp == NULL) { + return TCL_ERROR; } - if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { - - /* - * The result of askingInterp was set by recursive call. - */ - + iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { return TCL_ERROR; } - masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_GetInterpPath: could not find master record"); - } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), - slavePtr->slaveEntry)); + Tcl_AppendElement(askingInterp, + Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * GetTarget -- + * GetInterp -- * - * Sets the result of the invoking interpreter to a path name for - * the target interpreter of an alias in one of the slaves. + * Helper function to find a slave interpreter given a pathname. * * Results: - * TCL_OK if the target interpreter of the alias is a slave of the - * invoking interpreter, TCL_ERROR else. + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: - * Sets the result of the invoking interpreter. + * Assigns to the pointer variable passed in, if not NULL. * *---------------------------------------------------------------------- */ -static int -GetTarget(askingInterp, path, aliasName) - Tcl_Interp *askingInterp; /* Interpreter to start search from. */ - char *path; /* The path of the interp to find. */ - char *aliasName; /* The target of this allias. */ +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_Interp *slaveInterp; /* Interim storage for slave. */ - Slave *slaveSlavePtr; /* Its Slave record. */ - Master *masterPtr; /* Interim storage for Master record. */ Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Data describing the alias. */ + Slave *slavePtr; /* Interim slave record. */ + Tcl_Obj **objv; + int objc, i; + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ + InterpInfo *masterInfoPtr; - Tcl_ResetResult(askingInterp); - masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("GetTarget: could not find master record"); - } - slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), - "could not find interpreter \"", path, "\"", (char *) NULL); - return TCL_ERROR; - } - slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slaveSlavePtr == (Slave *) NULL) { - panic("GetTarget: could not find slave record"); + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + return NULL; } - hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), - "alias \"", aliasName, "\" in path \"", path, "\" not found", - (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (aliasPtr == (Alias *) NULL) { - panic("GetTarget: could not find alias record"); + + 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 (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { - Tcl_ResetResult(askingInterp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), - "target interpreter for alias \"", - aliasName, "\" in path \"", path, "\" is not my descendant", - (char *) NULL); - return TCL_ERROR; + if (searchInterp == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not find interpreter \"", + Tcl_GetString(pathPtr), "\"", (char *) NULL); } - - return TCL_OK; + return searchInterp; } /* *---------------------------------------------------------------------- * - * Tcl_InterpCmd -- + * SlaveCreate -- * - * This procedure is invoked to process the "interp" Tcl command. - * See the user documentation for details on what it does. + * 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: - * A standard Tcl result. + * 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: - * See the user documentation. + * Creates a new slave interpreter and a new object command. * *---------------------------------------------------------------------- */ - /* 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. */ -{ - Master *masterPtr; /* Master record for current interp. */ - int result; /* Local result variable. */ - /* - * These are all the different subcommands for this command: - */ - - static char *subCmds[] = { - "alias", "aliases", "create", "delete", "eval", "exists", - "expose", "hide", "hidden", "issafe", "invokehidden", - "marktrusted", "slaves", "share", "target", "transfer", - (char *) NULL}; - enum ISubCmdIdx { - IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx, - IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx, - IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx, - ITargetIdx, ITransferIdx - } index; +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) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; + 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]); } - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_InterpCmd: could not find master record"); + if (safe == 0) { + safe = Tcl_IsSafe(masterInterp); } - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", - 0, (int *) &index); - if (result != TCL_OK) { - return result; + 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); - switch (index) { - case IAliasIdx: - return InterpAliasHelper(interp, masterPtr, objc, objv); - case IAliasesIdx: - return InterpAliasesHelper(interp, masterPtr, objc, objv); - case ICreateIdx: - return CreateInterpObject(interp, masterPtr, objc, objv); - case IDeleteIdx: - return DeleteInterpObject(interp, masterPtr, objc, objv); - case IEvalIdx: - return InterpEvalHelper(interp, masterPtr, objc, objv); - case IExistsIdx: - return InterpExistsHelper(interp, masterPtr, objc, objv); - case IExposeIdx: - return InterpExposeHelper(interp, masterPtr, objc, objv); - case IHideIdx: - return InterpHideHelper(interp, masterPtr, objc, objv); - case IHiddenIdx: - return InterpHiddenHelper(interp, masterPtr, objc, objv); - case IIsSafeIdx: - return InterpIsSafeHelper(interp, masterPtr, objc, objv); - case IInvokeHiddenIdx: - return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv); - case IMarkTrustedIdx: - return InterpMarkTrustedHelper(interp, masterPtr, objc, objv); - case ISlavesIdx: - return InterpSlavesHelper(interp, masterPtr, objc, objv); - case IShareIdx: - return InterpShareHelper(interp, masterPtr, objc, objv); - case ITargetIdx: - return InterpTargetHelper(interp, masterPtr, objc, objv); - case ITransferIdx: - return InterpTransferHelper(interp, masterPtr, objc, objv); + /* + * 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; + } } + return slaveInterp; + + error: + TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_DeleteInterp(slaveInterp); - return TCL_ERROR; + return NULL; } /* *---------------------------------------------------------------------- * - * SlaveAliasHelper -- + * SlaveObjCmd -- * - * Helper function to construct or query an alias for a slave - * interpreter. + * 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: - * Potentially creates a new alias. + * See user documentation for details. * *---------------------------------------------------------------------- */ static int -SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +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. */ { - Master *masterPtr; - int len; + Tcl_Interp *slaveInterp; + int index; + static char *options[] = { + "alias", "aliases", "eval", "expose", + "hide", "hidden", "issafe", "invokehidden", + "marktrusted", NULL + }; + enum options { + OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE, + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, + OPT_MARKTRUSTED + }; + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == NULL) { + panic("SlaveObjCmd: interpreter has been deleted"); + } - switch (objc-2) { - case 0: - Tcl_WrongNumArgs(interp, 2, objv, - "aliasName ?targetName? ?args..?"); - return TCL_ERROR; + 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; + } - case 1: - - /* - * Return the name of the command in the current - * interpreter for which the argument is an alias in the - * slave interpreter, and the list of saved arguments - */ - - return DescribeAlias(interp, slaveInterp, - Tcl_GetStringFromObj(objv[2], &len)); - - default: - masterPtr = (Master *) Tcl_GetAssocData(interp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); - } - return AliasCreationHelper(interp, slaveInterp, interp, - masterPtr, - Tcl_GetStringFromObj(objv[2], &len), - Tcl_GetStringFromObj(objv[3], &len), - objc-4, objv+4); + switch ((enum options) index) { + case OPT_ALIAS: { + 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: { + 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: { + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp)); + return TCL_OK; + } + case OPT_INVOKEHIDDEN: { + int global, i, index; + static 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); + } } + + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * SlaveAliasesHelper -- + * SlaveObjCmdDeleteProc -- * - * Computes a list of aliases defined in a slave interpreter. + * 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: - * A standard Tcl result. + * None. * * Side effects: - * None. + * Cleans up all state associated with the slave interpreter and + * destroys the slave interpreter. * *---------------------------------------------------------------------- */ -static int -SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +static void +SlaveObjCmdDeleteProc(clientData) + ClientData clientData; /* The SlaveRecord for the command. */ { - Tcl_HashEntry *hPtr; /* For local searches. */ - Tcl_HashSearch hSearch; /* For local searches. */ - Tcl_Obj *listObjPtr; /* Local object pointer. */ - Alias *aliasPtr; /* Alias information. */ + 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; /* - * Return the names of all the aliases created in the - * slave interpreter. + * Unlink the slave from its master interpreter. */ - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), - &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(aliasPtr->aliasName, -1)); + 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); } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveEvalHelper -- + * SlaveEval -- * * Helper function to evaluate a command in a slave interpreter. * @@ -2394,84 +2002,37 @@ SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +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. */ { - Interp *iPtr; /* Internal data type for slave. */ - Tcl_Obj *objPtr; /* Local object pointer. */ - Tcl_Obj *namePtr; /* Local object pointer. */ - int len; - char *string; int result; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); - return TCL_ERROR; - } - - objPtr = Tcl_ConcatObj(objc-2, objv+2); - Tcl_IncrRefCount(objPtr); + Tcl_Obj *objPtr; Tcl_Preserve((ClientData) slaveInterp); - result = Tcl_EvalObj(slaveInterp, objPtr); - - Tcl_DecrRefCount(objPtr); + Tcl_AllowExceptions(slaveInterp); - /* - * Make the result and any error information accessible. We have - * to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. - */ - - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from the - * destination interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + if (objc == 1) { + result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); + } 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; + return result; } /* *---------------------------------------------------------------------- * - * SlaveExposeHelper -- + * SlaveExpose -- * * Helper function to expose a command in a slave interpreter. * @@ -2486,33 +2047,26 @@ SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +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. */ { - int len; + char *name; - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot expose commands", - (char *) NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot expose commands", + (char *) NULL); + return TCL_ERROR; } - if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len), - (objc == 4 ? - Tcl_GetStringFromObj(objv[3], &len) : - Tcl_GetStringFromObj(objv[2], &len))) - == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - 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; } @@ -2520,7 +2074,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveHideHelper -- + * SlaveHide -- * * Helper function to hide a command in a slave interpreter. * @@ -2535,33 +2089,26 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +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. */ { - int len; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } + char *name; + if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot hide commands", - (char *) NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot hide commands", + (char *) NULL); + return TCL_ERROR; } - if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len), - (objc == 4 ? - Tcl_GetStringFromObj(objv[3], &len) : - Tcl_GetStringFromObj(objv[2], &len))) - == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - 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; } @@ -2569,7 +2116,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveHiddenHelper -- + * SlaveHidden -- * * Helper function to compute list of hidden commands in a slave * interpreter. @@ -2584,78 +2131,33 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +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. */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp, - "tclHiddenCmds", NULL); + 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(interp, listObjPtr, - Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); - } - } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveIsSafeHelper -- - * - * Helper function to compute whether a slave interpreter is safe. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { -static int -SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ -{ - Tcl_Obj *resultPtr; /* Local object pointer. */ - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_ListObjAppendElement(NULL, listObjPtr, + Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); + } } - resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); - - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveInvokeHiddenHelper -- + * SlaveInvokeHidden -- * * Helper function to invoke a hidden command in a slave interpreter. * @@ -2669,96 +2171,35 @@ SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +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. */ { - Interp *iPtr; - Master *masterPtr; - int doGlobal = 0; int result; - int len; - char *string; - Tcl_Obj *namePtr, *objPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-global? cmd ?arg ..?"); - return TCL_ERROR; - } + if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "not allowed to invoke hidden commands from safe interpreter", - (char *) NULL); - return TCL_ERROR; - } - if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) { - doGlobal = 1; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-global? cmd ?arg ..?"); - return TCL_ERROR; - } - } - masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "not allowed to invoke hidden commands from safe interpreter", + -1); + return TCL_ERROR; } + Tcl_Preserve((ClientData) slaveInterp); - if (doGlobal) { - result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3, + Tcl_AllowExceptions(slaveInterp); + + if (global) { + result = TclObjInvokeGlobal(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } else { - result = TclObjInvoke(slaveInterp, objc-2, objv+2, - TCL_INVOKE_HIDDEN); + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } - /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. - */ - - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } + TclTransferResult(slaveInterp, result, interp); - /* - * Move the result object from the slave to the master. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - } Tcl_Release((ClientData) slaveInterp); return result; } @@ -2766,7 +2207,7 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveMarkTrustedHelper -- + * SlaveMarkTrusted -- * * Helper function to mark a slave interpreter as trusted (unsafe). * @@ -2781,675 +2222,18 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveMarkTrusted(interp, slaveInterp) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* The slave interpreter which will be + * marked trusted. */ { - int len; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"", - " can only be invoked from a trusted interpreter", - (char *) NULL); - return TCL_ERROR; - } - return MarkTrusted(slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * SlaveObjectCmd -- - * - * 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 -SlaveObjectCmd(clientData, interp, objc, objv) - ClientData clientData; /* Slave interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument vector. */ -{ - Slave *slavePtr; /* Slave record. */ - Tcl_Interp *slaveInterp; /* Slave interpreter. */ - int result; /* Loop counter, status return. */ - int len; /* Length of command name. */ - - /* - * These are all the different subcommands for this command: - */ - - static char *subCmds[] = { - "alias", "aliases", - "eval", "expose", - "hide", "hidden", - "issafe", "invokehidden", - "marktrusted", - (char *) NULL}; - enum ISubCmdIdx { - IAliasIdx, IAliasesIdx, - IEvalIdx, IExposeIdx, - IHideIdx, IHiddenIdx, - IIsSafeIdx, IInvokeHiddenIdx, - IMarkTrustedIdx - } index; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; - } - - slaveInterp = (Tcl_Interp *) clientData; - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter ", Tcl_GetStringFromObj(objv[0], &len), - " has been deleted", (char *) NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot mark trusted", + (char *) NULL); return TCL_ERROR; } - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, - "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("SlaveObjectCmd: could not find slave record"); - } - - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", - 0, (int *) &index); - if (result != TCL_OK) { - return result; - } - - switch (index) { - case IAliasIdx: - return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv); - case IAliasesIdx: - return SlaveAliasesHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IEvalIdx: - return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv); - case IExposeIdx: - return SlaveExposeHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IHideIdx: - return SlaveHideHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IHiddenIdx: - return SlaveHiddenHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IIsSafeIdx: - return SlaveIsSafeHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IInvokeHiddenIdx: - return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IMarkTrustedIdx: - return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, - objc, objv); - } - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveObjectDeleteProc -- - * - * 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 -SlaveObjectDeleteProc(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 = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); - if (slavePtr == (Slave *) NULL) { - panic("SlaveObjectDeleteProc: could not find slave record"); - } - - /* - * Delete the entry in the slave table in the master interpreter now. - * This is to avoid an infinite loop in the Master hash table cleanup in - * the master interpreter. This can happen if this slave is being deleted - * because the master is being deleted and the slave deletion is deferred - * because it is still active. - */ - - Tcl_DeleteHashEntry(slavePtr->slaveEntry); - - /* - * Set to NULL so that when the slave record is cleaned up in the slave - * it does not try to delete the command causing all sorts of grief. - * See SlaveRecordDeleteProc(). - */ - - slavePtr->interpCmd = NULL; - - /* - * Destroy the interpreter - this will cause all the deleteProcs for - * all commands (including aliases) to run. - * - * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! - */ - - Tcl_DeleteInterp(slavePtr->slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * AliasCmd -- - * - * 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 -AliasCmd(clientData, interp, objc, objv) - ClientData clientData; /* Alias record. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ -{ - Tcl_Interp *targetInterp; /* Target for alias exec. */ - Interp *iPtr; /* Internal type of target. */ - Alias *aliasPtr; /* Describes the alias. */ - Tcl_Command cmd; /* The target command. */ - Command *cmdPtr; /* Points to target command. */ - Tcl_Namespace *targetNsPtr; /* Target command's namespace. */ - int result; /* Result of execution. */ - int i, j, addObjc; /* Loop counters. */ - int localObjc; /* Local argument count. */ - Tcl_Obj **localObjv; /* Local argument vector. */ - Tcl_Obj *namePtr, *objPtr; /* Local object pointers. */ - char *string; /* Local object string rep. */ - int len; /* Dummy length arg. */ - - aliasPtr = (Alias *) clientData; - targetInterp = aliasPtr->targetInterp; - - /* - * Look for the target command in the global namespace of the target - * interpreter. - */ - - cmdPtr = NULL; - targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp); - cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName, - targetNsPtr, /*flags*/ 0); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - - iPtr = (Interp *) targetInterp; - - /* - * If the command does not exist, invoke "unknown" in the master. - */ - - if (cmdPtr == NULL) { - addObjc = aliasPtr->objc; - localObjc = addObjc + objc + 1; - localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) - * localObjc); - - localObjv[0] = Tcl_NewStringObj("unknown", -1); - localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1); - Tcl_IncrRefCount(localObjv[0]); - Tcl_IncrRefCount(localObjv[1]); - - for (i = 0, j = 2; i < addObjc; i++, j++) { - localObjv[j] = aliasPtr->objv[i]; - } - for (i = 1; i < objc; i++, j++) { - localObjv[j] = objv[i]; - } - Tcl_Preserve((ClientData) targetInterp); - result = TclObjInvoke(targetInterp, localObjc, localObjv, 0); - - Tcl_DecrRefCount(localObjv[0]); - Tcl_DecrRefCount(localObjv[1]); - - ckfree((char *) localObjv); - - if (targetInterp != interp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(targetInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Transfer the result from the target interpreter to the - * calling interpreter. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp)); - Tcl_ResetResult(targetInterp); - } - - Tcl_Release((ClientData) targetInterp); - return result; - } - - /* - * Otherwise invoke the regular target command. - */ - - if (aliasPtr->objc <= 0) { - localObjv = (Tcl_Obj **) objv; - localObjc = objc; - } else { - addObjc = aliasPtr->objc; - localObjc = objc + addObjc; - localObjv = - (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc); - localObjv[0] = objv[0]; - for (i = 0, j = 1; i < addObjc; i++, j++) { - localObjv[j] = aliasPtr->objv[i]; - } - for (i = 1; i < objc; i++, j++) { - localObjv[j] = objv[i]; - } - } - - iPtr->numLevels++; - Tcl_Preserve((ClientData) targetInterp); - - /* - * Reset the interpreter to its clean state; we do not know what state - * it is in now.. - */ - - Tcl_ResetResult(targetInterp); - result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp, - localObjc, localObjv); - - iPtr->numLevels--; - - /* - * Check if we are at the bottom of the stack for the target interpreter. - * If so, check for special return codes. - */ - - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR)) { - Tcl_ResetResult(targetInterp); - if (result == TCL_BREAK) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj("invoked \"break\" outside of a loop", - -1)); - } else if (result == TCL_CONTINUE) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", - -1)); - } else { - char buf[128]; - - sprintf(buf, "command returned bad code: %d", result); - Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); - } - result = TCL_ERROR; - } - } - - /* - * Clean up any locally allocated argument vector structure. - */ - - if (localObjv != objv) { - ckfree((char *) localObjv); - } - - /* - * Move the result from the target interpreter to the invoking - * interpreter if they are different. - * - * Note: We cannot use aliasPtr any more because the alias may have - * been deleted. - */ - - if (interp != targetInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer the error information from - * the target interpreter back to our interpreter. - */ - - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(targetInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL, - TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp)); - Tcl_ResetResult(targetInterp); - } - Tcl_Release((ClientData) targetInterp); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * AliasCmdDeleteProc -- - * - * Is invoked when an alias command is deleted in a slave. Cleans up - * all storage associated with this alias. - * - * Results: - * None. - * - * Side effects: - * Deletes the alias record and its entry in the alias table for - * the interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -AliasCmdDeleteProc(clientData) - ClientData clientData; /* The alias record for this alias. */ -{ - Alias *aliasPtr; /* Alias record for alias to delete. */ - Target *targetPtr; /* Record for target of this alias. */ - int i; /* Loop counter. */ - - aliasPtr = (Alias *) clientData; - - targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); - ckfree((char *) targetPtr); - Tcl_DeleteHashEntry(aliasPtr->targetEntry); - - ckfree((char *) aliasPtr->targetName); - ckfree((char *) aliasPtr->aliasName); - for (i = 0; i < aliasPtr->objc; i++) { - Tcl_DecrRefCount(aliasPtr->objv[i]); - } - if (aliasPtr->objv != (Tcl_Obj **) NULL) { - ckfree((char *) aliasPtr->objv); - } - - Tcl_DeleteHashEntry(aliasPtr->aliasEntry); - - ckfree((char *) aliasPtr); -} - -/* - *---------------------------------------------------------------------- - * - * MasterRecordDeleteProc - - * - * Is invoked when an interpreter (which is using the "interp" facility) - * is deleted, and it cleans up the storage associated with the - * "tclMasterRecord" assoc-data entry. - * - * Results: - * None. - * - * Side effects: - * Cleans up storage. - * - *---------------------------------------------------------------------- - */ - -static void -MasterRecordDeleteProc(clientData, interp) - ClientData clientData; /* Master record for deleted interp. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ -{ - Target *targetPtr; /* Loop variable. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Tcl_HashSearch hSearch; /* Search record (internal). */ - Slave *slavePtr; /* Loop variable. */ - Master *masterPtr; /* Interim storage. */ - - masterPtr = (Master *) clientData; - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd); - } - Tcl_DeleteHashTable(&(masterPtr->slaveTable)); - - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { - targetPtr = (Target *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, - targetPtr->slaveCmd); - } - Tcl_DeleteHashTable(&(masterPtr->targetTable)); - - ckfree((char *) masterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SlaveRecordDeleteProc -- - * - * Is invoked when an interpreter (which is using the interp facility) - * is deleted, and it cleans up the storage associated with the - * tclSlaveRecord assoc-data entry. - * - * Results: - * None - * - * Side effects: - * Cleans up storage. - * - *---------------------------------------------------------------------- - */ - -static void -SlaveRecordDeleteProc(clientData, interp) - ClientData clientData; /* Slave record for deleted interp. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ -{ - Slave *slavePtr; /* Interim storage. */ - Alias *aliasPtr; - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - - slavePtr = (Slave *) clientData; - - /* - * In every case that we call SetAssocData on "tclSlaveRecord", - * slavePtr is not NULL. Otherwise we panic. - */ - - if (slavePtr == NULL) { - panic("SlaveRecordDeleteProc: NULL slavePtr"); - } - - if (slavePtr->interpCmd != (Tcl_Command) NULL) { - Command *cmdPtr = (Command *) slavePtr->interpCmd; - - /* - * The interpCmd has not been deleted in the master yet, since - * it's callback sets interpCmd to NULL. - * - * Probably Tcl_DeleteInterp() was called on this interpreter directly, - * rather than via "interp delete", or equivalent (deletion of the - * command in the master). - * - * Perform the cleanup done by SlaveObjectDeleteProc() directly, - * and turn off the callback now (since we are about to free slavePtr - * and this interpreter is going away, while the deletion of commands - * in the master may be deferred). - */ - - Tcl_DeleteHashEntry(slavePtr->slaveEntry); - cmdPtr->clientData = NULL; - cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = NULL; - - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, - slavePtr->interpCmd); - } - - /* - * If there are any aliases, delete those now. This removes any - * dependency on the order of deletion between commands and the - * slave record. - */ - - hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - /* - * The call to Tcl_DeleteCommand will release the storage - * occupied by the hash entry and the alias record. - */ - - Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd); - } - - /* - * Finally dispose of the hash table and the slave record. - */ - - Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) slavePtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclInterpInit -- - * - * Initializes the invoking interpreter for using the "interp" - * facility. This is called from inside Tcl_Init. - * - * Results: - * None. - * - * Side effects: - * Adds the "interp" command to an interpreter and initializes several - * records in the associated data of the invoking interpreter. - * - *---------------------------------------------------------------------- - */ - -int -TclInterpInit(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - Master *masterPtr; /* Its Master record. */ - Slave *slavePtr; /* And its slave record. */ - - masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); - - Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); - Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); - - (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, - (ClientData) masterPtr); - - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); - - slavePtr->masterInterp = (Tcl_Interp *) NULL; - slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; - slavePtr->slaveInterp = interp; - slavePtr->interpCmd = (Tcl_Command) NULL; - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - - (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc, - (ClientData) slavePtr); - + ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; return TCL_OK; } @@ -3486,328 +2270,86 @@ Tcl_IsSafe(interp) /* *---------------------------------------------------------------------- * - * Tcl_CreateSlave -- - * - * Creates a slave interpreter. The slavePath argument denotes the - * name of the new slave relative to the current interpreter; the - * slave is a direct descendant of the one-before-last component of - * the path, e.g. it is a descendant of the current interpreter if - * the slavePath argument contains only one component. Optionally makes - * the slave interpreter safe. - * - * Results: - * Returns the interpreter structure created, or NULL if an error - * occurred. - * - * Side effects: - * Creates a new interpreter and a new interpreter object command in - * the interpreter indicated by the slavePath argument. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_CreateSlave(interp, slavePath, isSafe) - Tcl_Interp *interp; /* Interpreter to start search at. */ - char *slavePath; /* Name of slave to create. */ - int isSafe; /* Should new slave be "safe" ? */ -{ - Master *masterPtr; /* Master record for same. */ - - if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { - return NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("CreatSlave: could not find master record"); - } - return CreateSlave(interp, masterPtr, slavePath, isSafe); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetSlave -- - * - * Finds a slave interpreter by its path name. - * - * Results: - * Returns a Tcl_Interp * for the named interpreter or NULL if not - * found. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_GetSlave(interp, slavePath) - Tcl_Interp *interp; /* Interpreter to start search from. */ - char *slavePath; /* Path of slave to find. */ -{ - Master *masterPtr; /* Interim storage for Master record. */ - - if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { - return NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_GetSlave: could not find master record"); - } - return GetInterp(interp, masterPtr, slavePath, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMaster -- + * Tcl_MakeSafe -- * - * Finds the master interpreter of a slave interpreter. + * 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: - * Returns a Tcl_Interp * for the master interpreter or NULL if none. - * - * Side effects: * None. * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_GetMaster(interp) - Tcl_Interp *interp; /* Get the master of this interpreter. */ -{ - Slave *slavePtr; /* Slave record of this interpreter. */ - - if (interp == (Tcl_Interp *) NULL) { - return NULL; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - return NULL; - } - return slavePtr->masterInterp; -} - -/* - *---------------------------------------------------------------------- - * - * 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. + * Hides commands in its argument interpreter, and removes settings + * and channels. * *---------------------------------------------------------------------- */ int -Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) - Tcl_Interp *slaveInterp; /* Interpreter for source command. */ - char *slaveCmd; /* Command to install in slave. */ - Tcl_Interp *targetInterp; /* Interpreter for target command. */ - char *targetCmd; /* Name of target command. */ - int argc; /* How many additional arguments? */ - char **argv; /* These are the additional args. */ +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ { - Master *masterPtr; /* Master record for target interp. */ - Tcl_Obj **objv; - int i; - int result; - - if ((slaveInterp == (Tcl_Interp *) NULL) || - (targetInterp == (Tcl_Interp *) NULL) || - (slaveCmd == (char *) NULL) || - (targetCmd == (char *) NULL)) { - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_CreateAlias: could not find master record"); - } - 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]); - } + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + Interp *iPtr = (Interp *) interp; + + TclHideUnsafeCommands(interp); - result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp, - masterPtr, slaveCmd, targetCmd, argc, objv); + iPtr->flags |= SAFE_INTERP; - ckfree((char *) objv); + /* + * Unsetting variables : (which should not have been set + * in the first place, but...) + */ - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateAliasObj -- - * - * Object version: Creates an alias between two interpreters. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates a new alias. - * - *---------------------------------------------------------------------- - */ + /* + * No env array in a safe slave. + */ -int -Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) - Tcl_Interp *slaveInterp; /* Interpreter for source command. */ - char *slaveCmd; /* Command to install in slave. */ - Tcl_Interp *targetInterp; /* Interpreter for target command. */ - char *targetCmd; /* Name of target command. */ - int objc; /* How many additional arguments? */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ -{ - Master *masterPtr; /* Master record for target interp. */ + Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); - if ((slaveInterp == (Tcl_Interp *) NULL) || - (targetInterp == (Tcl_Interp *) NULL) || - (slaveCmd == (char *) NULL) || - (targetCmd == (char *) NULL)) { - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_CreateAlias: could not find master record"); - } - return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp, - masterPtr, slaveCmd, targetCmd, objc, objv); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetAlias -- - * - * Gets information about an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* + * Remove unsafe parts of tcl_platform + */ -int -Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, - argvPtr) - Tcl_Interp *interp; /* Interp to start search from. */ - char *aliasName; /* Name of alias to find. */ - Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ - char **targetNamePtr; /* (Return) name of target command. */ - int *argcPtr; /* (Return) count of addnl args. */ - char ***argvPtr; /* (Return) additional arguments. */ -{ - Slave *slavePtr; /* Slave record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Storage for alias found. */ - int len; - int i; + 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); - if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("Tcl_GetAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", - (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; - } - if (targetNamePtr != (char **) NULL) { - *targetNamePtr = aliasPtr->targetName; - } - if (argcPtr != (int *) NULL) { - *argcPtr = aliasPtr->objc; - } - if (argvPtr != (char ***) NULL) { - *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * - aliasPtr->objc); - for (i = 0; i < aliasPtr->objc; i++) { - *argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ObjGetAlias -- - * - * Object version: Gets information about an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* + * Unset path informations variables + * (the only one remaining is [info nameofexecutable]) + */ -int -Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, - objvPtr) - Tcl_Interp *interp; /* Interp to start search from. */ - char *aliasName; /* Name of alias to find. */ - Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ - char **targetNamePtr; /* (Return) name of target command. */ - int *objcPtr; /* (Return) count of addnl args. */ - Tcl_Obj ***objvPtr; /* (Return) additional args. */ -{ - Slave *slavePtr; /* Slave record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Storage for alias found. */ + 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.. + */ - if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("Tcl_GetAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->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); - if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; - } - if (targetNamePtr != (char **) NULL) { - *targetNamePtr = aliasPtr->targetName; + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); } - if (objcPtr != (int *) NULL) { - *objcPtr = aliasPtr->objc; + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); } - if (objvPtr != (Tcl_Obj ***) NULL) { - *objvPtr = aliasPtr->objv; + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); } + return TCL_OK; } |