summaryrefslogtreecommitdiffstats
path: root/generic/tclInterp.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclInterp.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclInterp.c')
-rw-r--r--generic/tclInterp.c4508
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;
}