/*
|
/*
|
* tclInterp.c --
|
* tclInterp.c --
|
*
|
*
|
* This file implements the "interp" command which allows creation
|
* This file implements the "interp" command which allows creation
|
* and manipulation of Tcl interpreters from within Tcl scripts.
|
* and manipulation of Tcl interpreters from within Tcl scripts.
|
*
|
*
|
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclInterp.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
|
* RCS: @(#) $Id: tclInterp.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
|
*/
|
*/
|
|
|
#include <stdio.h>
|
#include <stdio.h>
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
|
|
/*
|
/*
|
* Counter for how many aliases were created (global)
|
* Counter for how many aliases were created (global)
|
*/
|
*/
|
|
|
static int aliasCounter = 0;
|
static int aliasCounter = 0;
|
|
|
/*
|
/*
|
*
|
*
|
* struct Slave:
|
* struct Slave:
|
*
|
*
|
* Used by the "interp" command to record and find information about slave
|
* Used by the "interp" command to record and find information about slave
|
* interpreters. Maps from a command name in the master to information about
|
* interpreters. Maps from a command name in the master to information about
|
* a slave interpreter, e.g. what aliases are defined in it.
|
* a slave interpreter, e.g. what aliases are defined in it.
|
*/
|
*/
|
|
|
typedef struct {
|
typedef struct {
|
Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
|
Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
|
Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for
|
Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for
|
* this slave interpreter. Used to find
|
* this slave interpreter. Used to find
|
* this record, and used when deleting the
|
* this record, and used when deleting the
|
* slave interpreter to delete it from the
|
* slave interpreter to delete it from the
|
* masters table. */
|
* masters table. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Command interpCmd; /* Interpreter object command. */
|
Tcl_Command interpCmd; /* Interpreter object command. */
|
Tcl_HashTable aliasTable; /* Table which maps from names of commands
|
Tcl_HashTable aliasTable; /* Table which maps from names of commands
|
* in slave interpreter to struct Alias
|
* in slave interpreter to struct Alias
|
* defined below. */
|
* defined below. */
|
} Slave;
|
} Slave;
|
|
|
/*
|
/*
|
* struct Alias:
|
* struct Alias:
|
*
|
*
|
* Stores information about an alias. Is stored in the slave interpreter
|
* 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
|
* and used by the source command to find the target command in the master
|
* when the source command is invoked.
|
* when the source command is invoked.
|
*/
|
*/
|
|
|
typedef struct {
|
typedef struct {
|
char *aliasName; /* Name of alias command. */
|
char *aliasName; /* Name of alias command. */
|
char *targetName; /* Name of target command in master interp. */
|
char *targetName; /* Name of target command in master interp. */
|
Tcl_Interp *targetInterp; /* Master interpreter. */
|
Tcl_Interp *targetInterp; /* Master interpreter. */
|
int objc; /* Count of additional args to pass. */
|
int objc; /* Count of additional args to pass. */
|
Tcl_Obj **objv; /* Actual additional args to pass. */
|
Tcl_Obj **objv; /* Actual additional args to pass. */
|
Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave.
|
Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave.
|
* This is used by alias deletion to remove
|
* This is used by alias deletion to remove
|
* the alias from the slave interpreter
|
* the alias from the slave interpreter
|
* alias table. */
|
* alias table. */
|
Tcl_HashEntry *targetEntry; /* Entry for target command in master.
|
Tcl_HashEntry *targetEntry; /* Entry for target command in master.
|
* This is used in the master interpreter to
|
* This is used in the master interpreter to
|
* map back from the target command to aliases
|
* map back from the target command to aliases
|
* redirecting to it. Random access to this
|
* redirecting to it. Random access to this
|
* hash table is never required - we are using
|
* hash table is never required - we are using
|
* a hash table only for convenience. */
|
* a hash table only for convenience. */
|
Tcl_Command slaveCmd; /* Source command in slave interpreter. */
|
Tcl_Command slaveCmd; /* Source command in slave interpreter. */
|
} Alias;
|
} Alias;
|
|
|
/*
|
/*
|
* struct Target:
|
* struct Target:
|
*
|
*
|
* Maps from master interpreter commands back to the source commands in slave
|
* Maps from master interpreter commands back to the source commands in slave
|
* interpreters. This is needed because aliases can be created between sibling
|
* interpreters. This is needed because aliases can be created between sibling
|
* interpreters and must be deleted when the target interpreter is deleted. In
|
* interpreters and must be deleted when the target interpreter is deleted. In
|
* case they would not be deleted the source interpreter would be left with a
|
* case they would not be deleted the source interpreter would be left with a
|
* "dangling pointer". One such record is stored in the Master record of the
|
* "dangling pointer". One such record is stored in the Master record of the
|
* master interpreter (in the targetTable hashtable, see below) with the
|
* master interpreter (in the targetTable hashtable, see below) with the
|
* master for each alias which directs to a command in the master. These
|
* master for each alias which directs to a command in the master. These
|
* records are used to remove the source command for an from a slave if/when
|
* records are used to remove the source command for an from a slave if/when
|
* the master is deleted.
|
* the master is deleted.
|
*/
|
*/
|
|
|
typedef struct {
|
typedef struct {
|
Tcl_Command slaveCmd; /* Command for alias in slave interp. */
|
Tcl_Command slaveCmd; /* Command for alias in slave interp. */
|
Tcl_Interp *slaveInterp; /* Slave Interpreter. */
|
Tcl_Interp *slaveInterp; /* Slave Interpreter. */
|
} Target;
|
} Target;
|
|
|
/*
|
/*
|
* struct Master:
|
* struct Master:
|
*
|
*
|
* This record is used for two purposes: First, slaveTable (a hashtable)
|
* This record is used for two purposes: First, slaveTable (a hashtable)
|
* maps from names of commands to slave interpreters. This hashtable is
|
* maps from names of commands to slave interpreters. This hashtable is
|
* used to store information about slave interpreters of this interpreter,
|
* used to store information about slave interpreters of this interpreter,
|
* to map over all slaves, etc. The second purpose is to store information
|
* to map over all slaves, etc. The second purpose is to store information
|
* about all aliases in slaves (or siblings) which direct to target commands
|
* about all aliases in slaves (or siblings) which direct to target commands
|
* in this interpreter (using the targetTable hashtable).
|
* in this interpreter (using the targetTable hashtable).
|
*
|
*
|
* NB: the flags field in the interp structure, used with SAFE_INTERP
|
* NB: the flags field in the interp structure, used with SAFE_INTERP
|
* mask denotes whether the interpreter is safe or not. Safe
|
* mask denotes whether the interpreter is safe or not. Safe
|
* interpreters have restricted functionality, can only create safe slave
|
* interpreters have restricted functionality, can only create safe slave
|
* interpreters and can only load safe extensions.
|
* interpreters and can only load safe extensions.
|
*/
|
*/
|
|
|
typedef struct {
|
typedef struct {
|
Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
|
Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
|
* Maps from command names to Slave records. */
|
* Maps from command names to Slave records. */
|
Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
|
Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
|
* all Target records which denote aliases
|
* all Target records which denote aliases
|
* from slaves or sibling interpreters that
|
* from slaves or sibling interpreters that
|
* direct to commands in this interpreter. This
|
* direct to commands in this interpreter. This
|
* table is used to remove dangling pointers
|
* table is used to remove dangling pointers
|
* from the slave (or sibling) interpreters
|
* from the slave (or sibling) interpreters
|
* when this interpreter is deleted. */
|
* when this interpreter is deleted. */
|
} Master;
|
} Master;
|
|
|
/*
|
/*
|
* Prototypes for local static procedures:
|
* Prototypes for local static procedures:
|
*/
|
*/
|
|
|
static int AliasCmd _ANSI_ARGS_((ClientData dummy,
|
static int AliasCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *currentInterp, int objc,
|
Tcl_Interp *currentInterp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static void AliasCmdDeleteProc _ANSI_ARGS_((
|
static void AliasCmdDeleteProc _ANSI_ARGS_((
|
ClientData clientData));
|
ClientData clientData));
|
static int AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp,
|
static int AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp,
|
Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
|
Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
|
Master *masterPtr, char *aliasName,
|
Master *masterPtr, char *aliasName,
|
char *targetName, int objc,
|
char *targetName, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
|
static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
|
static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, char *slavePath, int safe));
|
Master *masterPtr, char *slavePath, int safe));
|
static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp,
|
static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, char *aliasName));
|
Tcl_Interp *slaveInterp, char *aliasName));
|
static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp,
|
static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, char *aliasName));
|
Tcl_Interp *slaveInterp, char *aliasName));
|
static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
|
static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
|
static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, char *path));
|
Master *masterPtr, char *path));
|
static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
|
static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, char *path,
|
Master *masterPtr, char *path,
|
Master **masterPtrPtr));
|
Master **masterPtrPtr));
|
static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path,
|
static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path,
|
char *aliasName));
|
char *aliasName));
|
static int InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpInvokeHiddenHelper _ANSI_ARGS_((
|
static int InterpInvokeHiddenHelper _ANSI_ARGS_((
|
Tcl_Interp *interp, Master *masterPtr, int objc,
|
Tcl_Interp *interp, Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpMarkTrustedHelper _ANSI_ARGS_((
|
static int InterpMarkTrustedHelper _ANSI_ARGS_((
|
Tcl_Interp *interp, Master *masterPtr, int objc,
|
Tcl_Interp *interp, Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Master *masterPtr, int objc,
|
Master *masterPtr, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp));
|
static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp));
|
static void MasterRecordDeleteProc _ANSI_ARGS_((
|
static void MasterRecordDeleteProc _ANSI_ARGS_((
|
ClientData clientData, Tcl_Interp *interp));
|
ClientData clientData, Tcl_Interp *interp));
|
static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveIsSafeHelper _ANSI_ARGS_((
|
static int SlaveIsSafeHelper _ANSI_ARGS_((
|
Tcl_Interp *interp, Tcl_Interp *slaveInterp,
|
Tcl_Interp *interp, Tcl_Interp *slaveInterp,
|
Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
|
Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveInvokeHiddenHelper _ANSI_ARGS_((
|
static int SlaveInvokeHiddenHelper _ANSI_ARGS_((
|
Tcl_Interp *interp, Tcl_Interp *slaveInterp,
|
Tcl_Interp *interp, Tcl_Interp *slaveInterp,
|
Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
|
Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
Tcl_Interp *slaveInterp, Slave *slavePtr,
|
int objc, Tcl_Obj *CONST objv[]));
|
int objc, Tcl_Obj *CONST objv[]));
|
static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy,
|
static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static void SlaveObjectDeleteProc _ANSI_ARGS_((
|
static void SlaveObjectDeleteProc _ANSI_ARGS_((
|
ClientData clientData));
|
ClientData clientData));
|
static void SlaveRecordDeleteProc _ANSI_ARGS_((
|
static void SlaveRecordDeleteProc _ANSI_ARGS_((
|
ClientData clientData, Tcl_Interp *interp));
|
ClientData clientData, Tcl_Interp *interp));
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclPreventAliasLoop --
|
* TclPreventAliasLoop --
|
*
|
*
|
* When defining an alias or renaming a command, prevent an alias
|
* When defining an alias or renaming a command, prevent an alias
|
* loop from being formed.
|
* loop from being formed.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If TCL_ERROR is returned, the function also stores an error message
|
* If TCL_ERROR is returned, the function also stores an error message
|
* in the interpreter's result object.
|
* in the interpreter's result object.
|
*
|
*
|
* NOTE:
|
* NOTE:
|
* This function is public internal (instead of being static to
|
* This function is public internal (instead of being static to
|
* this file) because it is also used from TclRenameCommand.
|
* this file) because it is also used from TclRenameCommand.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclPreventAliasLoop(interp, cmdInterp, cmd)
|
TclPreventAliasLoop(interp, cmdInterp, cmd)
|
Tcl_Interp *interp; /* Interp in which to report errors. */
|
Tcl_Interp *interp; /* Interp in which to report errors. */
|
Tcl_Interp *cmdInterp; /* Interp in which the command is
|
Tcl_Interp *cmdInterp; /* Interp in which the command is
|
* being defined. */
|
* being defined. */
|
Tcl_Command cmd; /* Tcl command we are attempting
|
Tcl_Command cmd; /* Tcl command we are attempting
|
* to define. */
|
* to define. */
|
{
|
{
|
Command *cmdPtr = (Command *) cmd;
|
Command *cmdPtr = (Command *) cmd;
|
Alias *aliasPtr, *nextAliasPtr;
|
Alias *aliasPtr, *nextAliasPtr;
|
Tcl_Command aliasCmd;
|
Tcl_Command aliasCmd;
|
Command *aliasCmdPtr;
|
Command *aliasCmdPtr;
|
|
|
/*
|
/*
|
* If we are not creating or renaming an alias, then it is
|
* If we are not creating or renaming an alias, then it is
|
* always OK to create or rename the command.
|
* always OK to create or rename the command.
|
*/
|
*/
|
|
|
if (cmdPtr->objProc != AliasCmd) {
|
if (cmdPtr->objProc != AliasCmd) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* OK, we are dealing with an alias, so traverse the chain of aliases.
|
* 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
|
* If we encounter the alias we are defining (or renaming to) any in
|
* the chain then we have a loop.
|
* the chain then we have a loop.
|
*/
|
*/
|
|
|
aliasPtr = (Alias *) cmdPtr->objClientData;
|
aliasPtr = (Alias *) cmdPtr->objClientData;
|
nextAliasPtr = aliasPtr;
|
nextAliasPtr = aliasPtr;
|
while (1) {
|
while (1) {
|
|
|
/*
|
/*
|
* If the target of the next alias in the chain is the same as
|
* If the target of the next alias in the chain is the same as
|
* the source alias, we have a loop.
|
* the source alias, we have a loop.
|
*/
|
*/
|
|
|
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
|
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
|
nextAliasPtr->targetName,
|
nextAliasPtr->targetName,
|
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
|
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
|
/*flags*/ 0);
|
/*flags*/ 0);
|
if (aliasCmd == (Tcl_Command) NULL) {
|
if (aliasCmd == (Tcl_Command) NULL) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
aliasCmdPtr = (Command *) aliasCmd;
|
aliasCmdPtr = (Command *) aliasCmd;
|
if (aliasCmdPtr == cmdPtr) {
|
if (aliasCmdPtr == cmdPtr) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot define or rename alias \"", aliasPtr->aliasName,
|
"cannot define or rename alias \"", aliasPtr->aliasName,
|
"\": would create a loop", (char *) NULL);
|
"\": would create a loop", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, follow the chain one step further. See if the target
|
* Otherwise, follow the chain one step further. See if the target
|
* command is an alias - if so, follow the loop to its target
|
* command is an alias - if so, follow the loop to its target
|
* command. Otherwise we do not have a loop.
|
* command. Otherwise we do not have a loop.
|
*/
|
*/
|
|
|
if (aliasCmdPtr->objProc != AliasCmd) {
|
if (aliasCmdPtr->objProc != AliasCmd) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
|
nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
|
}
|
}
|
|
|
/* NOTREACHED */
|
/* NOTREACHED */
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* MarkTrusted --
|
* MarkTrusted --
|
*
|
*
|
* Mark an interpreter as unsafe (i.e. remove the "safe" mark).
|
* Mark an interpreter as unsafe (i.e. remove the "safe" mark).
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Removes the "safe" mark from an interpreter.
|
* Removes the "safe" mark from an interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
MarkTrusted(interp)
|
MarkTrusted(interp)
|
Tcl_Interp *interp; /* Interpreter to be marked unsafe. */
|
Tcl_Interp *interp; /* Interpreter to be marked unsafe. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
iPtr->flags &= ~SAFE_INTERP;
|
iPtr->flags &= ~SAFE_INTERP;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_MakeSafe --
|
* Tcl_MakeSafe --
|
*
|
*
|
* Makes its argument interpreter contain only functionality that is
|
* Makes its argument interpreter contain only functionality that is
|
* defined to be part of Safe Tcl. Unsafe commands are hidden, the
|
* defined to be part of Safe Tcl. Unsafe commands are hidden, the
|
* env array is unset, and the standard channels are removed.
|
* env array is unset, and the standard channels are removed.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Hides commands in its argument interpreter, and removes settings
|
* Hides commands in its argument interpreter, and removes settings
|
* and channels.
|
* and channels.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_MakeSafe(interp)
|
Tcl_MakeSafe(interp)
|
Tcl_Interp *interp; /* Interpreter to be made safe. */
|
Tcl_Interp *interp; /* Interpreter to be made safe. */
|
{
|
{
|
Tcl_Channel chan; /* Channel to remove from
|
Tcl_Channel chan; /* Channel to remove from
|
* safe interpreter. */
|
* safe interpreter. */
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
TclHideUnsafeCommands(interp);
|
TclHideUnsafeCommands(interp);
|
|
|
iPtr->flags |= SAFE_INTERP;
|
iPtr->flags |= SAFE_INTERP;
|
|
|
/*
|
/*
|
* Unsetting variables : (which should not have been set
|
* Unsetting variables : (which should not have been set
|
* in the first place, but...)
|
* in the first place, but...)
|
*/
|
*/
|
|
|
/*
|
/*
|
* No env array in a safe slave.
|
* No env array in a safe slave.
|
*/
|
*/
|
|
|
Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
|
|
|
/*
|
/*
|
* Remove unsafe parts of tcl_platform
|
* Remove unsafe parts of tcl_platform
|
*/
|
*/
|
|
|
Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", 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", "machine", TCL_GLOBAL_ONLY);
|
|
|
/*
|
/*
|
* Unset path informations variables
|
* Unset path informations variables
|
* (the only one remaining is [info nameofexecutable])
|
* (the only one remaining is [info nameofexecutable])
|
*/
|
*/
|
|
|
Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
|
Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
|
|
|
/*
|
/*
|
* Remove the standard channels from the interpreter; safe interpreters
|
* Remove the standard channels from the interpreter; safe interpreters
|
* do not ordinarily have access to stdin, stdout and stderr.
|
* do not ordinarily have access to stdin, stdout and stderr.
|
*
|
*
|
* NOTE: These channels are not added to the interpreter by the
|
* NOTE: These channels are not added to the interpreter by the
|
* Tcl_CreateInterp call, but may be added later, by another I/O
|
* Tcl_CreateInterp call, but may be added later, by another I/O
|
* operation. We want to ensure that the interpreter does not have
|
* operation. We want to ensure that the interpreter does not have
|
* these channels even if it is being made safe after being used for
|
* these channels even if it is being made safe after being used for
|
* some time..
|
* some time..
|
*/
|
*/
|
|
|
chan = Tcl_GetStdChannel(TCL_STDIN);
|
chan = Tcl_GetStdChannel(TCL_STDIN);
|
if (chan != (Tcl_Channel) NULL) {
|
if (chan != (Tcl_Channel) NULL) {
|
Tcl_UnregisterChannel(interp, chan);
|
Tcl_UnregisterChannel(interp, chan);
|
}
|
}
|
chan = Tcl_GetStdChannel(TCL_STDOUT);
|
chan = Tcl_GetStdChannel(TCL_STDOUT);
|
if (chan != (Tcl_Channel) NULL) {
|
if (chan != (Tcl_Channel) NULL) {
|
Tcl_UnregisterChannel(interp, chan);
|
Tcl_UnregisterChannel(interp, chan);
|
}
|
}
|
chan = Tcl_GetStdChannel(TCL_STDERR);
|
chan = Tcl_GetStdChannel(TCL_STDERR);
|
if (chan != (Tcl_Channel) NULL) {
|
if (chan != (Tcl_Channel) NULL) {
|
Tcl_UnregisterChannel(interp, chan);
|
Tcl_UnregisterChannel(interp, chan);
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* GetInterp --
|
* GetInterp --
|
*
|
*
|
* Helper function to find a slave interpreter given a pathname.
|
* Helper function to find a slave interpreter given a pathname.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns the slave interpreter known by that name in the calling
|
* Returns the slave interpreter known by that name in the calling
|
* interpreter, or NULL if no interpreter known by that name exists.
|
* interpreter, or NULL if no interpreter known by that name exists.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Assigns to the pointer variable passed in, if not NULL.
|
* Assigns to the pointer variable passed in, if not NULL.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static Tcl_Interp *
|
static Tcl_Interp *
|
GetInterp(interp, masterPtr, path, masterPtrPtr)
|
GetInterp(interp, masterPtr, path, masterPtrPtr)
|
Tcl_Interp *interp; /* Interp. to start search from. */
|
Tcl_Interp *interp; /* Interp. to start search from. */
|
Master *masterPtr; /* Its master record. */
|
Master *masterPtr; /* Its master record. */
|
char *path; /* The path (name) of interp. to be found. */
|
char *path; /* The path (name) of interp. to be found. */
|
Master **masterPtrPtr; /* (Return) its master record. */
|
Master **masterPtrPtr; /* (Return) its master record. */
|
{
|
{
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Slave *slavePtr; /* Interim slave record. */
|
Slave *slavePtr; /* Interim slave record. */
|
char **argv; /* Split-up path (name) for interp to find. */
|
char **argv; /* Split-up path (name) for interp to find. */
|
int argc, i; /* Loop indices. */
|
int argc, i; /* Loop indices. */
|
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
|
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
|
|
|
if (masterPtrPtr != (Master **) NULL) {
|
if (masterPtrPtr != (Master **) NULL) {
|
*masterPtrPtr = masterPtr;
|
*masterPtrPtr = masterPtr;
|
}
|
}
|
|
|
if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) {
|
if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) {
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
|
|
for (searchInterp = interp, i = 0; i < argc; i++) {
|
for (searchInterp = interp, i = 0; i < argc; i++) {
|
|
|
hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]);
|
hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
|
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
|
searchInterp = slavePtr->slaveInterp;
|
searchInterp = slavePtr->slaveInterp;
|
if (searchInterp == (Tcl_Interp *) NULL) {
|
if (searchInterp == (Tcl_Interp *) NULL) {
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(searchInterp,
|
masterPtr = (Master *) Tcl_GetAssocData(searchInterp,
|
"tclMasterRecord", NULL);
|
"tclMasterRecord", NULL);
|
if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr;
|
if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr;
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
}
|
}
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return searchInterp;
|
return searchInterp;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* CreateSlave --
|
* CreateSlave --
|
*
|
*
|
* Helper function to do the actual work of creating a slave interp
|
* Helper function to do the actual work of creating a slave interp
|
* and new object command. Also optionally makes the new slave
|
* and new object command. Also optionally makes the new slave
|
* interpreter "safe".
|
* interpreter "safe".
|
*
|
*
|
* Results:
|
* Results:
|
* Returns the new Tcl_Interp * if successful or NULL if not. If failed,
|
* Returns the new Tcl_Interp * if successful or NULL if not. If failed,
|
* the result of the invoking interpreter contains an error message.
|
* the result of the invoking interpreter contains an error message.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Creates a new slave interpreter and a new object command.
|
* Creates a new slave interpreter and a new object command.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static Tcl_Interp *
|
static Tcl_Interp *
|
CreateSlave(interp, masterPtr, slavePath, safe)
|
CreateSlave(interp, masterPtr, slavePath, safe)
|
Tcl_Interp *interp; /* Interp. to start search from. */
|
Tcl_Interp *interp; /* Interp. to start search from. */
|
Master *masterPtr; /* Master record. */
|
Master *masterPtr; /* Master record. */
|
char *slavePath; /* Path (name) of slave to create. */
|
char *slavePath; /* Path (name) of slave to create. */
|
int safe; /* Should we make it "safe"? */
|
int safe; /* Should we make it "safe"? */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */
|
Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */
|
Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */
|
Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */
|
Slave *slavePtr; /* Slave record. */
|
Slave *slavePtr; /* Slave record. */
|
Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */
|
Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */
|
int new; /* Indicates whether new entry. */
|
int new; /* Indicates whether new entry. */
|
int argc; /* Count of elements in slavePath. */
|
int argc; /* Count of elements in slavePath. */
|
char **argv; /* Elements in slavePath. */
|
char **argv; /* Elements in slavePath. */
|
char *masterPath; /* Path to its master. */
|
char *masterPath; /* Path to its master. */
|
|
|
if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) {
|
if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) {
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
|
|
if (argc < 2) {
|
if (argc < 2) {
|
masterInterp = interp;
|
masterInterp = interp;
|
if (argc == 1) {
|
if (argc == 1) {
|
slavePath = argv[0];
|
slavePath = argv[0];
|
}
|
}
|
} else {
|
} else {
|
masterPath = Tcl_Merge(argc-1, argv);
|
masterPath = Tcl_Merge(argc-1, argv);
|
masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
|
masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter named \"", masterPath,
|
"interpreter named \"", masterPath,
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
ckfree((char *) masterPath);
|
ckfree((char *) masterPath);
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
ckfree((char *) masterPath);
|
ckfree((char *) masterPath);
|
slavePath = argv[argc-1];
|
slavePath = argv[argc-1];
|
if (!safe) {
|
if (!safe) {
|
safe = Tcl_IsSafe(masterInterp);
|
safe = Tcl_IsSafe(masterInterp);
|
}
|
}
|
}
|
}
|
hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
|
hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
|
if (new == 0) {
|
if (new == 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter named \"", slavePath,
|
"interpreter named \"", slavePath,
|
"\" already exists, cannot create", (char *) NULL);
|
"\" already exists, cannot create", (char *) NULL);
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
slaveInterp = Tcl_CreateInterp();
|
slaveInterp = Tcl_CreateInterp();
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
panic("CreateSlave: out of memory while creating a new interpreter");
|
panic("CreateSlave: out of memory while creating a new interpreter");
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
|
slavePtr->masterInterp = masterInterp;
|
slavePtr->masterInterp = masterInterp;
|
slavePtr->slaveEntry = hPtr;
|
slavePtr->slaveEntry = hPtr;
|
slavePtr->slaveInterp = slaveInterp;
|
slavePtr->slaveInterp = slaveInterp;
|
slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath,
|
slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath,
|
SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc);
|
SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc);
|
Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
|
Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
|
(void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
|
(void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
|
SlaveRecordDeleteProc, (ClientData) slavePtr);
|
SlaveRecordDeleteProc, (ClientData) slavePtr);
|
Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
|
Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
|
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
|
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
|
|
|
/*
|
/*
|
* Inherit the recursion limit.
|
* Inherit the recursion limit.
|
*/
|
*/
|
((Interp *)slaveInterp)->maxNestingDepth =
|
((Interp *)slaveInterp)->maxNestingDepth =
|
((Interp *)masterInterp)->maxNestingDepth ;
|
((Interp *)masterInterp)->maxNestingDepth ;
|
|
|
if (safe) {
|
if (safe) {
|
if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
|
if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
|
goto error;
|
goto error;
|
}
|
}
|
} else {
|
} else {
|
if (Tcl_Init(slaveInterp) == TCL_ERROR) {
|
if (Tcl_Init(slaveInterp) == TCL_ERROR) {
|
goto error;
|
goto error;
|
}
|
}
|
}
|
}
|
|
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return slaveInterp;
|
return slaveInterp;
|
|
|
error:
|
error:
|
|
|
Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *)
|
Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *)
|
NULL, TCL_GLOBAL_ONLY));
|
NULL, TCL_GLOBAL_ONLY));
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL,
|
TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
|
|
(void) Tcl_DeleteCommand(masterInterp, slavePath);
|
(void) Tcl_DeleteCommand(masterInterp, slavePath);
|
|
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return (Tcl_Interp *) NULL;
|
return (Tcl_Interp *) NULL;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* CreateInterpObject -
|
* CreateInterpObject -
|
*
|
*
|
* Helper function to do the actual work of creating a new interpreter
|
* Helper function to do the actual work of creating a new interpreter
|
* and an object command.
|
* and an object command.
|
*
|
*
|
* Results:
|
* Results:
|
* A Tcl result.
|
* A Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See user documentation for details.
|
* See user documentation for details.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
CreateInterpObject(interp, masterPtr, objc, objv)
|
CreateInterpObject(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Invoking interpreter. */
|
Tcl_Interp *interp; /* Invoking interpreter. */
|
Master *masterPtr; /* Master record for same. */
|
Master *masterPtr; /* Master record for same. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* with alias. */
|
Tcl_Obj *CONST objv[]; /* with alias. */
|
{
|
{
|
int safe; /* Create a safe interpreter? */
|
int safe; /* Create a safe interpreter? */
|
int moreFlags; /* Expecting more flag args? */
|
int moreFlags; /* Expecting more flag args? */
|
char *string; /* Local pointer to object string. */
|
char *string; /* Local pointer to object string. */
|
char *slavePath; /* Name of slave. */
|
char *slavePath; /* Name of slave. */
|
char localSlaveName[200]; /* Local area for creating names. */
|
char localSlaveName[200]; /* Local area for creating names. */
|
int i; /* Loop counter. */
|
int i; /* Loop counter. */
|
int len; /* Length of option argument. */
|
int len; /* Length of option argument. */
|
static int interpCounter = 0; /* Unique id for created names. */
|
static int interpCounter = 0; /* Unique id for created names. */
|
|
|
moreFlags = 1;
|
moreFlags = 1;
|
slavePath = NULL;
|
slavePath = NULL;
|
safe = Tcl_IsSafe(interp);
|
safe = Tcl_IsSafe(interp);
|
|
|
if ((objc < 2) || (objc > 5)) {
|
if ((objc < 2) || (objc > 5)) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
for (i = 2; i < objc; i++) {
|
for (i = 2; i < objc; i++) {
|
string = Tcl_GetStringFromObj(objv[i], &len);
|
string = Tcl_GetStringFromObj(objv[i], &len);
|
if ((string[0] == '-') && (moreFlags != 0)) {
|
if ((string[0] == '-') && (moreFlags != 0)) {
|
if ((string[1] == 's') &&
|
if ((string[1] == 's') &&
|
(strncmp(string, "-safe", (size_t) len) == 0) &&
|
(strncmp(string, "-safe", (size_t) len) == 0) &&
|
(len > 1)){
|
(len > 1)){
|
safe = 1;
|
safe = 1;
|
} else if ((strncmp(string, "--", (size_t) len) == 0) &&
|
} else if ((strncmp(string, "--", (size_t) len) == 0) &&
|
(len > 1)) {
|
(len > 1)) {
|
moreFlags = 0;
|
moreFlags = 0;
|
} else {
|
} else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad option \"", string, "\": should be -safe",
|
"bad option \"", string, "\": should be -safe",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else {
|
} else {
|
slavePath = string;
|
slavePath = string;
|
}
|
}
|
}
|
}
|
if (slavePath == (char *) NULL) {
|
if (slavePath == (char *) NULL) {
|
|
|
/*
|
/*
|
* Create an anonymous interpreter -- we choose its name and
|
* Create an anonymous interpreter -- we choose its name and
|
* the name of the command. We check that the command name that
|
* the name of the command. We check that the command name that
|
* we use for the interpreter does not collide with an existing
|
* we use for the interpreter does not collide with an existing
|
* command in the master interpreter.
|
* command in the master interpreter.
|
*/
|
*/
|
|
|
while (1) {
|
while (1) {
|
Tcl_CmdInfo cmdInfo;
|
Tcl_CmdInfo cmdInfo;
|
|
|
sprintf(localSlaveName, "interp%d", interpCounter);
|
sprintf(localSlaveName, "interp%d", interpCounter);
|
interpCounter++;
|
interpCounter++;
|
if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
|
if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
slavePath = localSlaveName;
|
slavePath = localSlaveName;
|
}
|
}
|
if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
|
if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1));
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1));
|
return TCL_OK;
|
return TCL_OK;
|
} else {
|
} else {
|
/*
|
/*
|
* CreateSlave already set the result if there was an error,
|
* CreateSlave already set the result if there was an error,
|
* so we do not do it here.
|
* so we do not do it here.
|
*/
|
*/
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DeleteOneInterpObject --
|
* DeleteOneInterpObject --
|
*
|
*
|
* Helper function for DeleteInterpObject. It deals with deleting one
|
* Helper function for DeleteInterpObject. It deals with deleting one
|
* interpreter at a time.
|
* interpreter at a time.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deletes an interpreter and its interpreter object command.
|
* Deletes an interpreter and its interpreter object command.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
DeleteOneInterpObject(interp, masterPtr, path)
|
DeleteOneInterpObject(interp, masterPtr, path)
|
Tcl_Interp *interp; /* Interpreter for reporting errors. */
|
Tcl_Interp *interp; /* Interpreter for reporting errors. */
|
Master *masterPtr; /* Interim storage for master record.*/
|
Master *masterPtr; /* Interim storage for master record.*/
|
char *path; /* Path of interpreter to delete. */
|
char *path; /* Path of interpreter to delete. */
|
{
|
{
|
Slave *slavePtr; /* Interim storage for slave record. */
|
Slave *slavePtr; /* Interim storage for slave record. */
|
Tcl_Interp *masterInterp; /* Master of interp. to delete. */
|
Tcl_Interp *masterInterp; /* Master of interp. to delete. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
int localArgc; /* Local copy of count of elements in
|
int localArgc; /* Local copy of count of elements in
|
* path (name) of interp. to delete. */
|
* path (name) of interp. to delete. */
|
char **localArgv; /* Local copy of path. */
|
char **localArgv; /* Local copy of path. */
|
char *slaveName; /* Last component in path. */
|
char *slaveName; /* Last component in path. */
|
char *masterPath; /* One-before-last component in path.*/
|
char *masterPath; /* One-before-last component in path.*/
|
|
|
if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) {
|
if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad interpreter path \"", path, "\"", (char *) NULL);
|
"bad interpreter path \"", path, "\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (localArgc < 2) {
|
if (localArgc < 2) {
|
masterInterp = interp;
|
masterInterp = interp;
|
if (localArgc == 0) {
|
if (localArgc == 0) {
|
slaveName = "";
|
slaveName = "";
|
} else {
|
} else {
|
slaveName = localArgv[0];
|
slaveName = localArgv[0];
|
}
|
}
|
} else {
|
} else {
|
masterPath = Tcl_Merge(localArgc-1, localArgv);
|
masterPath = Tcl_Merge(localArgc-1, localArgv);
|
masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
|
masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter named \"", masterPath, "\" not found",
|
"interpreter named \"", masterPath, "\" not found",
|
(char *) NULL);
|
(char *) NULL);
|
ckfree((char *) localArgv);
|
ckfree((char *) localArgv);
|
ckfree((char *) masterPath);
|
ckfree((char *) masterPath);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
ckfree((char *) masterPath);
|
ckfree((char *) masterPath);
|
slaveName = localArgv[localArgc-1];
|
slaveName = localArgv[localArgc-1];
|
}
|
}
|
hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName);
|
hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
ckfree((char *) localArgv);
|
ckfree((char *) localArgv);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter named \"", path, "\" not found", (char *) NULL);
|
"interpreter named \"", path, "\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
|
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
|
if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) {
|
if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) {
|
ckfree((char *) localArgv);
|
ckfree((char *) localArgv);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter named \"", path, "\" not found", (char *) NULL);
|
"interpreter named \"", path, "\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
ckfree((char *) localArgv);
|
ckfree((char *) localArgv);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DeleteInterpObject --
|
* DeleteInterpObject --
|
*
|
*
|
* Helper function to do the work of deleting zero or more
|
* Helper function to do the work of deleting zero or more
|
* interpreters and their interpreter object commands.
|
* interpreters and their interpreter object commands.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deletes interpreters and their interpreter object command.
|
* Deletes interpreters and their interpreter object command.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
DeleteInterpObject(interp, masterPtr, objc, objv)
|
DeleteInterpObject(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Interpreter start search from. */
|
Tcl_Interp *interp; /* Interpreter start search from. */
|
Master *masterPtr; /* Interim storage for master record.*/
|
Master *masterPtr; /* Interim storage for master record.*/
|
int objc; /* Number of arguments in vector. */
|
int objc; /* Number of arguments in vector. */
|
Tcl_Obj *CONST objv[]; /* with alias. */
|
Tcl_Obj *CONST objv[]; /* with alias. */
|
{
|
{
|
int i;
|
int i;
|
int len;
|
int len;
|
|
|
for (i = 2; i < objc; i++) {
|
for (i = 2; i < objc; i++) {
|
if (DeleteOneInterpObject(interp, masterPtr,
|
if (DeleteOneInterpObject(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[i], &len))
|
Tcl_GetStringFromObj(objv[i], &len))
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* AliasCreationHelper --
|
* AliasCreationHelper --
|
*
|
*
|
* Helper function to do the work to actually create an alias or
|
* Helper function to do the work to actually create an alias or
|
* delete an alias.
|
* delete an alias.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* An alias command is created and entered into the alias table
|
* An alias command is created and entered into the alias table
|
* for the slave interpreter.
|
* for the slave interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
|
AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
|
aliasName, targetName, objc, objv)
|
aliasName, targetName, objc, objv)
|
Tcl_Interp *curInterp; /* Interp that invoked this proc. */
|
Tcl_Interp *curInterp; /* Interp that invoked this proc. */
|
Tcl_Interp *slaveInterp; /* Interp where alias cmd will live
|
Tcl_Interp *slaveInterp; /* Interp where alias cmd will live
|
* or from which alias will be
|
* or from which alias will be
|
* deleted. */
|
* deleted. */
|
Tcl_Interp *masterInterp; /* Interp where target cmd will be. */
|
Tcl_Interp *masterInterp; /* Interp where target cmd will be. */
|
Master *masterPtr; /* Master record for target interp. */
|
Master *masterPtr; /* Master record for target interp. */
|
char *aliasName; /* Name of alias cmd. */
|
char *aliasName; /* Name of alias cmd. */
|
char *targetName; /* Name of target cmd. */
|
char *targetName; /* Name of target cmd. */
|
int objc; /* Additional arguments to store */
|
int objc; /* Additional arguments to store */
|
Tcl_Obj *CONST objv[]; /* with alias. */
|
Tcl_Obj *CONST objv[]; /* with alias. */
|
{
|
{
|
Alias *aliasPtr; /* Storage for alias data. */
|
Alias *aliasPtr; /* Storage for alias data. */
|
Alias *tmpAliasPtr; /* Temp storage for alias to delete. */
|
Alias *tmpAliasPtr; /* Temp storage for alias to delete. */
|
Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */
|
Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */
|
int i; /* Loop index. */
|
int i; /* Loop index. */
|
int new; /* Is it a new hash entry? */
|
int new; /* Is it a new hash entry? */
|
Target *targetPtr; /* Maps from target command in master
|
Target *targetPtr; /* Maps from target command in master
|
* to source command in slave. */
|
* to source command in slave. */
|
Slave *slavePtr; /* Maps from source command in slave
|
Slave *slavePtr; /* Maps from source command in slave
|
* to target command in master. */
|
* to target command in master. */
|
|
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
|
|
|
/*
|
/*
|
* Slave record should be always present because it is created when
|
* Slave record should be always present because it is created when
|
* the interpreter is created.
|
* the interpreter is created.
|
*/
|
*/
|
|
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
panic("AliasCreationHelper: could not find slave record");
|
panic("AliasCreationHelper: could not find slave record");
|
}
|
}
|
|
|
if ((targetName == (char *) NULL) || (targetName[0] == '\0')) {
|
if ((targetName == (char *) NULL) || (targetName[0] == '\0')) {
|
if (objc != 0) {
|
if (objc != 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp),
|
"malformed command: should be",
|
"malformed command: should be",
|
" \"alias ", aliasName, " {}\"", (char *) NULL);
|
" \"alias ", aliasName, " {}\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
return DeleteAlias(curInterp, slaveInterp, aliasName);
|
return DeleteAlias(curInterp, slaveInterp, aliasName);
|
}
|
}
|
|
|
aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
|
aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
|
aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1);
|
aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1);
|
aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1);
|
aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1);
|
strcpy(aliasPtr->aliasName, aliasName);
|
strcpy(aliasPtr->aliasName, aliasName);
|
strcpy(aliasPtr->targetName, targetName);
|
strcpy(aliasPtr->targetName, targetName);
|
aliasPtr->targetInterp = masterInterp;
|
aliasPtr->targetInterp = masterInterp;
|
|
|
aliasPtr->objv = NULL;
|
aliasPtr->objv = NULL;
|
aliasPtr->objc = objc;
|
aliasPtr->objc = objc;
|
|
|
if (aliasPtr->objc > 0) {
|
if (aliasPtr->objc > 0) {
|
aliasPtr->objv =
|
aliasPtr->objv =
|
(Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) *
|
(Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) *
|
aliasPtr->objc);
|
aliasPtr->objc);
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
aliasPtr->objv[i] = objv[i];
|
aliasPtr->objv[i] = objv[i];
|
Tcl_IncrRefCount(objv[i]);
|
Tcl_IncrRefCount(objv[i]);
|
}
|
}
|
}
|
}
|
|
|
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName,
|
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName,
|
AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc);
|
AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc);
|
|
|
if (TclPreventAliasLoop(curInterp, slaveInterp,
|
if (TclPreventAliasLoop(curInterp, slaveInterp,
|
aliasPtr->slaveCmd) != TCL_OK) {
|
aliasPtr->slaveCmd) != TCL_OK) {
|
|
|
/*
|
/*
|
* Found an alias loop! The last call to Tcl_CreateObjCommand
|
* Found an alias loop! The last call to Tcl_CreateObjCommand
|
* made the alias point to itself. Delete the command and
|
* made the alias point to itself. Delete the command and
|
* its alias record. Be careful to wipe out its client data
|
* its alias record. Be careful to wipe out its client data
|
* first, so the command doesn't try to delete itself.
|
* first, so the command doesn't try to delete itself.
|
*/
|
*/
|
|
|
Command *cmdPtr = (Command*) aliasPtr->slaveCmd;
|
Command *cmdPtr = (Command*) aliasPtr->slaveCmd;
|
cmdPtr->clientData = NULL;
|
cmdPtr->clientData = NULL;
|
cmdPtr->deleteProc = NULL;
|
cmdPtr->deleteProc = NULL;
|
cmdPtr->deleteData = NULL;
|
cmdPtr->deleteData = NULL;
|
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
|
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
|
|
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
Tcl_DecrRefCount(aliasPtr->objv[i]);
|
Tcl_DecrRefCount(aliasPtr->objv[i]);
|
}
|
}
|
if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) {
|
if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) {
|
ckfree((char *) aliasPtr->objv);
|
ckfree((char *) aliasPtr->objv);
|
}
|
}
|
ckfree(aliasPtr->aliasName);
|
ckfree(aliasPtr->aliasName);
|
ckfree(aliasPtr->targetName);
|
ckfree(aliasPtr->targetName);
|
ckfree((char *) aliasPtr);
|
ckfree((char *) aliasPtr);
|
|
|
/*
|
/*
|
* The result was already set by TclPreventAliasLoop.
|
* The result was already set by TclPreventAliasLoop.
|
*/
|
*/
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make an entry in the alias table. If it already exists delete
|
* Make an entry in the alias table. If it already exists delete
|
* the alias command. Then retry.
|
* the alias command. Then retry.
|
*/
|
*/
|
|
|
do {
|
do {
|
hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new);
|
hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new);
|
if (!new) {
|
if (!new) {
|
tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
(void) Tcl_DeleteCommandFromToken(slaveInterp,
|
(void) Tcl_DeleteCommandFromToken(slaveInterp,
|
tmpAliasPtr->slaveCmd);
|
tmpAliasPtr->slaveCmd);
|
|
|
/*
|
/*
|
* The hash entry should be deleted by the Tcl_DeleteCommand
|
* The hash entry should be deleted by the Tcl_DeleteCommand
|
* above, in its command deletion callback (most likely this
|
* above, in its command deletion callback (most likely this
|
* will be AliasCmdDeleteProc, which does the deletion).
|
* will be AliasCmdDeleteProc, which does the deletion).
|
*/
|
*/
|
}
|
}
|
} while (new == 0);
|
} while (new == 0);
|
aliasPtr->aliasEntry = hPtr;
|
aliasPtr->aliasEntry = hPtr;
|
Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
|
|
|
/*
|
/*
|
* Create the new command. We must do it after deleting any old command,
|
* Create the new command. We must do it after deleting any old command,
|
* because the alias may be pointing at a renamed alias, as in:
|
* because the alias may be pointing at a renamed alias, as in:
|
*
|
*
|
* interp alias {} foo {} bar # Create an alias "foo"
|
* interp alias {} foo {} bar # Create an alias "foo"
|
* rename foo zop # Now rename the alias
|
* rename foo zop # Now rename the alias
|
* interp alias {} foo {} zop # Now recreate "foo"...
|
* interp alias {} foo {} zop # Now recreate "foo"...
|
*/
|
*/
|
|
|
targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
|
targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
|
targetPtr->slaveCmd = aliasPtr->slaveCmd;
|
targetPtr->slaveCmd = aliasPtr->slaveCmd;
|
targetPtr->slaveInterp = slaveInterp;
|
targetPtr->slaveInterp = slaveInterp;
|
|
|
do {
|
do {
|
hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable),
|
hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable),
|
(char *) aliasCounter, &new);
|
(char *) aliasCounter, &new);
|
aliasCounter++;
|
aliasCounter++;
|
} while (new == 0);
|
} while (new == 0);
|
|
|
Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
|
|
|
aliasPtr->targetEntry = hPtr;
|
aliasPtr->targetEntry = hPtr;
|
|
|
/*
|
/*
|
* Make sure we clear out the object result when setting the string
|
* Make sure we clear out the object result when setting the string
|
* result.
|
* result.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1));
|
Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1));
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpAliasesHelper --
|
* InterpAliasesHelper --
|
*
|
*
|
* Computes a list of aliases defined in an interpreter.
|
* Computes a list of aliases defined in an interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpAliasesHelper(interp, masterPtr, objc, objv)
|
InterpAliasesHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Invoking interpreter. */
|
Tcl_Interp *interp; /* Invoking interpreter. */
|
Master *masterPtr; /* Master record for current interp. */
|
Master *masterPtr; /* Master record for current interp. */
|
int objc; /* How many arguments? */
|
int objc; /* How many arguments? */
|
Tcl_Obj *CONST objv[]; /* Actual arguments. */
|
Tcl_Obj *CONST objv[]; /* Actual arguments. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Slave *slavePtr; /* Record for slave interp. */
|
Slave *slavePtr; /* Record for slave interp. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashSearch hSearch; /* Iteration variable. */
|
Tcl_HashSearch hSearch; /* Iteration variable. */
|
int len; /* Dummy length variable. */
|
int len; /* Dummy length variable. */
|
Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */
|
Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */
|
|
|
if ((objc != 2) && (objc != 3)) {
|
if ((objc != 2) && (objc != 3)) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc == 3) {
|
if (objc == 3) {
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else {
|
} else {
|
slaveInterp = interp;
|
slaveInterp = interp;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
|
"tclSlaveRecord", NULL);
|
"tclSlaveRecord", NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* Build a list to return the aliases:
|
* Build a list to return the aliases:
|
*/
|
*/
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
|
|
elemObjPtr = Tcl_NewStringObj(
|
elemObjPtr = Tcl_NewStringObj(
|
Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1);
|
Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1);
|
Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr);
|
Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr);
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpAliasHelper -
|
* InterpAliasHelper -
|
*
|
*
|
* Handles the different forms of the "interp alias" command:
|
* Handles the different forms of the "interp alias" command:
|
* - interp alias slavePath aliasName
|
* - interp alias slavePath aliasName
|
* Describes an alias.
|
* Describes an alias.
|
* - interp alias slavePath aliasName {}
|
* - interp alias slavePath aliasName {}
|
* Deletes an alias.
|
* Deletes an alias.
|
* - interp alias slavePath srcCmd masterPath targetCmd args...
|
* - interp alias slavePath srcCmd masterPath targetCmd args...
|
* Creates an alias.
|
* Creates an alias.
|
*
|
*
|
* Results:
|
* Results:
|
* A Tcl result.
|
* A Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See user documentation for details.
|
* See user documentation for details.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpAliasHelper(interp, masterPtr, objc, objv)
|
InterpAliasHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for current interp. */
|
Master *masterPtr; /* Master record for current interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp, /* Interpreters used when */
|
Tcl_Interp *slaveInterp, /* Interpreters used when */
|
*masterInterp; /* creating an alias btn siblings. */
|
*masterInterp; /* creating an alias btn siblings. */
|
Master *masterMasterPtr; /* Master record for master interp. */
|
Master *masterMasterPtr; /* Master record for master interp. */
|
int len;
|
int len;
|
|
|
if (objc < 4) {
|
if (objc < 4) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"slavePath slaveCmd masterPath masterCmd ?args ..?");
|
"slavePath slaveCmd masterPath masterCmd ?args ..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"could not find interpreter \"",
|
"could not find interpreter \"",
|
Tcl_GetStringFromObj(objv[2], &len), "\"",
|
Tcl_GetStringFromObj(objv[2], &len), "\"",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc == 4) {
|
if (objc == 4) {
|
return DescribeAlias(interp, slaveInterp,
|
return DescribeAlias(interp, slaveInterp,
|
Tcl_GetStringFromObj(objv[3], &len));
|
Tcl_GetStringFromObj(objv[3], &len));
|
}
|
}
|
if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) {
|
if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) {
|
return DeleteAlias(interp, slaveInterp,
|
return DeleteAlias(interp, slaveInterp,
|
Tcl_GetStringFromObj(objv[3], &len));
|
Tcl_GetStringFromObj(objv[3], &len));
|
}
|
}
|
if (objc < 6) {
|
if (objc < 6) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"slavePath slaveCmd masterPath masterCmd ?args ..?");
|
"slavePath slaveCmd masterPath masterCmd ?args ..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
masterInterp = GetInterp(interp, masterPtr,
|
masterInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr);
|
Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr);
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"could not find interpreter \"",
|
"could not find interpreter \"",
|
Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL);
|
Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return AliasCreationHelper(interp, slaveInterp, masterInterp,
|
return AliasCreationHelper(interp, slaveInterp, masterInterp,
|
masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len),
|
masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len),
|
Tcl_GetStringFromObj(objv[5], &len),
|
Tcl_GetStringFromObj(objv[5], &len),
|
objc-6, objv+6);
|
objc-6, objv+6);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpExistsHelper --
|
* InterpExistsHelper --
|
*
|
*
|
* Computes whether a named interpreter exists or not.
|
* Computes whether a named interpreter exists or not.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpExistsHelper(interp, masterPtr, objc, objv)
|
InterpExistsHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for current interp. */
|
Master *masterPtr; /* Master record for current interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
int len;
|
int len;
|
|
|
if (objc > 3) {
|
if (objc > 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc == 3) {
|
if (objc == 3) {
|
if (GetInterp(interp, masterPtr,
|
if (GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), NULL) ==
|
Tcl_GetStringFromObj(objv[2], &len), NULL) ==
|
(Tcl_Interp *) NULL) {
|
(Tcl_Interp *) NULL) {
|
objPtr = Tcl_NewIntObj(0);
|
objPtr = Tcl_NewIntObj(0);
|
} else {
|
} else {
|
objPtr = Tcl_NewIntObj(1);
|
objPtr = Tcl_NewIntObj(1);
|
}
|
}
|
} else {
|
} else {
|
objPtr = Tcl_NewIntObj(1);
|
objPtr = Tcl_NewIntObj(1);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpEvalHelper --
|
* InterpEvalHelper --
|
*
|
*
|
* Helper function to handle all the details of evaluating a
|
* Helper function to handle all the details of evaluating a
|
* command in another interpreter.
|
* command in another interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the command itself does.
|
* Whatever the command itself does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpEvalHelper(interp, masterPtr, objc, objv)
|
InterpEvalHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for current interp. */
|
Master *masterPtr; /* Master record for current interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Interp *iPtr; /* Internal data type for slave. */
|
Interp *iPtr; /* Internal data type for slave. */
|
int len; /* Dummy length variable. */
|
int len; /* Dummy length variable. */
|
int result;
|
int result;
|
Tcl_Obj *namePtr, *objPtr; /* Local object pointer. */
|
Tcl_Obj *namePtr, *objPtr; /* Local object pointer. */
|
char *string;
|
char *string;
|
|
|
if (objc < 4) {
|
if (objc < 4) {
|
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
|
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter named \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter named \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
objPtr = Tcl_ConcatObj(objc-3, objv+3);
|
objPtr = Tcl_ConcatObj(objc-3, objv+3);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
|
|
Tcl_Preserve((ClientData) slaveInterp);
|
Tcl_Preserve((ClientData) slaveInterp);
|
result = Tcl_EvalObj(slaveInterp, objPtr);
|
result = Tcl_EvalObj(slaveInterp, objPtr);
|
|
|
Tcl_DecrRefCount(objPtr);
|
Tcl_DecrRefCount(objPtr);
|
|
|
/*
|
/*
|
* Now make the result and any error information accessible. We
|
* Now make the result and any error information accessible. We
|
* have to be careful because the slave interpreter and the current
|
* have to be careful because the slave interpreter and the current
|
* interpreter can be the same - do not destroy the result.. This
|
* interpreter can be the same - do not destroy the result.. This
|
* can happen if an interpreter contains an alias which is directed
|
* can happen if an interpreter contains an alias which is directed
|
* at a target command in the same interpreter.
|
* at a target command in the same interpreter.
|
*/
|
*/
|
|
|
if (interp != slaveInterp) {
|
if (interp != slaveInterp) {
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
|
|
/*
|
/*
|
* An error occurred, so transfer error information from
|
* An error occurred, so transfer error information from
|
* the target interpreter back to our interpreter.
|
* the target interpreter back to our interpreter.
|
*/
|
*/
|
|
|
iPtr = (Interp *) slaveInterp;
|
iPtr = (Interp *) slaveInterp;
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_AddErrorInfo(slaveInterp, "");
|
Tcl_AddErrorInfo(slaveInterp, "");
|
}
|
}
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
NULL, TCL_GLOBAL_ONLY),
|
NULL, TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Move the result object from one interpreter to the
|
* Move the result object from one interpreter to the
|
* other.
|
* other.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
|
|
}
|
}
|
Tcl_Release((ClientData) slaveInterp);
|
Tcl_Release((ClientData) slaveInterp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpExposeHelper --
|
* InterpExposeHelper --
|
*
|
*
|
* Helper function to handle the details of exposing a command in
|
* Helper function to handle the details of exposing a command in
|
* another interpreter.
|
* another interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* Standard Tcl result.
|
* Standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Exposes a command. From now on the command can be called by scripts
|
* Exposes a command. From now on the command can be called by scripts
|
* in the interpreter in which it was exposed.
|
* in the interpreter in which it was exposed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpExposeHelper(interp, masterPtr, objc, objv)
|
InterpExposeHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for current interp. */
|
Master *masterPtr; /* Master record for current interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
int len; /* Dummy length variable. */
|
int len; /* Dummy length variable. */
|
|
|
if ((objc != 4) && (objc != 5)) {
|
if ((objc != 4) && (objc != 5)) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"path hiddenCmdName ?cmdName?");
|
"path hiddenCmdName ?cmdName?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"permission denied: safe interpreter cannot expose commands",
|
"permission denied: safe interpreter cannot expose commands",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_ExposeCommand(slaveInterp,
|
if (Tcl_ExposeCommand(slaveInterp,
|
Tcl_GetStringFromObj(objv[3], &len),
|
Tcl_GetStringFromObj(objv[3], &len),
|
(objc == 5 ?
|
(objc == 5 ?
|
Tcl_GetStringFromObj(objv[4], &len) :
|
Tcl_GetStringFromObj(objv[4], &len) :
|
Tcl_GetStringFromObj(objv[3], &len)))
|
Tcl_GetStringFromObj(objv[3], &len)))
|
== TCL_ERROR) {
|
== TCL_ERROR) {
|
if (interp != slaveInterp) {
|
if (interp != slaveInterp) {
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpHideHelper --
|
* InterpHideHelper --
|
*
|
*
|
* Helper function that handles the details of hiding a command in
|
* Helper function that handles the details of hiding a command in
|
* another interpreter.
|
* another interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Hides a command. From now on the command cannot be called by
|
* Hides a command. From now on the command cannot be called by
|
* scripts in that interpreter.
|
* scripts in that interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpHideHelper(interp, masterPtr, objc, objv)
|
InterpHideHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
int len; /* Dummy length variable. */
|
int len; /* Dummy length variable. */
|
|
|
if ((objc != 4) && (objc != 5)) {
|
if ((objc != 4) && (objc != 5)) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"path cmdName ?hiddenCmdName?");
|
"path cmdName ?hiddenCmdName?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"permission denied: safe interpreter cannot hide commands",
|
"permission denied: safe interpreter cannot hide commands",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len),
|
if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len),
|
(objc == 5 ?
|
(objc == 5 ?
|
Tcl_GetStringFromObj(objv[4], &len) :
|
Tcl_GetStringFromObj(objv[4], &len) :
|
Tcl_GetStringFromObj(objv[3], &len)))
|
Tcl_GetStringFromObj(objv[3], &len)))
|
== TCL_ERROR) {
|
== TCL_ERROR) {
|
if (interp != slaveInterp) {
|
if (interp != slaveInterp) {
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpHiddenHelper --
|
* InterpHiddenHelper --
|
*
|
*
|
* Computes the list of hidden commands in a named interpreter.
|
* Computes the list of hidden commands in a named interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpHiddenHelper(interp, masterPtr, objc, objv)
|
InterpHiddenHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
int len;
|
int len;
|
Tcl_HashTable *hTblPtr; /* Hidden command table. */
|
Tcl_HashTable *hTblPtr; /* Hidden command table. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashSearch hSearch; /* Iteration variable. */
|
Tcl_HashSearch hSearch; /* Iteration variable. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
|
|
if (objc > 3) {
|
if (objc > 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc == 3) {
|
if (objc == 3) {
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len),
|
Tcl_GetStringFromObj(objv[2], &len),
|
&masterPtr);
|
&masterPtr);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else {
|
} else {
|
slaveInterp = interp;
|
slaveInterp = interp;
|
}
|
}
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
|
"tclHiddenCmds", NULL);
|
"tclHiddenCmds", NULL);
|
if (hTblPtr != (Tcl_HashTable *) NULL) {
|
if (hTblPtr != (Tcl_HashTable *) NULL) {
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
|
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
|
Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpInvokeHiddenHelper --
|
* InterpInvokeHiddenHelper --
|
*
|
*
|
* Helper routine to handle the details of invoking a hidden
|
* Helper routine to handle the details of invoking a hidden
|
* command in another interpreter.
|
* command in another interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the hidden command does.
|
* Whatever the hidden command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
|
InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
int doGlobal = 0;
|
int doGlobal = 0;
|
int len;
|
int len;
|
int result;
|
int result;
|
Tcl_Obj *namePtr, *objPtr;
|
Tcl_Obj *namePtr, *objPtr;
|
Tcl_Interp *slaveInterp;
|
Tcl_Interp *slaveInterp;
|
Interp *iPtr;
|
Interp *iPtr;
|
char *string;
|
char *string;
|
|
|
if (objc < 4) {
|
if (objc < 4) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"path ?-global? cmd ?arg ..?");
|
"path ?-global? cmd ?arg ..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"not allowed to invoke hidden commands from safe interpreter",
|
"not allowed to invoke hidden commands from safe interpreter",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) {
|
if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) {
|
doGlobal = 1;
|
doGlobal = 1;
|
if (objc < 5) {
|
if (objc < 5) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"path ?-global? cmd ?arg ..?");
|
"path ?-global? cmd ?arg ..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_Preserve((ClientData) slaveInterp);
|
Tcl_Preserve((ClientData) slaveInterp);
|
if (doGlobal) {
|
if (doGlobal) {
|
result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4,
|
result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4,
|
TCL_INVOKE_HIDDEN);
|
TCL_INVOKE_HIDDEN);
|
} else {
|
} else {
|
result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN);
|
result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN);
|
}
|
}
|
|
|
/*
|
/*
|
* Now make the result and any error information accessible. We
|
* Now make the result and any error information accessible. We
|
* have to be careful because the slave interpreter and the current
|
* have to be careful because the slave interpreter and the current
|
* interpreter can be the same - do not destroy the result.. This
|
* interpreter can be the same - do not destroy the result.. This
|
* can happen if an interpreter contains an alias which is directed
|
* can happen if an interpreter contains an alias which is directed
|
* at a target command in the same interpreter.
|
* at a target command in the same interpreter.
|
*/
|
*/
|
|
|
if (interp != slaveInterp) {
|
if (interp != slaveInterp) {
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
|
|
/*
|
/*
|
* An error occurred, so transfer error information from
|
* An error occurred, so transfer error information from
|
* the target interpreter back to our interpreter.
|
* the target interpreter back to our interpreter.
|
*/
|
*/
|
|
|
iPtr = (Interp *) slaveInterp;
|
iPtr = (Interp *) slaveInterp;
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_AddErrorInfo(slaveInterp, "");
|
Tcl_AddErrorInfo(slaveInterp, "");
|
}
|
}
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
NULL, TCL_GLOBAL_ONLY),
|
NULL, TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
}
|
}
|
|
|
/*
|
/*
|
* Move the result object from the slave to the master.
|
* Move the result object from the slave to the master.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
}
|
}
|
Tcl_Release((ClientData) slaveInterp);
|
Tcl_Release((ClientData) slaveInterp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpMarkTrustedHelper --
|
* InterpMarkTrustedHelper --
|
*
|
*
|
* Helper function to handle the details of marking another
|
* Helper function to handle the details of marking another
|
* interpreter as trusted (unsafe).
|
* interpreter as trusted (unsafe).
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Henceforth the hard-wired checks for safety will not prevent
|
* Henceforth the hard-wired checks for safety will not prevent
|
* this interpreter from performing certain operations.
|
* this interpreter from performing certain operations.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpMarkTrustedHelper(interp, masterPtr, objc, objv)
|
InterpMarkTrustedHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
int len; /* Dummy length variable. */
|
int len; /* Dummy length variable. */
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "path");
|
Tcl_WrongNumArgs(interp, 2, objv, "path");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", Tcl_GetStringFromObj(objv[0], &len),
|
"\"", Tcl_GetStringFromObj(objv[0], &len),
|
" marktrusted\" can only",
|
" marktrusted\" can only",
|
" be invoked from a trusted interpreter",
|
" be invoked from a trusted interpreter",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return MarkTrusted(slaveInterp);
|
return MarkTrusted(slaveInterp);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpIsSafeHelper --
|
* InterpIsSafeHelper --
|
*
|
*
|
* Computes whether a named interpreter is safe.
|
* Computes whether a named interpreter is safe.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpIsSafeHelper(interp, masterPtr, objc, objv)
|
InterpIsSafeHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
int len; /* Dummy length variable. */
|
int len; /* Dummy length variable. */
|
Tcl_Obj *objPtr; /* Local object pointer. */
|
Tcl_Obj *objPtr; /* Local object pointer. */
|
|
|
if (objc > 3) {
|
if (objc > 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc == 3) {
|
if (objc == 3) {
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"",
|
"interpreter \"",
|
Tcl_GetStringFromObj(objv[2], &len), "\" not found",
|
Tcl_GetStringFromObj(objv[2], &len), "\" not found",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
|
objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
|
} else {
|
} else {
|
objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp));
|
objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp));
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpSlavesHelper --
|
* InterpSlavesHelper --
|
*
|
*
|
* Computes a list of slave interpreters of a named interpreter.
|
* Computes a list of slave interpreters of a named interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpSlavesHelper(interp, masterPtr, objc, objv)
|
InterpSlavesHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
int len;
|
int len;
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashSearch hSearch; /* Iteration variable. */
|
Tcl_HashSearch hSearch; /* Iteration variable. */
|
Tcl_Obj *listObjPtr; /* Local object pointers. */
|
Tcl_Obj *listObjPtr; /* Local object pointers. */
|
|
|
if ((objc != 2) && (objc != 3)) {
|
if ((objc != 2) && (objc != 3)) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc == 3) {
|
if (objc == 3) {
|
if (GetInterp(interp, masterPtr,
|
if (GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr) ==
|
Tcl_GetStringFromObj(objv[2], &len), &masterPtr) ==
|
(Tcl_Interp *) NULL) {
|
(Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
|
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_NewStringObj(
|
Tcl_NewStringObj(
|
Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1));
|
Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1));
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpShareHelper --
|
* InterpShareHelper --
|
*
|
*
|
* Helper function to handle the details of sharing a channel between
|
* Helper function to handle the details of sharing a channel between
|
* interpreters.
|
* interpreters.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* After this call the named channel will be shared between the
|
* After this call the named channel will be shared between the
|
* interpreters named in the arguments.
|
* interpreters named in the arguments.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpShareHelper(interp, masterPtr, objc, objv)
|
InterpShareHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *masterInterp; /* Its master. */
|
Tcl_Interp *masterInterp; /* Its master. */
|
int len;
|
int len;
|
Tcl_Channel chan;
|
Tcl_Channel chan;
|
|
|
if (objc != 5) {
|
if (objc != 5) {
|
Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
|
Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
masterInterp = GetInterp(interp, masterPtr,
|
masterInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[4], &len), NULL);
|
Tcl_GetStringFromObj(objv[4], &len), NULL);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len),
|
chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len),
|
NULL);
|
NULL);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
if (interp != masterInterp) {
|
if (interp != masterInterp) {
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
Tcl_ResetResult(masterInterp);
|
Tcl_ResetResult(masterInterp);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_RegisterChannel(slaveInterp, chan);
|
Tcl_RegisterChannel(slaveInterp, chan);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpTargetHelper --
|
* InterpTargetHelper --
|
*
|
*
|
* Helper function to compute the target of an alias.
|
* Helper function to compute the target of an alias.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpTargetHelper(interp, masterPtr, objc, objv)
|
InterpTargetHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
int len;
|
int len;
|
|
|
if (objc != 4) {
|
if (objc != 4) {
|
Tcl_WrongNumArgs(interp, 2, objv, "path alias");
|
Tcl_WrongNumArgs(interp, 2, objv, "path alias");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return GetTarget(interp,
|
return GetTarget(interp,
|
Tcl_GetStringFromObj(objv[2], &len),
|
Tcl_GetStringFromObj(objv[2], &len),
|
Tcl_GetStringFromObj(objv[3], &len));
|
Tcl_GetStringFromObj(objv[3], &len));
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InterpTransferHelper --
|
* InterpTransferHelper --
|
*
|
*
|
* Helper function to handle the details of transferring ownership
|
* Helper function to handle the details of transferring ownership
|
* of a channel between interpreters.
|
* of a channel between interpreters.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* After the call, the named channel will be registered in the target
|
* After the call, the named channel will be registered in the target
|
* interpreter and no longer available for use in the source interpreter.
|
* interpreter and no longer available for use in the source interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InterpTransferHelper(interp, masterPtr, objc, objv)
|
InterpTransferHelper(interp, masterPtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Master *masterPtr; /* Master record for interp. */
|
Master *masterPtr; /* Master record for interp. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *slaveInterp; /* A slave. */
|
Tcl_Interp *masterInterp; /* Its master. */
|
Tcl_Interp *masterInterp; /* Its master. */
|
int len;
|
int len;
|
Tcl_Channel chan;
|
Tcl_Channel chan;
|
|
|
if (objc != 5) {
|
if (objc != 5) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"srcPath channelId destPath");
|
"srcPath channelId destPath");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
masterInterp = GetInterp(interp, masterPtr,
|
masterInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
Tcl_GetStringFromObj(objv[2], &len), NULL);
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
if (masterInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveInterp = GetInterp(interp, masterPtr,
|
slaveInterp = GetInterp(interp, masterPtr,
|
Tcl_GetStringFromObj(objv[4], &len), NULL);
|
Tcl_GetStringFromObj(objv[4], &len), NULL);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
|
"interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
|
"\" not found", (char *) NULL);
|
"\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
chan = Tcl_GetChannel(masterInterp,
|
chan = Tcl_GetChannel(masterInterp,
|
Tcl_GetStringFromObj(objv[3], &len), NULL);
|
Tcl_GetStringFromObj(objv[3], &len), NULL);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
if (interp != masterInterp) {
|
if (interp != masterInterp) {
|
|
|
/*
|
/*
|
* After fixing objresult, this code will change to:
|
* After fixing objresult, this code will change to:
|
* Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
* Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
Tcl_ResetResult(masterInterp);
|
Tcl_ResetResult(masterInterp);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_RegisterChannel(slaveInterp, chan);
|
Tcl_RegisterChannel(slaveInterp, chan);
|
if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
|
if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
|
if (interp != masterInterp) {
|
if (interp != masterInterp) {
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
|
Tcl_ResetResult(masterInterp);
|
Tcl_ResetResult(masterInterp);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DescribeAlias --
|
* DescribeAlias --
|
*
|
*
|
* Sets the interpreter's result object to a Tcl list describing
|
* Sets the interpreter's result object to a Tcl list describing
|
* the given alias in the given interpreter: its target command
|
* the given alias in the given interpreter: its target command
|
* and the additional arguments to prepend to any invocation
|
* and the additional arguments to prepend to any invocation
|
* of the alias.
|
* of the alias.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
DescribeAlias(interp, slaveInterp, aliasName)
|
DescribeAlias(interp, slaveInterp, aliasName)
|
Tcl_Interp *interp; /* Interpreter for result & errors. */
|
Tcl_Interp *interp; /* Interpreter for result & errors. */
|
Tcl_Interp *slaveInterp; /* Interpreter defining alias. */
|
Tcl_Interp *slaveInterp; /* Interpreter defining alias. */
|
char *aliasName; /* Name of alias to describe. */
|
char *aliasName; /* Name of alias to describe. */
|
{
|
{
|
Slave *slavePtr; /* Slave interp slave record. */
|
Slave *slavePtr; /* Slave interp slave record. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Alias *aliasPtr; /* Structure describing alias. */
|
Alias *aliasPtr; /* Structure describing alias. */
|
int i; /* Loop variable. */
|
int i; /* Loop variable. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
|
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
|
NULL);
|
NULL);
|
|
|
/*
|
/*
|
* The slave record should always be present because it is created
|
* The slave record should always be present because it is created
|
* by Tcl_CreateInterp.
|
* by Tcl_CreateInterp.
|
*/
|
*/
|
|
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
panic("DescribeAlias: could not find slave record");
|
panic("DescribeAlias: could not find slave record");
|
}
|
}
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_NewStringObj(aliasPtr->targetName, -1));
|
Tcl_NewStringObj(aliasPtr->targetName, -1));
|
for (i = 0; i < aliasPtr->objc; i++) {
|
for (i = 0; i < aliasPtr->objc; i++) {
|
Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]);
|
Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]);
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DeleteAlias --
|
* DeleteAlias --
|
*
|
*
|
* Deletes the given alias from the slave interpreter given.
|
* Deletes the given alias from the slave interpreter given.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deletes the alias from the slave interpreter.
|
* Deletes the alias from the slave interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
DeleteAlias(interp, slaveInterp, aliasName)
|
DeleteAlias(interp, slaveInterp, aliasName)
|
Tcl_Interp *interp; /* Interpreter for result and errors. */
|
Tcl_Interp *interp; /* Interpreter for result and errors. */
|
Tcl_Interp *slaveInterp; /* Interpreter defining alias. */
|
Tcl_Interp *slaveInterp; /* Interpreter defining alias. */
|
char *aliasName; /* Name of alias to delete. */
|
char *aliasName; /* Name of alias to delete. */
|
{
|
{
|
Slave *slavePtr; /* Slave record for slave interpreter. */
|
Slave *slavePtr; /* Slave record for slave interpreter. */
|
Alias *aliasPtr; /* Points at alias structure to delete. */
|
Alias *aliasPtr; /* Points at alias structure to delete. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
Tcl_HashEntry *hPtr; /* Search variable. */
|
char *tmpPtr, *namePtr; /* Local pointers to name of command to
|
char *tmpPtr, *namePtr; /* Local pointers to name of command to
|
* be deleted. */
|
* be deleted. */
|
|
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
|
NULL);
|
NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"alias \"", aliasName, "\" not found", (char *) NULL);
|
"alias \"", aliasName, "\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the alias from the alias table, then delete the command. The
|
* Get the alias from the alias table, then delete the command. The
|
* deleteProc on the alias command will take care of removing the entry
|
* deleteProc on the alias command will take care of removing the entry
|
* from the alias table.
|
* from the alias table.
|
*/
|
*/
|
|
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"alias \"", aliasName, "\" not found", (char *) NULL);
|
"alias \"", aliasName, "\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
|
|
/*
|
/*
|
* Get a copy of the real name of the command -- it might have
|
* Get a copy of the real name of the command -- it might have
|
* been renamed, and we want to delete the renamed command, not
|
* been renamed, and we want to delete the renamed command, not
|
* the current command (if any) by the name of the original alias.
|
* the current command (if any) by the name of the original alias.
|
* We need the local copy because the name may get smashed when the
|
* We need the local copy because the name may get smashed when the
|
* command to delete is exposed, if it was hidden.
|
* command to delete is exposed, if it was hidden.
|
*/
|
*/
|
|
|
tmpPtr = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd);
|
tmpPtr = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd);
|
namePtr = (char *) ckalloc((unsigned) strlen(tmpPtr) + 1);
|
namePtr = (char *) ckalloc((unsigned) strlen(tmpPtr) + 1);
|
strcpy(namePtr, tmpPtr);
|
strcpy(namePtr, tmpPtr);
|
|
|
/*
|
/*
|
* NOTE: The deleteProc for this command will delete the
|
* NOTE: The deleteProc for this command will delete the
|
* alias from the hash table. The deleteProc will also
|
* alias from the hash table. The deleteProc will also
|
* delete the target information from the master interpreter
|
* delete the target information from the master interpreter
|
* target table.
|
* target table.
|
*/
|
*/
|
|
|
if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) {
|
if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) {
|
if (Tcl_ExposeCommand(slaveInterp, namePtr, namePtr) != TCL_OK) {
|
if (Tcl_ExposeCommand(slaveInterp, namePtr, namePtr) != TCL_OK) {
|
panic("DeleteAlias: did not find alias to be deleted");
|
panic("DeleteAlias: did not find alias to be deleted");
|
}
|
}
|
if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) {
|
if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) {
|
panic("DeleteAlias: did not find alias to be deleted");
|
panic("DeleteAlias: did not find alias to be deleted");
|
}
|
}
|
}
|
}
|
ckfree(namePtr);
|
ckfree(namePtr);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetInterpPath --
|
* Tcl_GetInterpPath --
|
*
|
*
|
* Sets the result of the asking interpreter to a proper Tcl list
|
* Sets the result of the asking interpreter to a proper Tcl list
|
* containing the names of interpreters between the asking and
|
* containing the names of interpreters between the asking and
|
* target interpreters. The target interpreter must be either the
|
* target interpreters. The target interpreter must be either the
|
* same as the asking interpreter or one of its slaves (including
|
* same as the asking interpreter or one of its slaves (including
|
* recursively).
|
* recursively).
|
*
|
*
|
* Results:
|
* Results:
|
* TCL_OK if the target interpreter is the same as, or a descendant
|
* TCL_OK if the target interpreter is the same as, or a descendant
|
* of, the asking interpreter; TCL_ERROR else. This way one can
|
* of, the asking interpreter; TCL_ERROR else. This way one can
|
* distinguish between the case where the asking and target interps
|
* distinguish between the case where the asking and target interps
|
* are the same (an empty list is the result, and TCL_OK is returned)
|
* are the same (an empty list is the result, and TCL_OK is returned)
|
* and when the target is not a descendant of the asking interpreter
|
* and when the target is not a descendant of the asking interpreter
|
* (in which case the Tcl result is an error message and the function
|
* (in which case the Tcl result is an error message and the function
|
* returns TCL_ERROR).
|
* returns TCL_ERROR).
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetInterpPath(askingInterp, targetInterp)
|
Tcl_GetInterpPath(askingInterp, targetInterp)
|
Tcl_Interp *askingInterp; /* Interpreter to start search from. */
|
Tcl_Interp *askingInterp; /* Interpreter to start search from. */
|
Tcl_Interp *targetInterp; /* Interpreter to find. */
|
Tcl_Interp *targetInterp; /* Interpreter to find. */
|
{
|
{
|
Master *masterPtr; /* Interim storage for Master record. */
|
Master *masterPtr; /* Interim storage for Master record. */
|
Slave *slavePtr; /* Interim storage for Slave record. */
|
Slave *slavePtr; /* Interim storage for Slave record. */
|
|
|
if (targetInterp == askingInterp) {
|
if (targetInterp == askingInterp) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
if (targetInterp == (Tcl_Interp *) NULL) {
|
if (targetInterp == (Tcl_Interp *) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord",
|
slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord",
|
NULL);
|
NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) {
|
if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) {
|
|
|
/*
|
/*
|
* The result of askingInterp was set by recursive call.
|
* The result of askingInterp was set by recursive call.
|
*/
|
*/
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp,
|
masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp,
|
"tclMasterRecord", NULL);
|
"tclMasterRecord", NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("Tcl_GetInterpPath: could not find master record");
|
panic("Tcl_GetInterpPath: could not find master record");
|
}
|
}
|
Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable),
|
Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable),
|
slavePtr->slaveEntry));
|
slavePtr->slaveEntry));
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* GetTarget --
|
* GetTarget --
|
*
|
*
|
* Sets the result of the invoking interpreter to a path name for
|
* Sets the result of the invoking interpreter to a path name for
|
* the target interpreter of an alias in one of the slaves.
|
* the target interpreter of an alias in one of the slaves.
|
*
|
*
|
* Results:
|
* Results:
|
* TCL_OK if the target interpreter of the alias is a slave of the
|
* TCL_OK if the target interpreter of the alias is a slave of the
|
* invoking interpreter, TCL_ERROR else.
|
* invoking interpreter, TCL_ERROR else.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Sets the result of the invoking interpreter.
|
* Sets the result of the invoking interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
GetTarget(askingInterp, path, aliasName)
|
GetTarget(askingInterp, path, aliasName)
|
Tcl_Interp *askingInterp; /* Interpreter to start search from. */
|
Tcl_Interp *askingInterp; /* Interpreter to start search from. */
|
char *path; /* The path of the interp to find. */
|
char *path; /* The path of the interp to find. */
|
char *aliasName; /* The target of this allias. */
|
char *aliasName; /* The target of this allias. */
|
{
|
{
|
Tcl_Interp *slaveInterp; /* Interim storage for slave. */
|
Tcl_Interp *slaveInterp; /* Interim storage for slave. */
|
Slave *slaveSlavePtr; /* Its Slave record. */
|
Slave *slaveSlavePtr; /* Its Slave record. */
|
Master *masterPtr; /* Interim storage for Master record. */
|
Master *masterPtr; /* Interim storage for Master record. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Alias *aliasPtr; /* Data describing the alias. */
|
Alias *aliasPtr; /* Data describing the alias. */
|
|
|
Tcl_ResetResult(askingInterp);
|
Tcl_ResetResult(askingInterp);
|
masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord",
|
masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord",
|
NULL);
|
NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("GetTarget: could not find master record");
|
panic("GetTarget: could not find master record");
|
}
|
}
|
slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL);
|
slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL);
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
|
"could not find interpreter \"", path, "\"", (char *) NULL);
|
"could not find interpreter \"", path, "\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
|
slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
|
NULL);
|
NULL);
|
if (slaveSlavePtr == (Slave *) NULL) {
|
if (slaveSlavePtr == (Slave *) NULL) {
|
panic("GetTarget: could not find slave record");
|
panic("GetTarget: could not find slave record");
|
}
|
}
|
hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName);
|
hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
|
"alias \"", aliasName, "\" in path \"", path, "\" not found",
|
"alias \"", aliasName, "\" in path \"", path, "\" not found",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
if (aliasPtr == (Alias *) NULL) {
|
if (aliasPtr == (Alias *) NULL) {
|
panic("GetTarget: could not find alias record");
|
panic("GetTarget: could not find alias record");
|
}
|
}
|
|
|
if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) {
|
if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) {
|
Tcl_ResetResult(askingInterp);
|
Tcl_ResetResult(askingInterp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
|
"target interpreter for alias \"",
|
"target interpreter for alias \"",
|
aliasName, "\" in path \"", path, "\" is not my descendant",
|
aliasName, "\" in path \"", path, "\" is not my descendant",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_InterpCmd --
|
* Tcl_InterpCmd --
|
*
|
*
|
* This procedure is invoked to process the "interp" Tcl command.
|
* This procedure is invoked to process the "interp" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_InterpObjCmd(clientData, interp, objc, objv)
|
Tcl_InterpObjCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Unused. */
|
ClientData clientData; /* Unused. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Master *masterPtr; /* Master record for current interp. */
|
Master *masterPtr; /* Master record for current interp. */
|
int result; /* Local result variable. */
|
int result; /* Local result variable. */
|
|
|
/*
|
/*
|
* These are all the different subcommands for this command:
|
* These are all the different subcommands for this command:
|
*/
|
*/
|
|
|
static char *subCmds[] = {
|
static char *subCmds[] = {
|
"alias", "aliases", "create", "delete", "eval", "exists",
|
"alias", "aliases", "create", "delete", "eval", "exists",
|
"expose", "hide", "hidden", "issafe", "invokehidden",
|
"expose", "hide", "hidden", "issafe", "invokehidden",
|
"marktrusted", "slaves", "share", "target", "transfer",
|
"marktrusted", "slaves", "share", "target", "transfer",
|
(char *) NULL};
|
(char *) NULL};
|
enum ISubCmdIdx {
|
enum ISubCmdIdx {
|
IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx,
|
IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx,
|
IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx,
|
IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx,
|
IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx,
|
IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx,
|
ITargetIdx, ITransferIdx
|
ITargetIdx, ITransferIdx
|
} index;
|
} index;
|
|
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
|
masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("Tcl_InterpCmd: could not find master record");
|
panic("Tcl_InterpCmd: could not find master record");
|
}
|
}
|
|
|
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
|
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
|
0, (int *) &index);
|
0, (int *) &index);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
switch (index) {
|
switch (index) {
|
case IAliasIdx:
|
case IAliasIdx:
|
return InterpAliasHelper(interp, masterPtr, objc, objv);
|
return InterpAliasHelper(interp, masterPtr, objc, objv);
|
case IAliasesIdx:
|
case IAliasesIdx:
|
return InterpAliasesHelper(interp, masterPtr, objc, objv);
|
return InterpAliasesHelper(interp, masterPtr, objc, objv);
|
case ICreateIdx:
|
case ICreateIdx:
|
return CreateInterpObject(interp, masterPtr, objc, objv);
|
return CreateInterpObject(interp, masterPtr, objc, objv);
|
case IDeleteIdx:
|
case IDeleteIdx:
|
return DeleteInterpObject(interp, masterPtr, objc, objv);
|
return DeleteInterpObject(interp, masterPtr, objc, objv);
|
case IEvalIdx:
|
case IEvalIdx:
|
return InterpEvalHelper(interp, masterPtr, objc, objv);
|
return InterpEvalHelper(interp, masterPtr, objc, objv);
|
case IExistsIdx:
|
case IExistsIdx:
|
return InterpExistsHelper(interp, masterPtr, objc, objv);
|
return InterpExistsHelper(interp, masterPtr, objc, objv);
|
case IExposeIdx:
|
case IExposeIdx:
|
return InterpExposeHelper(interp, masterPtr, objc, objv);
|
return InterpExposeHelper(interp, masterPtr, objc, objv);
|
case IHideIdx:
|
case IHideIdx:
|
return InterpHideHelper(interp, masterPtr, objc, objv);
|
return InterpHideHelper(interp, masterPtr, objc, objv);
|
case IHiddenIdx:
|
case IHiddenIdx:
|
return InterpHiddenHelper(interp, masterPtr, objc, objv);
|
return InterpHiddenHelper(interp, masterPtr, objc, objv);
|
case IIsSafeIdx:
|
case IIsSafeIdx:
|
return InterpIsSafeHelper(interp, masterPtr, objc, objv);
|
return InterpIsSafeHelper(interp, masterPtr, objc, objv);
|
case IInvokeHiddenIdx:
|
case IInvokeHiddenIdx:
|
return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv);
|
return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv);
|
case IMarkTrustedIdx:
|
case IMarkTrustedIdx:
|
return InterpMarkTrustedHelper(interp, masterPtr, objc, objv);
|
return InterpMarkTrustedHelper(interp, masterPtr, objc, objv);
|
case ISlavesIdx:
|
case ISlavesIdx:
|
return InterpSlavesHelper(interp, masterPtr, objc, objv);
|
return InterpSlavesHelper(interp, masterPtr, objc, objv);
|
case IShareIdx:
|
case IShareIdx:
|
return InterpShareHelper(interp, masterPtr, objc, objv);
|
return InterpShareHelper(interp, masterPtr, objc, objv);
|
case ITargetIdx:
|
case ITargetIdx:
|
return InterpTargetHelper(interp, masterPtr, objc, objv);
|
return InterpTargetHelper(interp, masterPtr, objc, objv);
|
case ITransferIdx:
|
case ITransferIdx:
|
return InterpTransferHelper(interp, masterPtr, objc, objv);
|
return InterpTransferHelper(interp, masterPtr, objc, objv);
|
}
|
}
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveAliasHelper --
|
* SlaveAliasHelper --
|
*
|
*
|
* Helper function to construct or query an alias for a slave
|
* Helper function to construct or query an alias for a slave
|
* interpreter.
|
* interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Potentially creates a new alias.
|
* Potentially creates a new alias.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
Master *masterPtr;
|
Master *masterPtr;
|
int len;
|
int len;
|
|
|
switch (objc-2) {
|
switch (objc-2) {
|
case 0:
|
case 0:
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"aliasName ?targetName? ?args..?");
|
"aliasName ?targetName? ?args..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
|
|
case 1:
|
case 1:
|
|
|
/*
|
/*
|
* Return the name of the command in the current
|
* Return the name of the command in the current
|
* interpreter for which the argument is an alias in the
|
* interpreter for which the argument is an alias in the
|
* slave interpreter, and the list of saved arguments
|
* slave interpreter, and the list of saved arguments
|
*/
|
*/
|
|
|
return DescribeAlias(interp, slaveInterp,
|
return DescribeAlias(interp, slaveInterp,
|
Tcl_GetStringFromObj(objv[2], &len));
|
Tcl_GetStringFromObj(objv[2], &len));
|
|
|
default:
|
default:
|
masterPtr = (Master *) Tcl_GetAssocData(interp,
|
masterPtr = (Master *) Tcl_GetAssocData(interp,
|
"tclMasterRecord", NULL);
|
"tclMasterRecord", NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("SlaveObjectCmd: could not find master record");
|
panic("SlaveObjectCmd: could not find master record");
|
}
|
}
|
return AliasCreationHelper(interp, slaveInterp, interp,
|
return AliasCreationHelper(interp, slaveInterp, interp,
|
masterPtr,
|
masterPtr,
|
Tcl_GetStringFromObj(objv[2], &len),
|
Tcl_GetStringFromObj(objv[2], &len),
|
Tcl_GetStringFromObj(objv[3], &len),
|
Tcl_GetStringFromObj(objv[3], &len),
|
objc-4, objv+4);
|
objc-4, objv+4);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveAliasesHelper --
|
* SlaveAliasesHelper --
|
*
|
*
|
* Computes a list of aliases defined in a slave interpreter.
|
* Computes a list of aliases defined in a slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
Tcl_HashEntry *hPtr; /* For local searches. */
|
Tcl_HashEntry *hPtr; /* For local searches. */
|
Tcl_HashSearch hSearch; /* For local searches. */
|
Tcl_HashSearch hSearch; /* For local searches. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
Alias *aliasPtr; /* Alias information. */
|
Alias *aliasPtr; /* Alias information. */
|
|
|
/*
|
/*
|
* Return the names of all the aliases created in the
|
* Return the names of all the aliases created in the
|
* slave interpreter.
|
* slave interpreter.
|
*/
|
*/
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable),
|
for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable),
|
&hSearch);
|
&hSearch);
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_NewStringObj(aliasPtr->aliasName, -1));
|
Tcl_NewStringObj(aliasPtr->aliasName, -1));
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveEvalHelper --
|
* SlaveEvalHelper --
|
*
|
*
|
* Helper function to evaluate a command in a slave interpreter.
|
* Helper function to evaluate a command in a slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the command does.
|
* Whatever the command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
Interp *iPtr; /* Internal data type for slave. */
|
Interp *iPtr; /* Internal data type for slave. */
|
Tcl_Obj *objPtr; /* Local object pointer. */
|
Tcl_Obj *objPtr; /* Local object pointer. */
|
Tcl_Obj *namePtr; /* Local object pointer. */
|
Tcl_Obj *namePtr; /* Local object pointer. */
|
int len;
|
int len;
|
char *string;
|
char *string;
|
int result;
|
int result;
|
|
|
if (objc < 3) {
|
if (objc < 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
|
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
objPtr = Tcl_ConcatObj(objc-2, objv+2);
|
objPtr = Tcl_ConcatObj(objc-2, objv+2);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
|
|
Tcl_Preserve((ClientData) slaveInterp);
|
Tcl_Preserve((ClientData) slaveInterp);
|
result = Tcl_EvalObj(slaveInterp, objPtr);
|
result = Tcl_EvalObj(slaveInterp, objPtr);
|
|
|
Tcl_DecrRefCount(objPtr);
|
Tcl_DecrRefCount(objPtr);
|
|
|
/*
|
/*
|
* Make the result and any error information accessible. We have
|
* Make the result and any error information accessible. We have
|
* to be careful because the slave interpreter and the current
|
* to be careful because the slave interpreter and the current
|
* interpreter can be the same - do not destroy the result.. This
|
* interpreter can be the same - do not destroy the result.. This
|
* can happen if an interpreter contains an alias which is directed
|
* can happen if an interpreter contains an alias which is directed
|
* at a target command in the same interpreter.
|
* at a target command in the same interpreter.
|
*/
|
*/
|
|
|
if (interp != slaveInterp) {
|
if (interp != slaveInterp) {
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
|
|
/*
|
/*
|
* An error occurred, so transfer error information from the
|
* An error occurred, so transfer error information from the
|
* destination interpreter back to our interpreter.
|
* destination interpreter back to our interpreter.
|
*/
|
*/
|
|
|
iPtr = (Interp *) slaveInterp;
|
iPtr = (Interp *) slaveInterp;
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_AddErrorInfo(slaveInterp, "");
|
Tcl_AddErrorInfo(slaveInterp, "");
|
}
|
}
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
NULL, TCL_GLOBAL_ONLY),
|
NULL, TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Move the result object from one interpreter to the
|
* Move the result object from one interpreter to the
|
* other.
|
* other.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
}
|
}
|
Tcl_Release((ClientData) slaveInterp);
|
Tcl_Release((ClientData) slaveInterp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveExposeHelper --
|
* SlaveExposeHelper --
|
*
|
*
|
* Helper function to expose a command in a slave interpreter.
|
* Helper function to expose a command in a slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* After this call scripts in the slave will be able to invoke
|
* After this call scripts in the slave will be able to invoke
|
* the newly exposed command.
|
* the newly exposed command.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
int len;
|
int len;
|
|
|
if ((objc != 3) && (objc != 4)) {
|
if ((objc != 3) && (objc != 4)) {
|
Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
|
Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"permission denied: safe interpreter cannot expose commands",
|
"permission denied: safe interpreter cannot expose commands",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
|
if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
|
(objc == 4 ?
|
(objc == 4 ?
|
Tcl_GetStringFromObj(objv[3], &len) :
|
Tcl_GetStringFromObj(objv[3], &len) :
|
Tcl_GetStringFromObj(objv[2], &len)))
|
Tcl_GetStringFromObj(objv[2], &len)))
|
== TCL_ERROR) {
|
== TCL_ERROR) {
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveHideHelper --
|
* SlaveHideHelper --
|
*
|
*
|
* Helper function to hide a command in a slave interpreter.
|
* Helper function to hide a command in a slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* After this call scripts in the slave will no longer be able
|
* After this call scripts in the slave will no longer be able
|
* to invoke the named command.
|
* to invoke the named command.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
int len;
|
int len;
|
|
|
if ((objc != 3) && (objc != 4)) {
|
if ((objc != 3) && (objc != 4)) {
|
Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
|
Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"permission denied: safe interpreter cannot hide commands",
|
"permission denied: safe interpreter cannot hide commands",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
|
if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
|
(objc == 4 ?
|
(objc == 4 ?
|
Tcl_GetStringFromObj(objv[3], &len) :
|
Tcl_GetStringFromObj(objv[3], &len) :
|
Tcl_GetStringFromObj(objv[2], &len)))
|
Tcl_GetStringFromObj(objv[2], &len)))
|
== TCL_ERROR) {
|
== TCL_ERROR) {
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveHiddenHelper --
|
* SlaveHiddenHelper --
|
*
|
*
|
* Helper function to compute list of hidden commands in a slave
|
* Helper function to compute list of hidden commands in a slave
|
* interpreter.
|
* interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
Tcl_Obj *listObjPtr; /* Local object pointer. */
|
Tcl_HashTable *hTblPtr; /* For local searches. */
|
Tcl_HashTable *hTblPtr; /* For local searches. */
|
Tcl_HashEntry *hPtr; /* For local searches. */
|
Tcl_HashEntry *hPtr; /* For local searches. */
|
Tcl_HashSearch hSearch; /* For local searches. */
|
Tcl_HashSearch hSearch; /* For local searches. */
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
|
"tclHiddenCmds", NULL);
|
"tclHiddenCmds", NULL);
|
if (hTblPtr != (Tcl_HashTable *) NULL) {
|
if (hTblPtr != (Tcl_HashTable *) NULL) {
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
|
Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveIsSafeHelper --
|
* SlaveIsSafeHelper --
|
*
|
*
|
* Helper function to compute whether a slave interpreter is safe.
|
* Helper function to compute whether a slave interpreter is safe.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
Tcl_Obj *resultPtr; /* Local object pointer. */
|
Tcl_Obj *resultPtr; /* Local object pointer. */
|
|
|
if (objc > 2) {
|
if (objc > 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
|
resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
|
|
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveInvokeHiddenHelper --
|
* SlaveInvokeHiddenHelper --
|
*
|
*
|
* Helper function to invoke a hidden command in a slave interpreter.
|
* Helper function to invoke a hidden command in a slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the hidden command does.
|
* Whatever the hidden command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
Interp *iPtr;
|
Interp *iPtr;
|
Master *masterPtr;
|
Master *masterPtr;
|
int doGlobal = 0;
|
int doGlobal = 0;
|
int result;
|
int result;
|
int len;
|
int len;
|
char *string;
|
char *string;
|
Tcl_Obj *namePtr, *objPtr;
|
Tcl_Obj *namePtr, *objPtr;
|
|
|
if (objc < 3) {
|
if (objc < 3) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"?-global? cmd ?arg ..?");
|
"?-global? cmd ?arg ..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"not allowed to invoke hidden commands from safe interpreter",
|
"not allowed to invoke hidden commands from safe interpreter",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) {
|
if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) {
|
doGlobal = 1;
|
doGlobal = 1;
|
if (objc < 4) {
|
if (objc < 4) {
|
Tcl_WrongNumArgs(interp, 2, objv,
|
Tcl_WrongNumArgs(interp, 2, objv,
|
"path ?-global? cmd ?arg ..?");
|
"path ?-global? cmd ?arg ..?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(slaveInterp,
|
masterPtr = (Master *) Tcl_GetAssocData(slaveInterp,
|
"tclMasterRecord", NULL);
|
"tclMasterRecord", NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("SlaveObjectCmd: could not find master record");
|
panic("SlaveObjectCmd: could not find master record");
|
}
|
}
|
Tcl_Preserve((ClientData) slaveInterp);
|
Tcl_Preserve((ClientData) slaveInterp);
|
if (doGlobal) {
|
if (doGlobal) {
|
result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3,
|
result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3,
|
TCL_INVOKE_HIDDEN);
|
TCL_INVOKE_HIDDEN);
|
} else {
|
} else {
|
result = TclObjInvoke(slaveInterp, objc-2, objv+2,
|
result = TclObjInvoke(slaveInterp, objc-2, objv+2,
|
TCL_INVOKE_HIDDEN);
|
TCL_INVOKE_HIDDEN);
|
}
|
}
|
|
|
/*
|
/*
|
* Now make the result and any error information accessible. We
|
* Now make the result and any error information accessible. We
|
* have to be careful because the slave interpreter and the current
|
* have to be careful because the slave interpreter and the current
|
* interpreter can be the same - do not destroy the result.. This
|
* interpreter can be the same - do not destroy the result.. This
|
* can happen if an interpreter contains an alias which is directed
|
* can happen if an interpreter contains an alias which is directed
|
* at a target command in the same interpreter.
|
* at a target command in the same interpreter.
|
*/
|
*/
|
|
|
if (interp != slaveInterp) {
|
if (interp != slaveInterp) {
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
|
|
/*
|
/*
|
* An error occurred, so transfer error information from
|
* An error occurred, so transfer error information from
|
* the target interpreter back to our interpreter.
|
* the target interpreter back to our interpreter.
|
*/
|
*/
|
|
|
iPtr = (Interp *) slaveInterp;
|
iPtr = (Interp *) slaveInterp;
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_AddErrorInfo(slaveInterp, "");
|
Tcl_AddErrorInfo(slaveInterp, "");
|
}
|
}
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
Tcl_GetVar2(slaveInterp, "errorCode", (char *)
|
NULL, TCL_GLOBAL_ONLY),
|
NULL, TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Move the result object from the slave to the master.
|
* Move the result object from the slave to the master.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
|
Tcl_ResetResult(slaveInterp);
|
Tcl_ResetResult(slaveInterp);
|
}
|
}
|
Tcl_Release((ClientData) slaveInterp);
|
Tcl_Release((ClientData) slaveInterp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveMarkTrustedHelper --
|
* SlaveMarkTrustedHelper --
|
*
|
*
|
* Helper function to mark a slave interpreter as trusted (unsafe).
|
* Helper function to mark a slave interpreter as trusted (unsafe).
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* After this call the hard-wired security checks in the core no
|
* After this call the hard-wired security checks in the core no
|
* longer prevent the slave from performing certain operations.
|
* longer prevent the slave from performing certain operations.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv)
|
SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Tcl_Interp *slaveInterp; /* The slave interpreter. */
|
Slave *slavePtr; /* Its slave record. */
|
Slave *slavePtr; /* Its slave record. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
|
{
|
{
|
int len;
|
int len;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"",
|
"\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"",
|
" can only be invoked from a trusted interpreter",
|
" can only be invoked from a trusted interpreter",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return MarkTrusted(slaveInterp);
|
return MarkTrusted(slaveInterp);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveObjectCmd --
|
* SlaveObjectCmd --
|
*
|
*
|
* Command to manipulate an interpreter, e.g. to send commands to it
|
* Command to manipulate an interpreter, e.g. to send commands to it
|
* to be evaluated. One such command exists for each slave interpreter.
|
* to be evaluated. One such command exists for each slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See user documentation for details.
|
* See user documentation for details.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SlaveObjectCmd(clientData, interp, objc, objv)
|
SlaveObjectCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Slave interpreter. */
|
ClientData clientData; /* Slave interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* The argument vector. */
|
Tcl_Obj *CONST objv[]; /* The argument vector. */
|
{
|
{
|
Slave *slavePtr; /* Slave record. */
|
Slave *slavePtr; /* Slave record. */
|
Tcl_Interp *slaveInterp; /* Slave interpreter. */
|
Tcl_Interp *slaveInterp; /* Slave interpreter. */
|
int result; /* Loop counter, status return. */
|
int result; /* Loop counter, status return. */
|
int len; /* Length of command name. */
|
int len; /* Length of command name. */
|
|
|
/*
|
/*
|
* These are all the different subcommands for this command:
|
* These are all the different subcommands for this command:
|
*/
|
*/
|
|
|
static char *subCmds[] = {
|
static char *subCmds[] = {
|
"alias", "aliases",
|
"alias", "aliases",
|
"eval", "expose",
|
"eval", "expose",
|
"hide", "hidden",
|
"hide", "hidden",
|
"issafe", "invokehidden",
|
"issafe", "invokehidden",
|
"marktrusted",
|
"marktrusted",
|
(char *) NULL};
|
(char *) NULL};
|
enum ISubCmdIdx {
|
enum ISubCmdIdx {
|
IAliasIdx, IAliasesIdx,
|
IAliasIdx, IAliasesIdx,
|
IEvalIdx, IExposeIdx,
|
IEvalIdx, IExposeIdx,
|
IHideIdx, IHiddenIdx,
|
IHideIdx, IHiddenIdx,
|
IIsSafeIdx, IInvokeHiddenIdx,
|
IIsSafeIdx, IInvokeHiddenIdx,
|
IMarkTrustedIdx
|
IMarkTrustedIdx
|
} index;
|
} index;
|
|
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
slaveInterp = (Tcl_Interp *) clientData;
|
slaveInterp = (Tcl_Interp *) clientData;
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
if (slaveInterp == (Tcl_Interp *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"interpreter ", Tcl_GetStringFromObj(objv[0], &len),
|
"interpreter ", Tcl_GetStringFromObj(objv[0], &len),
|
" has been deleted", (char *) NULL);
|
" has been deleted", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
|
"tclSlaveRecord", NULL);
|
"tclSlaveRecord", NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
panic("SlaveObjectCmd: could not find slave record");
|
panic("SlaveObjectCmd: could not find slave record");
|
}
|
}
|
|
|
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
|
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
|
0, (int *) &index);
|
0, (int *) &index);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
switch (index) {
|
switch (index) {
|
case IAliasIdx:
|
case IAliasIdx:
|
return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv);
|
return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv);
|
case IAliasesIdx:
|
case IAliasesIdx:
|
return SlaveAliasesHelper(interp, slaveInterp, slavePtr,
|
return SlaveAliasesHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
case IEvalIdx:
|
case IEvalIdx:
|
return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv);
|
return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv);
|
case IExposeIdx:
|
case IExposeIdx:
|
return SlaveExposeHelper(interp, slaveInterp, slavePtr,
|
return SlaveExposeHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
case IHideIdx:
|
case IHideIdx:
|
return SlaveHideHelper(interp, slaveInterp, slavePtr,
|
return SlaveHideHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
case IHiddenIdx:
|
case IHiddenIdx:
|
return SlaveHiddenHelper(interp, slaveInterp, slavePtr,
|
return SlaveHiddenHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
case IIsSafeIdx:
|
case IIsSafeIdx:
|
return SlaveIsSafeHelper(interp, slaveInterp, slavePtr,
|
return SlaveIsSafeHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
case IInvokeHiddenIdx:
|
case IInvokeHiddenIdx:
|
return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr,
|
return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
case IMarkTrustedIdx:
|
case IMarkTrustedIdx:
|
return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr,
|
return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr,
|
objc, objv);
|
objc, objv);
|
}
|
}
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveObjectDeleteProc --
|
* SlaveObjectDeleteProc --
|
*
|
*
|
* Invoked when an object command for a slave interpreter is deleted;
|
* Invoked when an object command for a slave interpreter is deleted;
|
* cleans up all state associated with the slave interpreter and destroys
|
* cleans up all state associated with the slave interpreter and destroys
|
* the slave interpreter.
|
* the slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Cleans up all state associated with the slave interpreter and
|
* Cleans up all state associated with the slave interpreter and
|
* destroys the slave interpreter.
|
* destroys the slave interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
SlaveObjectDeleteProc(clientData)
|
SlaveObjectDeleteProc(clientData)
|
ClientData clientData; /* The SlaveRecord for the command. */
|
ClientData clientData; /* The SlaveRecord for the command. */
|
{
|
{
|
Slave *slavePtr; /* Interim storage for Slave record. */
|
Slave *slavePtr; /* Interim storage for Slave record. */
|
Tcl_Interp *slaveInterp; /* And for a slave interp. */
|
Tcl_Interp *slaveInterp; /* And for a slave interp. */
|
|
|
slaveInterp = (Tcl_Interp *) clientData;
|
slaveInterp = (Tcl_Interp *) clientData;
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL);
|
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
panic("SlaveObjectDeleteProc: could not find slave record");
|
panic("SlaveObjectDeleteProc: could not find slave record");
|
}
|
}
|
|
|
/*
|
/*
|
* Delete the entry in the slave table in the master interpreter now.
|
* 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
|
* 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
|
* 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 the master is being deleted and the slave deletion is deferred
|
* because it is still active.
|
* because it is still active.
|
*/
|
*/
|
|
|
Tcl_DeleteHashEntry(slavePtr->slaveEntry);
|
Tcl_DeleteHashEntry(slavePtr->slaveEntry);
|
|
|
/*
|
/*
|
* Set to NULL so that when the slave record is cleaned up in the slave
|
* 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.
|
* it does not try to delete the command causing all sorts of grief.
|
* See SlaveRecordDeleteProc().
|
* See SlaveRecordDeleteProc().
|
*/
|
*/
|
|
|
slavePtr->interpCmd = NULL;
|
slavePtr->interpCmd = NULL;
|
|
|
/*
|
/*
|
* Destroy the interpreter - this will cause all the deleteProcs for
|
* Destroy the interpreter - this will cause all the deleteProcs for
|
* all commands (including aliases) to run.
|
* all commands (including aliases) to run.
|
*
|
*
|
* NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!!
|
* NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!!
|
*/
|
*/
|
|
|
Tcl_DeleteInterp(slavePtr->slaveInterp);
|
Tcl_DeleteInterp(slavePtr->slaveInterp);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* AliasCmd --
|
* AliasCmd --
|
*
|
*
|
* This is the procedure that services invocations of aliases in a
|
* This is the procedure that services invocations of aliases in a
|
* slave interpreter. One such command exists for each alias. When
|
* slave interpreter. One such command exists for each alias. When
|
* invoked, this procedure redirects the invocation to the target
|
* invoked, this procedure redirects the invocation to the target
|
* command in the master interpreter as designated by the Alias
|
* command in the master interpreter as designated by the Alias
|
* record associated with this command.
|
* record associated with this command.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Causes forwarding of the invocation; all possible side effects
|
* Causes forwarding of the invocation; all possible side effects
|
* may occur as a result of invoking the command to which the
|
* may occur as a result of invoking the command to which the
|
* invocation is forwarded.
|
* invocation is forwarded.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
AliasCmd(clientData, interp, objc, objv)
|
AliasCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Alias record. */
|
ClientData clientData; /* Alias record. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument vector. */
|
Tcl_Obj *CONST objv[]; /* Argument vector. */
|
{
|
{
|
Tcl_Interp *targetInterp; /* Target for alias exec. */
|
Tcl_Interp *targetInterp; /* Target for alias exec. */
|
Interp *iPtr; /* Internal type of target. */
|
Interp *iPtr; /* Internal type of target. */
|
Alias *aliasPtr; /* Describes the alias. */
|
Alias *aliasPtr; /* Describes the alias. */
|
Tcl_Command cmd; /* The target command. */
|
Tcl_Command cmd; /* The target command. */
|
Command *cmdPtr; /* Points to target command. */
|
Command *cmdPtr; /* Points to target command. */
|
Tcl_Namespace *targetNsPtr; /* Target command's namespace. */
|
Tcl_Namespace *targetNsPtr; /* Target command's namespace. */
|
int result; /* Result of execution. */
|
int result; /* Result of execution. */
|
int i, j, addObjc; /* Loop counters. */
|
int i, j, addObjc; /* Loop counters. */
|
int localObjc; /* Local argument count. */
|
int localObjc; /* Local argument count. */
|
Tcl_Obj **localObjv; /* Local argument vector. */
|
Tcl_Obj **localObjv; /* Local argument vector. */
|
Tcl_Obj *namePtr, *objPtr; /* Local object pointers. */
|
Tcl_Obj *namePtr, *objPtr; /* Local object pointers. */
|
char *string; /* Local object string rep. */
|
char *string; /* Local object string rep. */
|
int len; /* Dummy length arg. */
|
int len; /* Dummy length arg. */
|
|
|
aliasPtr = (Alias *) clientData;
|
aliasPtr = (Alias *) clientData;
|
targetInterp = aliasPtr->targetInterp;
|
targetInterp = aliasPtr->targetInterp;
|
|
|
/*
|
/*
|
* Look for the target command in the global namespace of the target
|
* Look for the target command in the global namespace of the target
|
* interpreter.
|
* interpreter.
|
*/
|
*/
|
|
|
cmdPtr = NULL;
|
cmdPtr = NULL;
|
targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp);
|
targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp);
|
cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName,
|
cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName,
|
targetNsPtr, /*flags*/ 0);
|
targetNsPtr, /*flags*/ 0);
|
if (cmd != (Tcl_Command) NULL) {
|
if (cmd != (Tcl_Command) NULL) {
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
}
|
}
|
|
|
iPtr = (Interp *) targetInterp;
|
iPtr = (Interp *) targetInterp;
|
|
|
/*
|
/*
|
* If the command does not exist, invoke "unknown" in the master.
|
* If the command does not exist, invoke "unknown" in the master.
|
*/
|
*/
|
|
|
if (cmdPtr == NULL) {
|
if (cmdPtr == NULL) {
|
addObjc = aliasPtr->objc;
|
addObjc = aliasPtr->objc;
|
localObjc = addObjc + objc + 1;
|
localObjc = addObjc + objc + 1;
|
localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *)
|
localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *)
|
* localObjc);
|
* localObjc);
|
|
|
localObjv[0] = Tcl_NewStringObj("unknown", -1);
|
localObjv[0] = Tcl_NewStringObj("unknown", -1);
|
localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1);
|
localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1);
|
Tcl_IncrRefCount(localObjv[0]);
|
Tcl_IncrRefCount(localObjv[0]);
|
Tcl_IncrRefCount(localObjv[1]);
|
Tcl_IncrRefCount(localObjv[1]);
|
|
|
for (i = 0, j = 2; i < addObjc; i++, j++) {
|
for (i = 0, j = 2; i < addObjc; i++, j++) {
|
localObjv[j] = aliasPtr->objv[i];
|
localObjv[j] = aliasPtr->objv[i];
|
}
|
}
|
for (i = 1; i < objc; i++, j++) {
|
for (i = 1; i < objc; i++, j++) {
|
localObjv[j] = objv[i];
|
localObjv[j] = objv[i];
|
}
|
}
|
Tcl_Preserve((ClientData) targetInterp);
|
Tcl_Preserve((ClientData) targetInterp);
|
result = TclObjInvoke(targetInterp, localObjc, localObjv, 0);
|
result = TclObjInvoke(targetInterp, localObjc, localObjv, 0);
|
|
|
Tcl_DecrRefCount(localObjv[0]);
|
Tcl_DecrRefCount(localObjv[0]);
|
Tcl_DecrRefCount(localObjv[1]);
|
Tcl_DecrRefCount(localObjv[1]);
|
|
|
ckfree((char *) localObjv);
|
ckfree((char *) localObjv);
|
|
|
if (targetInterp != interp) {
|
if (targetInterp != interp) {
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
|
|
/*
|
/*
|
* An error occurred, so transfer error information from
|
* An error occurred, so transfer error information from
|
* the target interpreter back to our interpreter.
|
* the target interpreter back to our interpreter.
|
*/
|
*/
|
|
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_AddErrorInfo((Tcl_Interp *) iPtr, "");
|
Tcl_AddErrorInfo((Tcl_Interp *) iPtr, "");
|
}
|
}
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
objPtr = Tcl_ObjGetVar2(targetInterp, namePtr,
|
objPtr = Tcl_ObjGetVar2(targetInterp, namePtr,
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
(Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(targetInterp, "errorCode", (char *)
|
Tcl_GetVar2(targetInterp, "errorCode", (char *)
|
NULL, TCL_GLOBAL_ONLY),
|
NULL, TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Transfer the result from the target interpreter to the
|
* Transfer the result from the target interpreter to the
|
* calling interpreter.
|
* calling interpreter.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
|
Tcl_ResetResult(targetInterp);
|
Tcl_ResetResult(targetInterp);
|
}
|
}
|
|
|
Tcl_Release((ClientData) targetInterp);
|
Tcl_Release((ClientData) targetInterp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise invoke the regular target command.
|
* Otherwise invoke the regular target command.
|
*/
|
*/
|
|
|
if (aliasPtr->objc <= 0) {
|
if (aliasPtr->objc <= 0) {
|
localObjv = (Tcl_Obj **) objv;
|
localObjv = (Tcl_Obj **) objv;
|
localObjc = objc;
|
localObjc = objc;
|
} else {
|
} else {
|
addObjc = aliasPtr->objc;
|
addObjc = aliasPtr->objc;
|
localObjc = objc + addObjc;
|
localObjc = objc + addObjc;
|
localObjv =
|
localObjv =
|
(Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc);
|
(Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc);
|
localObjv[0] = objv[0];
|
localObjv[0] = objv[0];
|
for (i = 0, j = 1; i < addObjc; i++, j++) {
|
for (i = 0, j = 1; i < addObjc; i++, j++) {
|
localObjv[j] = aliasPtr->objv[i];
|
localObjv[j] = aliasPtr->objv[i];
|
}
|
}
|
for (i = 1; i < objc; i++, j++) {
|
for (i = 1; i < objc; i++, j++) {
|
localObjv[j] = objv[i];
|
localObjv[j] = objv[i];
|
}
|
}
|
}
|
}
|
|
|
iPtr->numLevels++;
|
iPtr->numLevels++;
|
Tcl_Preserve((ClientData) targetInterp);
|
Tcl_Preserve((ClientData) targetInterp);
|
|
|
/*
|
/*
|
* Reset the interpreter to its clean state; we do not know what state
|
* Reset the interpreter to its clean state; we do not know what state
|
* it is in now..
|
* it is in now..
|
*/
|
*/
|
|
|
Tcl_ResetResult(targetInterp);
|
Tcl_ResetResult(targetInterp);
|
result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp,
|
result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp,
|
localObjc, localObjv);
|
localObjc, localObjv);
|
|
|
iPtr->numLevels--;
|
iPtr->numLevels--;
|
|
|
/*
|
/*
|
* Check if we are at the bottom of the stack for the target interpreter.
|
* Check if we are at the bottom of the stack for the target interpreter.
|
* If so, check for special return codes.
|
* If so, check for special return codes.
|
*/
|
*/
|
|
|
if (iPtr->numLevels == 0) {
|
if (iPtr->numLevels == 0) {
|
if (result == TCL_RETURN) {
|
if (result == TCL_RETURN) {
|
result = TclUpdateReturnInfo(iPtr);
|
result = TclUpdateReturnInfo(iPtr);
|
}
|
}
|
if ((result != TCL_OK) && (result != TCL_ERROR)) {
|
if ((result != TCL_OK) && (result != TCL_ERROR)) {
|
Tcl_ResetResult(targetInterp);
|
Tcl_ResetResult(targetInterp);
|
if (result == TCL_BREAK) {
|
if (result == TCL_BREAK) {
|
Tcl_SetObjResult(targetInterp,
|
Tcl_SetObjResult(targetInterp,
|
Tcl_NewStringObj("invoked \"break\" outside of a loop",
|
Tcl_NewStringObj("invoked \"break\" outside of a loop",
|
-1));
|
-1));
|
} else if (result == TCL_CONTINUE) {
|
} else if (result == TCL_CONTINUE) {
|
Tcl_SetObjResult(targetInterp,
|
Tcl_SetObjResult(targetInterp,
|
Tcl_NewStringObj(
|
Tcl_NewStringObj(
|
"invoked \"continue\" outside of a loop",
|
"invoked \"continue\" outside of a loop",
|
-1));
|
-1));
|
} else {
|
} else {
|
char buf[128];
|
char buf[128];
|
|
|
sprintf(buf, "command returned bad code: %d", result);
|
sprintf(buf, "command returned bad code: %d", result);
|
Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
|
Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
|
}
|
}
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Clean up any locally allocated argument vector structure.
|
* Clean up any locally allocated argument vector structure.
|
*/
|
*/
|
|
|
if (localObjv != objv) {
|
if (localObjv != objv) {
|
ckfree((char *) localObjv);
|
ckfree((char *) localObjv);
|
}
|
}
|
|
|
/*
|
/*
|
* Move the result from the target interpreter to the invoking
|
* Move the result from the target interpreter to the invoking
|
* interpreter if they are different.
|
* interpreter if they are different.
|
*
|
*
|
* Note: We cannot use aliasPtr any more because the alias may have
|
* Note: We cannot use aliasPtr any more because the alias may have
|
* been deleted.
|
* been deleted.
|
*/
|
*/
|
|
|
if (interp != targetInterp) {
|
if (interp != targetInterp) {
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
|
|
/*
|
/*
|
* An error occurred, so transfer the error information from
|
* An error occurred, so transfer the error information from
|
* the target interpreter back to our interpreter.
|
* the target interpreter back to our interpreter.
|
*/
|
*/
|
|
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_AddErrorInfo(targetInterp, "");
|
Tcl_AddErrorInfo(targetInterp, "");
|
}
|
}
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
iPtr->flags &= (~(ERR_ALREADY_LOGGED));
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL,
|
objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL,
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
string = Tcl_GetStringFromObj(objPtr, &len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_AddObjErrorInfo(interp, string, len);
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL,
|
Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL,
|
TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY),
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Move the result object from one interpreter to the
|
* Move the result object from one interpreter to the
|
* other.
|
* other.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
|
Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
|
Tcl_ResetResult(targetInterp);
|
Tcl_ResetResult(targetInterp);
|
}
|
}
|
Tcl_Release((ClientData) targetInterp);
|
Tcl_Release((ClientData) targetInterp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* AliasCmdDeleteProc --
|
* AliasCmdDeleteProc --
|
*
|
*
|
* Is invoked when an alias command is deleted in a slave. Cleans up
|
* Is invoked when an alias command is deleted in a slave. Cleans up
|
* all storage associated with this alias.
|
* all storage associated with this alias.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deletes the alias record and its entry in the alias table for
|
* Deletes the alias record and its entry in the alias table for
|
* the interpreter.
|
* the interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
AliasCmdDeleteProc(clientData)
|
AliasCmdDeleteProc(clientData)
|
ClientData clientData; /* The alias record for this alias. */
|
ClientData clientData; /* The alias record for this alias. */
|
{
|
{
|
Alias *aliasPtr; /* Alias record for alias to delete. */
|
Alias *aliasPtr; /* Alias record for alias to delete. */
|
Target *targetPtr; /* Record for target of this alias. */
|
Target *targetPtr; /* Record for target of this alias. */
|
int i; /* Loop counter. */
|
int i; /* Loop counter. */
|
|
|
aliasPtr = (Alias *) clientData;
|
aliasPtr = (Alias *) clientData;
|
|
|
targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry);
|
targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry);
|
ckfree((char *) targetPtr);
|
ckfree((char *) targetPtr);
|
Tcl_DeleteHashEntry(aliasPtr->targetEntry);
|
Tcl_DeleteHashEntry(aliasPtr->targetEntry);
|
|
|
ckfree((char *) aliasPtr->targetName);
|
ckfree((char *) aliasPtr->targetName);
|
ckfree((char *) aliasPtr->aliasName);
|
ckfree((char *) aliasPtr->aliasName);
|
for (i = 0; i < aliasPtr->objc; i++) {
|
for (i = 0; i < aliasPtr->objc; i++) {
|
Tcl_DecrRefCount(aliasPtr->objv[i]);
|
Tcl_DecrRefCount(aliasPtr->objv[i]);
|
}
|
}
|
if (aliasPtr->objv != (Tcl_Obj **) NULL) {
|
if (aliasPtr->objv != (Tcl_Obj **) NULL) {
|
ckfree((char *) aliasPtr->objv);
|
ckfree((char *) aliasPtr->objv);
|
}
|
}
|
|
|
Tcl_DeleteHashEntry(aliasPtr->aliasEntry);
|
Tcl_DeleteHashEntry(aliasPtr->aliasEntry);
|
|
|
ckfree((char *) aliasPtr);
|
ckfree((char *) aliasPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* MasterRecordDeleteProc -
|
* MasterRecordDeleteProc -
|
*
|
*
|
* Is invoked when an interpreter (which is using the "interp" facility)
|
* Is invoked when an interpreter (which is using the "interp" facility)
|
* is deleted, and it cleans up the storage associated with the
|
* is deleted, and it cleans up the storage associated with the
|
* "tclMasterRecord" assoc-data entry.
|
* "tclMasterRecord" assoc-data entry.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Cleans up storage.
|
* Cleans up storage.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
MasterRecordDeleteProc(clientData, interp)
|
MasterRecordDeleteProc(clientData, interp)
|
ClientData clientData; /* Master record for deleted interp. */
|
ClientData clientData; /* Master record for deleted interp. */
|
Tcl_Interp *interp; /* Interpreter being deleted. */
|
Tcl_Interp *interp; /* Interpreter being deleted. */
|
{
|
{
|
Target *targetPtr; /* Loop variable. */
|
Target *targetPtr; /* Loop variable. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashSearch hSearch; /* Search record (internal). */
|
Tcl_HashSearch hSearch; /* Search record (internal). */
|
Slave *slavePtr; /* Loop variable. */
|
Slave *slavePtr; /* Loop variable. */
|
Master *masterPtr; /* Interim storage. */
|
Master *masterPtr; /* Interim storage. */
|
|
|
masterPtr = (Master *) clientData;
|
masterPtr = (Master *) clientData;
|
for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
|
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
|
(void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd);
|
(void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd);
|
}
|
}
|
Tcl_DeleteHashTable(&(masterPtr->slaveTable));
|
Tcl_DeleteHashTable(&(masterPtr->slaveTable));
|
|
|
for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) {
|
hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) {
|
targetPtr = (Target *) Tcl_GetHashValue(hPtr);
|
targetPtr = (Target *) Tcl_GetHashValue(hPtr);
|
(void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
|
(void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
|
targetPtr->slaveCmd);
|
targetPtr->slaveCmd);
|
}
|
}
|
Tcl_DeleteHashTable(&(masterPtr->targetTable));
|
Tcl_DeleteHashTable(&(masterPtr->targetTable));
|
|
|
ckfree((char *) masterPtr);
|
ckfree((char *) masterPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SlaveRecordDeleteProc --
|
* SlaveRecordDeleteProc --
|
*
|
*
|
* Is invoked when an interpreter (which is using the interp facility)
|
* Is invoked when an interpreter (which is using the interp facility)
|
* is deleted, and it cleans up the storage associated with the
|
* is deleted, and it cleans up the storage associated with the
|
* tclSlaveRecord assoc-data entry.
|
* tclSlaveRecord assoc-data entry.
|
*
|
*
|
* Results:
|
* Results:
|
* None
|
* None
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Cleans up storage.
|
* Cleans up storage.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
SlaveRecordDeleteProc(clientData, interp)
|
SlaveRecordDeleteProc(clientData, interp)
|
ClientData clientData; /* Slave record for deleted interp. */
|
ClientData clientData; /* Slave record for deleted interp. */
|
Tcl_Interp *interp; /* Interpreter being deleted. */
|
Tcl_Interp *interp; /* Interpreter being deleted. */
|
{
|
{
|
Slave *slavePtr; /* Interim storage. */
|
Slave *slavePtr; /* Interim storage. */
|
Alias *aliasPtr;
|
Alias *aliasPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashSearch hSearch;
|
Tcl_HashSearch hSearch;
|
|
|
slavePtr = (Slave *) clientData;
|
slavePtr = (Slave *) clientData;
|
|
|
/*
|
/*
|
* In every case that we call SetAssocData on "tclSlaveRecord",
|
* In every case that we call SetAssocData on "tclSlaveRecord",
|
* slavePtr is not NULL. Otherwise we panic.
|
* slavePtr is not NULL. Otherwise we panic.
|
*/
|
*/
|
|
|
if (slavePtr == NULL) {
|
if (slavePtr == NULL) {
|
panic("SlaveRecordDeleteProc: NULL slavePtr");
|
panic("SlaveRecordDeleteProc: NULL slavePtr");
|
}
|
}
|
|
|
if (slavePtr->interpCmd != (Tcl_Command) NULL) {
|
if (slavePtr->interpCmd != (Tcl_Command) NULL) {
|
Command *cmdPtr = (Command *) slavePtr->interpCmd;
|
Command *cmdPtr = (Command *) slavePtr->interpCmd;
|
|
|
/*
|
/*
|
* The interpCmd has not been deleted in the master yet, since
|
* The interpCmd has not been deleted in the master yet, since
|
* it's callback sets interpCmd to NULL.
|
* it's callback sets interpCmd to NULL.
|
*
|
*
|
* Probably Tcl_DeleteInterp() was called on this interpreter directly,
|
* Probably Tcl_DeleteInterp() was called on this interpreter directly,
|
* rather than via "interp delete", or equivalent (deletion of the
|
* rather than via "interp delete", or equivalent (deletion of the
|
* command in the master).
|
* command in the master).
|
*
|
*
|
* Perform the cleanup done by SlaveObjectDeleteProc() directly,
|
* Perform the cleanup done by SlaveObjectDeleteProc() directly,
|
* and turn off the callback now (since we are about to free slavePtr
|
* and turn off the callback now (since we are about to free slavePtr
|
* and this interpreter is going away, while the deletion of commands
|
* and this interpreter is going away, while the deletion of commands
|
* in the master may be deferred).
|
* in the master may be deferred).
|
*/
|
*/
|
|
|
Tcl_DeleteHashEntry(slavePtr->slaveEntry);
|
Tcl_DeleteHashEntry(slavePtr->slaveEntry);
|
cmdPtr->clientData = NULL;
|
cmdPtr->clientData = NULL;
|
cmdPtr->deleteProc = NULL;
|
cmdPtr->deleteProc = NULL;
|
cmdPtr->deleteData = NULL;
|
cmdPtr->deleteData = NULL;
|
|
|
Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
|
Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
|
slavePtr->interpCmd);
|
slavePtr->interpCmd);
|
}
|
}
|
|
|
/*
|
/*
|
* If there are any aliases, delete those now. This removes any
|
* If there are any aliases, delete those now. This removes any
|
* dependency on the order of deletion between commands and the
|
* dependency on the order of deletion between commands and the
|
* slave record.
|
* slave record.
|
*/
|
*/
|
|
|
hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable);
|
hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable);
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
|
hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
|
|
/*
|
/*
|
* The call to Tcl_DeleteCommand will release the storage
|
* The call to Tcl_DeleteCommand will release the storage
|
* occupied by the hash entry and the alias record.
|
* occupied by the hash entry and the alias record.
|
*/
|
*/
|
|
|
Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd);
|
Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd);
|
}
|
}
|
|
|
/*
|
/*
|
* Finally dispose of the hash table and the slave record.
|
* Finally dispose of the hash table and the slave record.
|
*/
|
*/
|
|
|
Tcl_DeleteHashTable(hTblPtr);
|
Tcl_DeleteHashTable(hTblPtr);
|
ckfree((char *) slavePtr);
|
ckfree((char *) slavePtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclInterpInit --
|
* TclInterpInit --
|
*
|
*
|
* Initializes the invoking interpreter for using the "interp"
|
* Initializes the invoking interpreter for using the "interp"
|
* facility. This is called from inside Tcl_Init.
|
* facility. This is called from inside Tcl_Init.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Adds the "interp" command to an interpreter and initializes several
|
* Adds the "interp" command to an interpreter and initializes several
|
* records in the associated data of the invoking interpreter.
|
* records in the associated data of the invoking interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclInterpInit(interp)
|
TclInterpInit(interp)
|
Tcl_Interp *interp; /* Interpreter to initialize. */
|
Tcl_Interp *interp; /* Interpreter to initialize. */
|
{
|
{
|
Master *masterPtr; /* Its Master record. */
|
Master *masterPtr; /* Its Master record. */
|
Slave *slavePtr; /* And its slave record. */
|
Slave *slavePtr; /* And its slave record. */
|
|
|
masterPtr = (Master *) ckalloc((unsigned) sizeof(Master));
|
masterPtr = (Master *) ckalloc((unsigned) sizeof(Master));
|
|
|
Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS);
|
Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS);
|
Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS);
|
Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS);
|
|
|
(void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc,
|
(void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc,
|
(ClientData) masterPtr);
|
(ClientData) masterPtr);
|
|
|
slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
|
slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
|
|
|
slavePtr->masterInterp = (Tcl_Interp *) NULL;
|
slavePtr->masterInterp = (Tcl_Interp *) NULL;
|
slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
|
slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
|
slavePtr->slaveInterp = interp;
|
slavePtr->slaveInterp = interp;
|
slavePtr->interpCmd = (Tcl_Command) NULL;
|
slavePtr->interpCmd = (Tcl_Command) NULL;
|
Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
|
Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
|
|
|
(void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc,
|
(void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc,
|
(ClientData) slavePtr);
|
(ClientData) slavePtr);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_IsSafe --
|
* Tcl_IsSafe --
|
*
|
*
|
* Determines whether an interpreter is safe
|
* Determines whether an interpreter is safe
|
*
|
*
|
* Results:
|
* Results:
|
* 1 if it is safe, 0 if it is not.
|
* 1 if it is safe, 0 if it is not.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_IsSafe(interp)
|
Tcl_IsSafe(interp)
|
Tcl_Interp *interp; /* Is this interpreter "safe" ? */
|
Tcl_Interp *interp; /* Is this interpreter "safe" ? */
|
{
|
{
|
Interp *iPtr;
|
Interp *iPtr;
|
|
|
if (interp == (Tcl_Interp *) NULL) {
|
if (interp == (Tcl_Interp *) NULL) {
|
return 0;
|
return 0;
|
}
|
}
|
iPtr = (Interp *) interp;
|
iPtr = (Interp *) interp;
|
|
|
return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
|
return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateSlave --
|
* Tcl_CreateSlave --
|
*
|
*
|
* Creates a slave interpreter. The slavePath argument denotes the
|
* Creates a slave interpreter. The slavePath argument denotes the
|
* name of the new slave relative to the current interpreter; the
|
* name of the new slave relative to the current interpreter; the
|
* slave is a direct descendant of the one-before-last component of
|
* 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 path, e.g. it is a descendant of the current interpreter if
|
* the slavePath argument contains only one component. Optionally makes
|
* the slavePath argument contains only one component. Optionally makes
|
* the slave interpreter safe.
|
* the slave interpreter safe.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns the interpreter structure created, or NULL if an error
|
* Returns the interpreter structure created, or NULL if an error
|
* occurred.
|
* occurred.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Creates a new interpreter and a new interpreter object command in
|
* Creates a new interpreter and a new interpreter object command in
|
* the interpreter indicated by the slavePath argument.
|
* the interpreter indicated by the slavePath argument.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Interp *
|
Tcl_Interp *
|
Tcl_CreateSlave(interp, slavePath, isSafe)
|
Tcl_CreateSlave(interp, slavePath, isSafe)
|
Tcl_Interp *interp; /* Interpreter to start search at. */
|
Tcl_Interp *interp; /* Interpreter to start search at. */
|
char *slavePath; /* Name of slave to create. */
|
char *slavePath; /* Name of slave to create. */
|
int isSafe; /* Should new slave be "safe" ? */
|
int isSafe; /* Should new slave be "safe" ? */
|
{
|
{
|
Master *masterPtr; /* Master record for same. */
|
Master *masterPtr; /* Master record for same. */
|
|
|
if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
|
if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
|
return NULL;
|
return NULL;
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
|
masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
|
NULL);
|
NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("CreatSlave: could not find master record");
|
panic("CreatSlave: could not find master record");
|
}
|
}
|
return CreateSlave(interp, masterPtr, slavePath, isSafe);
|
return CreateSlave(interp, masterPtr, slavePath, isSafe);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetSlave --
|
* Tcl_GetSlave --
|
*
|
*
|
* Finds a slave interpreter by its path name.
|
* Finds a slave interpreter by its path name.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns a Tcl_Interp * for the named interpreter or NULL if not
|
* Returns a Tcl_Interp * for the named interpreter or NULL if not
|
* found.
|
* found.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Interp *
|
Tcl_Interp *
|
Tcl_GetSlave(interp, slavePath)
|
Tcl_GetSlave(interp, slavePath)
|
Tcl_Interp *interp; /* Interpreter to start search from. */
|
Tcl_Interp *interp; /* Interpreter to start search from. */
|
char *slavePath; /* Path of slave to find. */
|
char *slavePath; /* Path of slave to find. */
|
{
|
{
|
Master *masterPtr; /* Interim storage for Master record. */
|
Master *masterPtr; /* Interim storage for Master record. */
|
|
|
if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
|
if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
|
return NULL;
|
return NULL;
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
|
masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("Tcl_GetSlave: could not find master record");
|
panic("Tcl_GetSlave: could not find master record");
|
}
|
}
|
return GetInterp(interp, masterPtr, slavePath, NULL);
|
return GetInterp(interp, masterPtr, slavePath, NULL);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetMaster --
|
* Tcl_GetMaster --
|
*
|
*
|
* Finds the master interpreter of a slave interpreter.
|
* Finds the master interpreter of a slave interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns a Tcl_Interp * for the master interpreter or NULL if none.
|
* Returns a Tcl_Interp * for the master interpreter or NULL if none.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Interp *
|
Tcl_Interp *
|
Tcl_GetMaster(interp)
|
Tcl_GetMaster(interp)
|
Tcl_Interp *interp; /* Get the master of this interpreter. */
|
Tcl_Interp *interp; /* Get the master of this interpreter. */
|
{
|
{
|
Slave *slavePtr; /* Slave record of this interpreter. */
|
Slave *slavePtr; /* Slave record of this interpreter. */
|
|
|
if (interp == (Tcl_Interp *) NULL) {
|
if (interp == (Tcl_Interp *) NULL) {
|
return NULL;
|
return NULL;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
|
slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
return NULL;
|
return NULL;
|
}
|
}
|
return slavePtr->masterInterp;
|
return slavePtr->masterInterp;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateAlias --
|
* Tcl_CreateAlias --
|
*
|
*
|
* Creates an alias between two interpreters.
|
* Creates an alias between two interpreters.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Creates a new alias, manipulates the result field of slaveInterp.
|
* Creates a new alias, manipulates the result field of slaveInterp.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
|
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
|
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
|
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
|
char *slaveCmd; /* Command to install in slave. */
|
char *slaveCmd; /* Command to install in slave. */
|
Tcl_Interp *targetInterp; /* Interpreter for target command. */
|
Tcl_Interp *targetInterp; /* Interpreter for target command. */
|
char *targetCmd; /* Name of target command. */
|
char *targetCmd; /* Name of target command. */
|
int argc; /* How many additional arguments? */
|
int argc; /* How many additional arguments? */
|
char **argv; /* These are the additional args. */
|
char **argv; /* These are the additional args. */
|
{
|
{
|
Master *masterPtr; /* Master record for target interp. */
|
Master *masterPtr; /* Master record for target interp. */
|
Tcl_Obj **objv;
|
Tcl_Obj **objv;
|
int i;
|
int i;
|
int result;
|
int result;
|
|
|
if ((slaveInterp == (Tcl_Interp *) NULL) ||
|
if ((slaveInterp == (Tcl_Interp *) NULL) ||
|
(targetInterp == (Tcl_Interp *) NULL) ||
|
(targetInterp == (Tcl_Interp *) NULL) ||
|
(slaveCmd == (char *) NULL) ||
|
(slaveCmd == (char *) NULL) ||
|
(targetCmd == (char *) NULL)) {
|
(targetCmd == (char *) NULL)) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
|
masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
|
NULL);
|
NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("Tcl_CreateAlias: could not find master record");
|
panic("Tcl_CreateAlias: could not find master record");
|
}
|
}
|
objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
|
objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
objv[i] = Tcl_NewStringObj(argv[i], -1);
|
objv[i] = Tcl_NewStringObj(argv[i], -1);
|
Tcl_IncrRefCount(objv[i]);
|
Tcl_IncrRefCount(objv[i]);
|
}
|
}
|
|
|
result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
|
result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
|
masterPtr, slaveCmd, targetCmd, argc, objv);
|
masterPtr, slaveCmd, targetCmd, argc, objv);
|
|
|
ckfree((char *) objv);
|
ckfree((char *) objv);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateAliasObj --
|
* Tcl_CreateAliasObj --
|
*
|
*
|
* Object version: Creates an alias between two interpreters.
|
* Object version: Creates an alias between two interpreters.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Creates a new alias.
|
* Creates a new alias.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
|
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
|
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
|
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
|
char *slaveCmd; /* Command to install in slave. */
|
char *slaveCmd; /* Command to install in slave. */
|
Tcl_Interp *targetInterp; /* Interpreter for target command. */
|
Tcl_Interp *targetInterp; /* Interpreter for target command. */
|
char *targetCmd; /* Name of target command. */
|
char *targetCmd; /* Name of target command. */
|
int objc; /* How many additional arguments? */
|
int objc; /* How many additional arguments? */
|
Tcl_Obj *CONST objv[]; /* Argument vector. */
|
Tcl_Obj *CONST objv[]; /* Argument vector. */
|
{
|
{
|
Master *masterPtr; /* Master record for target interp. */
|
Master *masterPtr; /* Master record for target interp. */
|
|
|
if ((slaveInterp == (Tcl_Interp *) NULL) ||
|
if ((slaveInterp == (Tcl_Interp *) NULL) ||
|
(targetInterp == (Tcl_Interp *) NULL) ||
|
(targetInterp == (Tcl_Interp *) NULL) ||
|
(slaveCmd == (char *) NULL) ||
|
(slaveCmd == (char *) NULL) ||
|
(targetCmd == (char *) NULL)) {
|
(targetCmd == (char *) NULL)) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
|
masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
|
NULL);
|
NULL);
|
if (masterPtr == (Master *) NULL) {
|
if (masterPtr == (Master *) NULL) {
|
panic("Tcl_CreateAlias: could not find master record");
|
panic("Tcl_CreateAlias: could not find master record");
|
}
|
}
|
return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
|
return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
|
masterPtr, slaveCmd, targetCmd, objc, objv);
|
masterPtr, slaveCmd, targetCmd, objc, objv);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetAlias --
|
* Tcl_GetAlias --
|
*
|
*
|
* Gets information about an alias.
|
* Gets information about an alias.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
|
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
|
argvPtr)
|
argvPtr)
|
Tcl_Interp *interp; /* Interp to start search from. */
|
Tcl_Interp *interp; /* Interp to start search from. */
|
char *aliasName; /* Name of alias to find. */
|
char *aliasName; /* Name of alias to find. */
|
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
|
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
|
char **targetNamePtr; /* (Return) name of target command. */
|
char **targetNamePtr; /* (Return) name of target command. */
|
int *argcPtr; /* (Return) count of addnl args. */
|
int *argcPtr; /* (Return) count of addnl args. */
|
char ***argvPtr; /* (Return) additional arguments. */
|
char ***argvPtr; /* (Return) additional arguments. */
|
{
|
{
|
Slave *slavePtr; /* Slave record for slave interp. */
|
Slave *slavePtr; /* Slave record for slave interp. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Alias *aliasPtr; /* Storage for alias found. */
|
Alias *aliasPtr; /* Storage for alias found. */
|
int len;
|
int len;
|
int i;
|
int i;
|
|
|
if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
|
if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
|
slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
panic("Tcl_GetAlias: could not find slave record");
|
panic("Tcl_GetAlias: could not find slave record");
|
}
|
}
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found",
|
Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
if (targetInterpPtr != (Tcl_Interp **) NULL) {
|
if (targetInterpPtr != (Tcl_Interp **) NULL) {
|
*targetInterpPtr = aliasPtr->targetInterp;
|
*targetInterpPtr = aliasPtr->targetInterp;
|
}
|
}
|
if (targetNamePtr != (char **) NULL) {
|
if (targetNamePtr != (char **) NULL) {
|
*targetNamePtr = aliasPtr->targetName;
|
*targetNamePtr = aliasPtr->targetName;
|
}
|
}
|
if (argcPtr != (int *) NULL) {
|
if (argcPtr != (int *) NULL) {
|
*argcPtr = aliasPtr->objc;
|
*argcPtr = aliasPtr->objc;
|
}
|
}
|
if (argvPtr != (char ***) NULL) {
|
if (argvPtr != (char ***) NULL) {
|
*argvPtr = (char **) ckalloc((unsigned) sizeof(char *) *
|
*argvPtr = (char **) ckalloc((unsigned) sizeof(char *) *
|
aliasPtr->objc);
|
aliasPtr->objc);
|
for (i = 0; i < aliasPtr->objc; i++) {
|
for (i = 0; i < aliasPtr->objc; i++) {
|
*argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len);
|
*argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len);
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ObjGetAlias --
|
* Tcl_ObjGetAlias --
|
*
|
*
|
* Object version: Gets information about an alias.
|
* Object version: Gets information about an alias.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
|
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
|
objvPtr)
|
objvPtr)
|
Tcl_Interp *interp; /* Interp to start search from. */
|
Tcl_Interp *interp; /* Interp to start search from. */
|
char *aliasName; /* Name of alias to find. */
|
char *aliasName; /* Name of alias to find. */
|
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
|
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
|
char **targetNamePtr; /* (Return) name of target command. */
|
char **targetNamePtr; /* (Return) name of target command. */
|
int *objcPtr; /* (Return) count of addnl args. */
|
int *objcPtr; /* (Return) count of addnl args. */
|
Tcl_Obj ***objvPtr; /* (Return) additional args. */
|
Tcl_Obj ***objvPtr; /* (Return) additional args. */
|
{
|
{
|
Slave *slavePtr; /* Slave record for slave interp. */
|
Slave *slavePtr; /* Slave record for slave interp. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Tcl_HashEntry *hPtr; /* Search element. */
|
Alias *aliasPtr; /* Storage for alias found. */
|
Alias *aliasPtr; /* Storage for alias found. */
|
|
|
if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
|
if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
|
slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
|
if (slavePtr == (Slave *) NULL) {
|
if (slavePtr == (Slave *) NULL) {
|
panic("Tcl_GetAlias: could not find slave record");
|
panic("Tcl_GetAlias: could not find slave record");
|
}
|
}
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"alias \"", aliasName, "\" not found", (char *) NULL);
|
"alias \"", aliasName, "\" not found", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
|
if (targetInterpPtr != (Tcl_Interp **) NULL) {
|
if (targetInterpPtr != (Tcl_Interp **) NULL) {
|
*targetInterpPtr = aliasPtr->targetInterp;
|
*targetInterpPtr = aliasPtr->targetInterp;
|
}
|
}
|
if (targetNamePtr != (char **) NULL) {
|
if (targetNamePtr != (char **) NULL) {
|
*targetNamePtr = aliasPtr->targetName;
|
*targetNamePtr = aliasPtr->targetName;
|
}
|
}
|
if (objcPtr != (int *) NULL) {
|
if (objcPtr != (int *) NULL) {
|
*objcPtr = aliasPtr->objc;
|
*objcPtr = aliasPtr->objc;
|
}
|
}
|
if (objvPtr != (Tcl_Obj ***) NULL) {
|
if (objvPtr != (Tcl_Obj ***) NULL) {
|
*objvPtr = aliasPtr->objv;
|
*objvPtr = aliasPtr->objv;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
