diff options
Diffstat (limited to 'contrib/tcl/generic/tclInterp.c')
| -rw-r--r-- | contrib/tcl/generic/tclInterp.c | 2385 |
1 files changed, 2385 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c new file mode 100644 index 0000000..a791fd5 --- /dev/null +++ b/contrib/tcl/generic/tclInterp.c @@ -0,0 +1,2385 @@ +/* + * tclInterp.c -- + * + * This file implements the "interp" command which allows creation + * and manipulation of Tcl interpreters from within Tcl scripts. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclInterp.c 1.66 96/04/15 17:26:10 + */ + +#include <stdio.h> +#include "tclInt.h" +#include "tclPort.h" + +/* + * Counter for how many aliases were created (global) + */ + +static int aliasCounter = 0; + +/* + * + * struct Slave: + * + * Used by the "interp" command to record and find information about slave + * interpreters. Maps from a command name in the master to information about + * a slave interpreter, e.g. what aliases are defined in it. + */ + +typedef struct { + Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ + Tcl_HashEntry *slaveEntry; /* 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. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Command interpCmd; /* Interpreter object command. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands + * in slave interpreter to struct Alias + * defined below. */ +} Slave; + +/* + * struct 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 argc; /* Count of additional args to pass. */ + char **argv; /* 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 + * interpreters. This is needed because aliases can be created between sibling + * interpreters and must be deleted when the target interpreter is deleted. In + * case they would not be deleted the source interpreter would be left with a + * "dangling pointer". One such record is stored in the Master record of the + * master interpreter (in the targetTable hashtable, see below) with the + * master for each alias which directs to a command in the master. These + * records are used to remove the source command for an from a slave if/when + * the master is deleted. + */ + +typedef struct { + Tcl_Command slaveCmd; /* Command for alias in slave interp. */ + Tcl_Interp *slaveInterp; /* Slave Interpreter. */ +} Target; + +/* + * struct Master: + * + * This record is used for three purposes: First, slaveTable (a hashtable) + * maps from names of commands to slave interpreters. This hashtable is + * used to store information about slave interpreters of this interpreter, + * to map over all slaves, etc. The second purpose is to store information + * about all aliases in slaves (or siblings) which direct to target commands + * in this interpreter (using the targetTable hashtable). The third field in + * the record, isSafe, denotes whether the interpreter is safe or not. Safe + * interpreters have restricted functionality, can only create safe slave + * interpreters and can only load safe extensions. + */ + +typedef struct { + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. + * Maps from command names to Slave records. */ + int isSafe; /* Am I a "safe" interpreter? */ + Tcl_HashTable targetTable; /* Hash table for Target Records. Contains + * all Target records which denote aliases + * from slaves or sibling interpreters that + * direct to commands in this interpreter. This + * table is used to remove dangling pointers + * from the slave (or sibling) interpreters + * when this interpreter is deleted. */ +} Master; + +/* + * Prototypes for local static procedures: + */ + +static int AliasCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *currentInterp, int argc, char **argv)); +static void AliasCmdDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static int AliasHelper _ANSI_ARGS_((Tcl_Interp *curInterp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Master *masterPtr, char *aliasName, + char *targetName, int argc, char **argv)); +static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + 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, + int argc, char **argv)); +static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + 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 void MasterRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static int MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static void SlaveObjectDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static void SlaveRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + * These are all the Tcl core commands which are available in a safe + * interpeter: + */ + +static char *TclCommandsToKeep[] = { + "after", "append", "array", + "break", + "case", "catch", "clock", "close", "concat", "continue", + "eof", "error", "eval", "expr", + "fblocked", "fconfigure", "flush", "for", "foreach", "format", + "gets", "global", + "history", + "if", "incr", "info", "interp", + "join", + "lappend", "lindex", "linsert", "list", "llength", "lower", "lrange", + "lreplace", "lsearch", "lsort", + "package", "pid", "proc", "puts", + "read", "regexp", "regsub", "rename", "return", + "scan", "seek", "set", "split", "string", "switch", + "tell", "trace", + "unset", "update", "uplevel", "upvar", + "vwait", + "while", + NULL}; +static int TclCommandsToKeepCt = + (sizeof (TclCommandsToKeep) / sizeof (char *)) -1 ; + +/* + *---------------------------------------------------------------------- + * + * TclPreventAliasLoop -- + * + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * If TCL_ERROR is returned, the function also sets interp->result + * to an error message. + * + * NOTE: + * This function is public internal (instead of being static to + * this file) because it is also used from Tcl_RenameCmd. + * + *---------------------------------------------------------------------- + */ + +int +TclPreventAliasLoop(interp, cmdInterp, cmdName, proc, clientData) + Tcl_Interp *interp; /* Interp in which to report errors. */ + Tcl_Interp *cmdInterp; /* Interp in which the command is + * being defined. */ + char *cmdName; /* Name of Tcl command we are + * attempting to define. */ + Tcl_CmdProc *proc; /* The command procedure for the + * command being created. */ + ClientData clientData; /* The client data associated with the + * command to be created. */ +{ + Alias *aliasPtr, *nextAliasPtr; + Tcl_CmdInfo cmdInfo; + + /* + * If we are not creating or renaming an alias, then it is + * always OK to create or rename the command. + */ + + if (proc != 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 *) clientData; + nextAliasPtr = aliasPtr; + while (1) { + + /* + * If the target of the next alias in the chain is the same as the + * source alias, we have a loop. + */ + + if ((strcmp(nextAliasPtr->targetName, cmdName) == 0) && + (nextAliasPtr->targetInterp == cmdInterp)) { + Tcl_AppendResult(interp, "cannot define or rename alias \"", + aliasPtr->aliasName, "\": would create a loop", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Otherwise, follow the chain one step further. If the target + * command is undefined then there is no loop. + */ + + if (Tcl_GetCommandInfo(nextAliasPtr->targetInterp, + nextAliasPtr->targetName, &cmdInfo) == 0) { + return TCL_OK; + } + + /* + * 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 (cmdInfo.proc != AliasCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) cmdInfo.clientData; + } + + /* NOTREACHED */ +} + +/* + *---------------------------------------------------------------------- + * + * MakeSafe -- + * + * Makes its argument interpreter contain only functionality that is + * defined to be part of Safe Tcl. + * + * Results: + * None. + * + * Side effects: + * Removes commands from its argument interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ +{ + char **argv; /* Args for Tcl_Eval. */ + int argc, keep, i, j; /* Loop indices. */ + char *cmdGetGlobalCmds = "info commands"; /* What command to run. */ + char *cmdNoEnv = "unset env"; /* How to get rid of env. */ + Master *masterPtr; /* Master record of interp + * to be made safe. */ + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + + /* + * Below, Tcl_Eval sets interp->result, so we do not. + */ + + Tcl_ResetResult(interp); + if ((Tcl_Eval(interp, cmdGetGlobalCmds) == TCL_ERROR) || + (Tcl_SplitList(interp, interp->result, &argc, &argv) != TCL_OK)) { + return TCL_ERROR; + } + for (i = 0; i < argc; i++) { + for (keep = 0, j = 0; j < TclCommandsToKeepCt; j++) { + if (strcmp(TclCommandsToKeep[j], argv[i]) == 0) { + keep = 1; + break; + } + } + if (keep == 0) { + (void) Tcl_DeleteCommand(interp, argv[i]); + } + } + ckfree((char *) argv); + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("MakeSafe: could not find master record"); + } + masterPtr->isSafe = 1; + if (Tcl_Eval(interp, cmdNoEnv) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Remove the standard channels from the interpreter; safe interpreters + * do not ordinarily have access to stdin, stdout and stderr. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetInterp -- + * + * Helper function to find a slave interpreter given a pathname. + * + * Results: + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. + * + * Side effects: + * Assigns to the pointer variable passed in, if not NULL. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +GetInterp(interp, 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. */ +{ + 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; + } + } + ckfree((char *) argv); + return searchInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSlave -- + * + * Helper function to do the actual work of creating a slave interp + * and new object command. Also optionally makes the new slave + * interpreter "safe". + * + * Results: + * Returns the new Tcl_Interp * if successful or NULL if not. If failed, + * the result of the invoking interpreter contains an error message. + * + * Side effects: + * Creates a new slave interpreter and a new object command. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +CreateSlave(interp, slavePath, safe) + Tcl_Interp *interp; /* Interp. to start search from. */ + char *slavePath; /* Path (name) of slave to create. */ + int safe; /* Should we make it "safe"? */ +{ + Master *masterPtr; /* Master record. */ + 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. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("CreatSlave: could not find master record"); + } + + 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_AppendResult(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 = masterPtr->isSafe; + } + } + hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); + if (new == 0) { + Tcl_AppendResult(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"); + } + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntry = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateCommand(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); + + if (((safe) && (MakeSafe(slaveInterp) == TCL_ERROR)) || + ((!safe) && (Tcl_Init(slaveInterp) == TCL_ERROR))) { + Tcl_ResetResult(interp); + 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); + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + (void) Tcl_DeleteCommand(masterInterp, slavePath); + slaveInterp = (Tcl_Interp *) NULL; + } + ckfree((char *) argv); + return slaveInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateInterpObject - + * + * Helper function to do the actual work of creating a new interpreter + * and an object command. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +CreateInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Invoking interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe; /* Create a safe interpreter? */ + Master *masterPtr; /* Master record. */ + int moreFlags; /* Expecting more flag args? */ + char *slavePath; /* Name of slave. */ + char localSlaveName[200]; /* Local area for creating names. */ + int i; /* Loop counter. */ + size_t len; /* Length of option argument. */ + static int interpCounter = 0; /* Unique id for created names. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("CreateInterpObject: could not find master record"); + } + moreFlags = 1; + slavePath = NULL; + safe = masterPtr->isSafe; + + if (argc < 2 || argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create ?-safe? ?--? ?path?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 2; i < argc; i++) { + len = strlen(argv[i]); + if ((argv[i][0] == '-') && (moreFlags != 0)) { + if ((argv[i][1] == 's') && (strncmp(argv[i], "-safe", len) == 0) + && (len > 1)){ + safe = 1; + } else if ((strncmp(argv[i], "--", len) == 0) && (len > 1)) { + moreFlags = 0; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": should be -safe", (char *) NULL); + return TCL_ERROR; + } + } else { + slavePath = argv[i]; + } + } + if (slavePath == (char *) NULL) { + sprintf(localSlaveName, "interp%d", interpCounter); + interpCounter++; + slavePath = localSlaveName; + } + if (CreateSlave(interp, slavePath, safe) != NULL) { + Tcl_AppendResult(interp, slavePath, (char *) NULL); + return TCL_OK; + } else { + /* + * CreateSlave already set interp->result if there was an error, + * so we do not do it here. + */ + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteOneInterpObject -- + * + * Helper function for DeleteInterpObject. It deals with deleting one + * interpreter at a time. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an interpreter and its interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteOneInterpObject(interp, path) + Tcl_Interp *interp; /* Interpreter for reporting errors. */ + char *path; /* Path of interpreter to delete. */ +{ + Master *masterPtr; /* Interim storage for master record.*/ + 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.*/ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("DeleteInterpObject: could not find master record"); + } + if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + Tcl_AppendResult(interp, "bad interpreter path \"", path, + "\"", (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_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) localArgv); + ckfree((char *) masterPath); + return TCL_ERROR; + } + ckfree((char *) masterPath); + slaveName = localArgv[localArgc-1]; + } + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + slaveName = Tcl_GetCommandName(masterInterp, slavePtr->interpCmd); + if (Tcl_DeleteCommand(masterInterp, slaveName) != 0) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + ckfree((char *) localArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpObject -- + * + * Helper function to do the work of deleting zero or more + * interpreters and their interpreter object commands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes interpreters and their interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Interpreter start search from. */ + int argc; /* Number of arguments in vector. */ + char **argv; /* Contains path to interps to + * delete. */ +{ + int i; + + for (i = 2; i < argc; i++) { + if (DeleteOneInterpObject(interp, argv[i]) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AliasHelper -- + * + * Helper function to do the work to actually create an alias or + * delete an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * An alias command is created and entered into the alias table + * for the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +AliasHelper(curInterp, slaveInterp, masterInterp, masterPtr, + aliasName, targetName, argc, argv) + 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 argc; /* Additional arguments to store */ + char **argv; /* 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); + + /* + * Fix it up if there is no slave record. This can happen if someone + * uses "" as the source for an alias. + */ + + if (slavePtr == (Slave *) NULL) { + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + } + + if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { + if (argc != 0) { + Tcl_AppendResult(curInterp, "malformed command: should be", + " \"alias ", aliasName, " {}\"", (char *) NULL); + return TCL_ERROR; + } + + 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->argv = (char **) NULL; + aliasPtr->argc = argc; + if (aliasPtr->argc > 0) { + aliasPtr->argv = (char **) ckalloc((unsigned) sizeof(char *) * + aliasPtr->argc); + for (i = 0; i < argc; i++) { + aliasPtr->argv[i] = (char *) ckalloc((unsigned) strlen(argv[i])+1); + strcpy(aliasPtr->argv[i], argv[i]); + } + } + + if (TclPreventAliasLoop(curInterp, slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr) != TCL_OK) { + for (i = 0; i < argc; i++) { + ckfree(aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + ckfree(aliasPtr->aliasName); + ckfree(aliasPtr->targetName); + ckfree((char *) aliasPtr); + + return TCL_ERROR; + } + + aliasPtr->slaveCmd = Tcl_CreateCommand(slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr, AliasCmdDeleteProc); + + /* + * Make an entry in the alias table. If it already exists delete + * the alias command. Then retry. + */ + + do { + hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); + if (new == 0) { + tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + (void) Tcl_DeleteCommand(slaveInterp, tmpAliasPtr->aliasName); + Tcl_DeleteHashEntry(hPtr); + } + } while (new == 0); + aliasPtr->aliasEntry = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); + + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr->slaveCmd = aliasPtr->slaveCmd; + targetPtr->slaveInterp = slaveInterp; + + do { + hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + (char *) aliasCounter, &new); + aliasCounter++; + } while (new == 0); + + Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + + aliasPtr->targetEntry = hPtr; + + curInterp->result = aliasPtr->aliasName; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveAliasHelper - + * + * 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 +SlaveAliasHelper(interp, argc, argv) + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for current interp. */ + Tcl_Interp *slaveInterp, /* Interpreters used when */ + *masterInterp; /* creating an alias btn siblings. */ + Master *masterMasterPtr; /* Master record for master interp. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveAliasHelper: could not find master record"); + } + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return DescribeAlias(interp, slaveInterp, argv[3]); + } + if (argc == 5 && strcmp(argv[4], "") == 0) { + return DeleteAlias(interp, slaveInterp, argv[3]); + } + if (argc < 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[4], &masterMasterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + return AliasHelper(interp, slaveInterp, masterInterp, masterMasterPtr, + argv[3], argv[5], argc-6, argv+6); +} + +/* + *---------------------------------------------------------------------- + * + * DescribeAlias -- + * + * Sets interp->result to a Tcl list describing the given alias in the + * given interpreter: its target command and the additional arguments + * to prepend to any invocation of the alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DescribeAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to describe. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias. */ + int i; /* Loop variable. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + 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); + Tcl_AppendResult(interp, aliasPtr->targetName, (char *) NULL); + for (i = 0; i < aliasPtr->argc; i++) { + Tcl_AppendElement(interp, aliasPtr->argv[i]); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteAlias -- + * + * Deletes the given alias from the slave interpreter given. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the alias from the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +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. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias to delete. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + panic("DeleteAlias: could not find slave record"); + } + + /* + * Get the alias from the alias table, determine the current + * true name of the alias (it may have been renamed!) and then + * delete the true command name. The deleteProc on the alias + * command will take care of removing the entry from the alias + * table. + */ + + 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); + aliasName = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); + + /* + * 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. + */ + + if (Tcl_DeleteCommand(slaveInterp, aliasName) != 0) { + panic("DeleteAlias: did not find alias to be deleted"); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpPath -- + * + * Sets the result of the asking interpreter to a proper Tcl list + * containing the names of interpreters between the asking and + * target interpreters. The target interpreter must be either the + * same as the asking interpreter or one of its slaves (including + * recursively). + * + * Results: + * TCL_OK if the target interpreter is the same as, or a descendant + * of, the asking interpreter; TCL_ERROR else. This way one can + * distinguish between the case where the asking and target interps + * are the same (an empty list is the result, and TCL_OK is returned) + * and when the target is not a descendant of the asking interpreter + * (in which case the Tcl result is an error message and the function + * returns TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpPath(askingInterp, targetInterp) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + Tcl_Interp *targetInterp; /* Interpreter to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + + 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 (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { + /* + * AskingInterp->result was set by recursive call. + */ + 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)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTarget -- + * + * Sets the result of the invoking interpreter to a path name for + * the target interpreter of an alias in one of the slaves. + * + * Results: + * TCL_OK if the target interpreter of the alias is a slave of the + * invoking interpreter, TCL_ERROR else. + * + * Side effects: + * Sets the result of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + 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. */ + + 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_AppendResult(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"); + } + hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(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"); + } + if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { + Tcl_ResetResult(askingInterp); + Tcl_AppendResult(askingInterp, "target interpreter for alias \"", + aliasName, "\" in path \"", path, "\" is not my descendant", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpCmd -- + * + * This procedure is invoked to process the "interp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Tcl_InterpCmd(clientData, interp, argc, argv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* A master. */ + Master *masterPtr; /* Master record for current interp. */ + Slave *slavePtr; /* Record for slave interp. */ + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + size_t len; /* Length of command name. */ + int result; /* Result of eval. */ + char *cmdName; /* Name of sub command to do. */ + char *cmd; /* Command to eval. */ + Tcl_Channel chan; /* Channel to share or transfer. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_InterpCmd: could not find master record"); + } + + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if ((strncmp(cmdName, "alias", len) == 0) && (len <= 5)) { + return SlaveAliasHelper(interp, argc, argv); + } + + if (strcmp(cmdName, "aliases") == 0) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " aliases ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", + argv[2], "\" not found", (char *) NULL); + return TCL_ERROR; + } + } else { + slaveInterp = interp; + } + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr)); + } + return TCL_OK; + } + } + + if ((cmdName[0] == 'c') && (strncmp(cmdName, "create", len) == 0)) { + return CreateInterpObject(interp, argc, argv); + } + + if ((cmdName[0] == 'd') && (strncmp(cmdName, "delete", len) == 0)) { + return DeleteInterpObject(interp, argc, argv); + } + + if (cmdName[0] == 'e') { + if ((strncmp(cmdName, "exists", len) == 0) && (len > 1)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], NULL) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + if ((strncmp(cmdName, "eval", len) == 0) && (len > 1)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval path arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + cmd = Tcl_Concat(argc-3, argv+3); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * 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. Must + * clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + 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); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + if (masterPtr->isSafe == 0) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + + if (cmdName[0] == 's') { + if ((strncmp(cmdName, "slaves", len) == 0) && (len > 1)) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " slaves ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], &masterPtr) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr)); + } + return TCL_OK; + } + if ((strncmp(cmdName, "share", len) == 0) && (len > 1)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " share srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, + (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "target", len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " target path alias\"", (char *) NULL); + return TCL_ERROR; + } + return GetTarget(interp, argv[2], argv[3]); + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "transfer", len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " transfer srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, create, delete, exists, eval, ", + "issafe, share, slaves, target or transfer", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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, argc, argv) + ClientData clientData; /* Slave interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for slave interp. */ + Slave *slavePtr; /* Slave record. */ + Tcl_Interp *slaveInterp; /* Slave interpreter. */ + char *cmdName; /* Name of command to do. */ + char *cmd; /* Command to evaluate in slave + * interpreter. */ + Alias *aliasPtr; /* Alias information. */ + Tcl_HashEntry *hPtr; /* For local searches. */ + Tcl_HashSearch hSearch; /* For local searches. */ + int result; /* Loop counter, status return. */ + size_t len; /* Length of command name. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter ", argv[0], " has been deleted", + (char *) NULL); + return TCL_ERROR; + } + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectCmd: could not find slave record"); + } + + cmdName = argv[1]; + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if (strncmp(cmdName, "alias", len) == 0) { + switch (argc-2) { + case 0: + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " alias aliasName ?targetName? ?args..?", + (char *) NULL); + 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, argv[2]); + + default: + masterPtr = (Master *) Tcl_GetAssocData(interp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + return AliasHelper(interp, slaveInterp, interp, masterPtr, + argv[2], argv[3], argc-4, argv+4); + } + } + + if (strncmp(cmdName, "aliases", len) == 0) { + + /* + * Return the names of all the aliases created in the + * slave interpreter. + */ + + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), + &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendElement(interp, aliasPtr->aliasName); + } + return TCL_OK; + } + } + + + if ((cmdName[0] == 'e') && (strncmp(cmdName, "eval", len) == 0)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + cmd = Tcl_Concat(argc-2, argv+2); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * 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 + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + 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); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe\"", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + if (masterPtr->isSafe == 1) { + Tcl_AppendResult(interp, "1", (char *) NULL); + } else { + Tcl_AppendResult(interp, "0", (char *) NULL); + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, eval or issafe", (char *) NULL); + 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, argc, argv) + ClientData clientData; /* Alias record. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Alias *aliasPtr; /* Describes the alias. */ + Tcl_CmdInfo cmdInfo; /* Info about target command. */ + int result; /* Result of execution. */ + int i, j, addArgc; /* Loop counters. */ + int localArgc; /* Local argument count. */ + char **localArgv; /* Local argument vector. */ + Interp *iPtr; /* The target interpreter. */ + + aliasPtr = (Alias *) clientData; + + result = Tcl_GetCommandInfo(aliasPtr->targetInterp, aliasPtr->targetName, + &cmdInfo); + if (result == 0) { + Tcl_AppendResult(interp, "aliased target \"", aliasPtr->targetName, + "\" for \"", argv[0], "\" not found", (char *) NULL); + return TCL_ERROR; + } + if (aliasPtr->argc <= 0) { + localArgv = argv; + localArgc = argc; + } else { + addArgc = aliasPtr->argc; + localArgc = argc + addArgc; + localArgv = (char **) ckalloc((unsigned) sizeof(char *) * localArgc); + localArgv[0] = argv[0]; + for (i = 0, j = 1; i < addArgc; i++, j++) { + localArgv[j] = aliasPtr->argv[i]; + } + for (i = 1; i < argc; i++, j++) { + localArgv[j] = argv[i]; + } + } + + /* + * Invoke the redirected command in the target interpreter. Note + * that we are not calling eval because of possible security holes with + * $ substitution and bracketed command evaluation. + * + * We duplicate some code here from Tcl_Eval to implement recursion + * level counting and correct deletion of the target interpreter if + * that was requested but delayed because of in-progress evaluations. + */ + + iPtr = (Interp *) aliasPtr->targetInterp; + iPtr->numLevels++; + Tcl_Preserve((ClientData) iPtr); + Tcl_ResetResult((Tcl_Interp *) iPtr); + result = (cmdInfo.proc)(cmdInfo.clientData, (Tcl_Interp *) iPtr, + localArgc, localArgv); + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult((Tcl_Interp *) iPtr); + if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + } else { + iPtr->result = iPtr->resultSpace; + sprintf(iPtr->resultSpace, "command returned bad code: %d", + result); + } + result = TCL_ERROR; + } + } + + /* + * Clean up any locally allocated argument vector structure. + */ + + if (localArgv != argv) { + ckfree((char *) localArgv); + } + + /* + * + * NOTE: Need to be careful if the target interpreter and the current + * interpreter are the same - must not destroy result. This may happen + * if an alias is created which redirects to a command in the same + * interpreter as the one in which the source command will be defined. + * Also: We cannot use aliasPtr any more because the alias may have + * been deleted. + */ + + if (interp != (Tcl_Interp *) iPtr) { + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Some tricky + * points: + * 1. Must call Tcl_AddErrorInfo in destination interpreter to + * make sure that the errorInfo variable has been initialized + * (it's initialized lazily and might not have been initialized + * yet). + * 2. Must clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending aliasPtr->interp's $errorInfo; + * we've already got everything we need in the redirected + * interpreter's $errorInfo. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2((Tcl_Interp *) iPtr, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (iPtr->freeProc != NULL) { + interp->result = iPtr->result; + interp->freeProc = iPtr->freeProc; + iPtr->freeProc = 0; + } else { + Tcl_SetResult(interp, iPtr->result, TCL_VOLATILE); + } + Tcl_ResetResult((Tcl_Interp *) iPtr); + } + Tcl_Release((ClientData) iPtr); + 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->argc; i++) { + ckfree((char *) aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + + 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. */ + char *cmdName; /* Name of command to delete. */ + 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); + cmdName = Tcl_GetCommandName(interp, slavePtr->interpCmd); + (void) Tcl_DeleteCommand(interp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->slaveTable)); + + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(targetPtr->slaveInterp, + targetPtr->slaveCmd); + (void) Tcl_DeleteCommand(targetPtr->slaveInterp, cmdName); + } + 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; + + /* + * Get the command name from the master interpreter instead of + * relying on the stored name; the command may have been renamed. + */ + + Tcl_DeleteCommand(slavePtr->masterInterp, + Tcl_GetCommandName(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 + * occuppied by the hash entry and the alias record. + * NOTE that we cannot use the alias name directly because its + * storage will be deleted in the command deletion callback. Hence + * we must use the name for the command as stored in the hash table. + */ + + Tcl_DeleteCommand(interp, + Tcl_GetCommandName(interp, aliasPtr->slaveCmd)); + } + + /* + * Finally dispose of the slave record itself. + */ + + 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. */ + + masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); + masterPtr->isSafe = 0; + Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); + Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); + + (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, + (ClientData) masterPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsSafe -- + * + * Determines whether an interpreter is safe + * + * Results: + * 1 if it is safe, 0 if it is not. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsSafe(interp) + Tcl_Interp *interp; /* Is this interpreter "safe" ? */ +{ + Master *masterPtr; /* Its master record. */ + + if (interp == (Tcl_Interp *) NULL) { + return 0; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_IsSafe: could not find master record"); + } + return masterPtr->isSafe; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeSafe -- + * + * Makes an interpreter safe. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Removes functionality from an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Make this interpreter "safe". */ +{ + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return MakeSafe(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" ? */ +{ + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + return CreateSlave(interp, 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 -- + * + * Finds the master interpreter of a slave interpreter. + * + * Results: + * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ +{ + Slave *slavePtr; /* Slave record of this interpreter. */ + + if (interp == (Tcl_Interp *) NULL) { + return NULL; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return NULL; + } + return slavePtr->masterInterp; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAlias -- + * + * Creates an alias between two interpreters. + * + * Results: + * TCL_OK if successful, TCL_ERROR if failed. If TCL_ERROR is returned + * the result of slaveInterp will contain an error message. + * + * Side effects: + * Creates a new alias, manipulates the result field of slaveInterp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + 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. */ +{ + Master *masterPtr; /* Master record for target interp. */ + + 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 AliasHelper(slaveInterp, slaveInterp, targetInterp, masterPtr, + slaveCmd, targetCmd, argc, argv); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAlias -- + * + * Gets information about an alias. + * + * Results: + * TCL_OK if successful, TCL_ERROR else. If TCL_ERROR is returned, the + * result field of the interpreter given as argument will contain an + * error message. + * + * Side effects: + * Manipulates the result field of the interpreter given as argument. + * + *---------------------------------------------------------------------- + */ + +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. */ + + 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->argc; + } + if (argvPtr != (char ***) NULL) { + *argvPtr = aliasPtr->argv; + } + return TCL_OK; +} |
