Logo Search packages:      
Sourcecode: tcl8.4 version File versions  Download package

tclInterp.c

/* 
 * tclInterp.c --
 *
 *    This file implements the "interp" command which allows creation
 *    and manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInterp.c,v 1.20.2.2 2003/05/12 22:35:40 dgp Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <stdio.h>

/*
 * Counter for how many aliases were created (global)
 */

static int aliasCounter = 0;
TCL_DECLARE_MUTEX(cntMutex)

/*
 * struct Alias:
 *
 * Stores information about an alias. Is stored in the slave interpreter
 * and used by the source command to find the target command in the master
 * when the source command is invoked.
 */

typedef struct Alias {
    Tcl_Obj *namePtr;         /* Name of alias command in slave interp. */
    Tcl_Interp *targetInterp; /* Interp in which target command will be
                         * invoked. */
    Tcl_Command slaveCmd;     /* Source command in slave interpreter,
                         * bound to command that invokes the target
                         * command in the target interpreter. */
    Tcl_HashEntry *aliasEntryPtr;
                        /* Entry for the alias hash table in slave.
                                 * This is used by alias deletion to remove
                                 * the alias from the slave interpreter
                                 * alias table. */
    Tcl_HashEntry *targetEntryPtr;
                        /* Entry for target command in master.
                                 * This is used in the master interpreter to
                                 * map back from the target command to aliases
                                 * redirecting to it. Random access to this
                                 * hash table is never required - we are using
                                 * a hash table only for convenience. */
    int objc;                   /* Count of Tcl_Obj in the prefix of the
                         * target command to be invoked in the
                         * target interpreter. Additional arguments
                         * specified when calling the alias in the
                         * slave interp will be appended to the prefix
                         * before the command is invoked. */
    Tcl_Obj *objPtr;            /* The first actual prefix object - the target
                         * command name; this has to be at the end of the 
                         * structure, which will be extended to accomodate 
                         * the remaining objects in the prefix. */
} Alias;

/*
 *
 * struct Slave:
 *
 * Used by the "interp" command to record and find information about slave
 * interpreters. Maps from a command name in the master to information about
 * a slave interpreter, e.g. what aliases are defined in it.
 */

typedef struct Slave {
    Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
    Tcl_HashEntry *slaveEntryPtr;
                        /* Hash entry in masters slave table for
                                 * this slave interpreter.  Used to find
                                 * this record, and used when deleting the
                                 * slave interpreter to delete it from the
                                 * master's table. */
    Tcl_Interp    *slaveInterp;     /* The slave interpreter. */
    Tcl_Command interpCmd;    /* Interpreter object command. */
    Tcl_HashTable aliasTable; /* Table which maps from names of commands
                                 * in slave interpreter to struct Alias
                                 * defined below. */
} Slave;

/*
 * struct Target:
 *
 * Maps from master interpreter commands back to the source commands in slave
 * interpreters. This is needed because aliases can be created between sibling
 * interpreters and must be deleted when the target interpreter is deleted. In
 * case they would not be deleted the source interpreter would be left with a
 * "dangling pointer". One such record is stored in the Master record of the
 * master interpreter (in the targetTable hashtable, see below) with the
 * master for each alias which directs to a command in the master. These
 * records are used to remove the source command for an from a slave if/when
 * the master is deleted.
 */

typedef struct Target {
    Tcl_Command   slaveCmd;   /* Command for alias in slave interp. */
    Tcl_Interp *slaveInterp;  /* Slave Interpreter. */
} Target;

/*
 * struct Master:
 *
 * This record is used for two purposes: First, slaveTable (a hashtable)
 * maps from names of commands to slave interpreters. This hashtable is
 * used to store information about slave interpreters of this interpreter,
 * to map over all slaves, etc. The second purpose is to store information
 * about all aliases in slaves (or siblings) which direct to target commands
 * in this interpreter (using the targetTable hashtable).
 * 
 * NB: the flags field in the interp structure, used with SAFE_INTERP
 * mask denotes whether the interpreter is safe or not. Safe
 * interpreters have restricted functionality, can only create safe slave
 * interpreters and can only load safe extensions.
 */

typedef struct Master {
    Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
                                 * Maps from command names to Slave records. */
    Tcl_HashTable targetTable;      /* Hash table for Target Records. Contains
                                 * all Target records which denote aliases
                                 * from slaves or sibling interpreters that
                                 * direct to commands in this interpreter. This
                                 * table is used to remove dangling pointers
                                 * from the slave (or sibling) interpreters
                                 * when this interpreter is deleted. */
} Master;

/*
 * The following structure keeps track of all the Master and Slave information
 * on a per-interp basis.
 */

typedef struct InterpInfo {
    Master master;            /* Keeps track of all interps for which this
                         * interp is the Master. */
    Slave slave;        /* Information necessary for this interp to
                         * function as a slave. */
} InterpInfo;

/*
 * Prototypes for local static procedures:
 */

static int        AliasCreate _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
                      Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
                      Tcl_Obj *CONST objv[]));
static int        AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
static int        AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
static int        AliasList _ANSI_ARGS_((Tcl_Interp *interp,
                        Tcl_Interp *slaveInterp));
static int        AliasObjCmd _ANSI_ARGS_((ClientData dummy,
                      Tcl_Interp *currentInterp, int objc,
                        Tcl_Obj *CONST objv[]));
static void       AliasObjCmdDeleteProc _ANSI_ARGS_((
                      ClientData clientData));

static Tcl_Interp *     GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Obj *pathPtr));
static Tcl_Interp *     GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
                      Tcl_Obj *CONST objv[]));
static void       InterpInfoDeleteProc _ANSI_ARGS_((
                      ClientData clientData, Tcl_Interp *interp));
static Tcl_Interp *     SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
                        Tcl_Obj *pathPtr, int safe));
static int        SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, int objc,
                      Tcl_Obj *CONST objv[]));
static int        SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, int objc,
                      Tcl_Obj *CONST objv[]));
static int        SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, int objc,
                      Tcl_Obj *CONST objv[]));
static int        SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp));
static int        SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, int global, int objc,
                      Tcl_Obj *CONST objv[]));
static int        SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp));
static int        SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
                      Tcl_Interp *interp, int objc,
                      Tcl_Obj *CONST objv[]));
static void       SlaveObjCmdDeleteProc _ANSI_ARGS_((
                      ClientData clientData));
static int        SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp,
                      Tcl_Interp *slaveInterp, int objc,
                      Tcl_Obj *CONST objv[]));


/*
 *---------------------------------------------------------------------------
 *
 * TclInterpInit --
 *
 *    Initializes the invoking interpreter for using the master, slave
 *    and safe interp facilities.  This is called from inside
 *    Tcl_CreateInterp().
 *
 * Results:
 *    Always returns TCL_OK for backwards compatibility.
 *
 * Side effects:
 *    Adds the "interp" command to an interpreter and initializes the
 *    interpInfoPtr field of the invoking interpreter.
 *
 *---------------------------------------------------------------------------
 */

int
TclInterpInit(interp)
    Tcl_Interp *interp;             /* Interpreter to initialize. */
{
    InterpInfo *interpInfoPtr;
    Master *masterPtr;
    Slave *slavePtr;    

    interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
    ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;

    masterPtr = &interpInfoPtr->master;
    Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
    Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS);

    slavePtr = &interpInfoPtr->slave;
    slavePtr->masterInterp    = NULL;
    slavePtr->slaveEntryPtr   = NULL;
    slavePtr->slaveInterp     = interp;
    slavePtr->interpCmd       = NULL;
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);

    Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);

    Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * InterpInfoDeleteProc --
 *
 *    Invoked when an interpreter is being deleted.  It releases all
 *    storage used by the master/slave/safe interpreter facilities.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Cleans up storage.  Sets the interpInfoPtr field of the interp
 *    to NULL.
 *
 *---------------------------------------------------------------------------
 */

static void
InterpInfoDeleteProc(clientData, interp)
    ClientData clientData;    /* Ignored. */
    Tcl_Interp *interp;       /* Interp being deleted.  All commands for
                         * slave interps should already be deleted. */
{
    InterpInfo *interpInfoPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Tcl_HashSearch hSearch;
    Tcl_HashEntry *hPtr;
    Target *targetPtr;

    interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;

    /*
     * There shouldn't be any commands left.
     */

    masterPtr = &interpInfoPtr->master;
    if (masterPtr->slaveTable.numEntries != 0) {
      panic("InterpInfoDeleteProc: still exist commands");
    }
    Tcl_DeleteHashTable(&masterPtr->slaveTable);

    /*
     * Tell any interps that have aliases to this interp that they should
     * delete those aliases.  If the other interp was already dead, it
     * would have removed the target record already. 
     */

    hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch);
    while (hPtr != NULL) {
      targetPtr = (Target *) Tcl_GetHashValue(hPtr);
      Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
            targetPtr->slaveCmd);
      hPtr = Tcl_NextHashEntry(&hSearch);
    }
    Tcl_DeleteHashTable(&masterPtr->targetTable);

    slavePtr = &interpInfoPtr->slave;
    if (slavePtr->interpCmd != NULL) {
      /*
       * Tcl_DeleteInterp() was called on this interpreter, rather
       * "interp delete" or the equivalent deletion of the command in the
       * master.  First ensure that the cleanup callback doesn't try to
       * delete the interp again.
       */

      slavePtr->slaveInterp = NULL;
        Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
            slavePtr->interpCmd);
    }

    /*
     * There shouldn't be any aliases left.
     */

    if (slavePtr->aliasTable.numEntries != 0) {
      panic("InterpInfoDeleteProc: still exist aliases");
    }
    Tcl_DeleteHashTable(&slavePtr->aliasTable);

    ckfree((char *) interpInfoPtr);    
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpObjCmd --
 *
 *    This procedure is invoked to process the "interp" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */
      /* ARGSUSED */
int
Tcl_InterpObjCmd(clientData, interp, objc, objv)
    ClientData clientData;          /* Unused. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    int index;
    static CONST char *options[] = {
        "alias",  "aliases",  "create",   "delete", 
      "eval",           "exists",   "expose",   "hide", 
      "hidden",   "issafe",   "invokehidden",   "marktrusted", 
      "recursionlimit",       "slaves",   "share",
      "target",   "transfer",
        NULL
    };
    enum option {
      OPT_ALIAS,  OPT_ALIASES,      OPT_CREATE, OPT_DELETE,
      OPT_EVAL,   OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
      OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,    OPT_MARKTRUSTED,
      OPT_RECLIMIT,                 OPT_SLAVES, OPT_SHARE,
      OPT_TARGET, OPT_TRANSFER
    };


    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, 
          &index) != TCL_OK) {
      return TCL_ERROR;
    }
    switch ((enum option) index) {
      case OPT_ALIAS: {
          Tcl_Interp *slaveInterp, *masterInterp;

          if (objc < 4) {
            aliasArgs:
            Tcl_WrongNumArgs(interp, 2, objv,
                  "slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == (Tcl_Interp *) NULL) {
            return TCL_ERROR;
          }
          if (objc == 4) {
            return AliasDescribe(interp, slaveInterp, objv[3]);
          }
          if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
            return AliasDelete(interp, slaveInterp, objv[3]);
          }
          if (objc > 5) {
            masterInterp = GetInterp(interp, objv[4]);
            if (masterInterp == (Tcl_Interp *) NULL) {
                return TCL_ERROR;
            }
            if (Tcl_GetString(objv[5])[0] == '\0') {
                if (objc == 6) {
                  return AliasDelete(interp, slaveInterp, objv[3]);
                }
            } else {
                return AliasCreate(interp, slaveInterp, masterInterp,
                      objv[3], objv[5], objc - 6, objv + 6);
            }
          }
          goto aliasArgs;
      }
      case OPT_ALIASES: {
          Tcl_Interp *slaveInterp;

          slaveInterp = GetInterp2(interp, objc, objv);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          return AliasList(interp, slaveInterp);
      }
      case OPT_CREATE: {
          int i, last, safe;
          Tcl_Obj *slavePtr;
          char buf[16 + TCL_INTEGER_SPACE];
          static CONST char *options[] = {
            "-safe",    "--",       NULL
          };
          enum option {
            OPT_SAFE,   OPT_LAST
          };

          safe = Tcl_IsSafe(interp);
          
          /*
           * Weird historical rules: "-safe" is accepted at the end, too.
           */

          slavePtr = NULL;
          last = 0;
          for (i = 2; i < objc; i++) {
            if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
                if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
                      0, &index) != TCL_OK) {
                  return TCL_ERROR;
                }
                if (index == OPT_SAFE) {
                  safe = 1;
                  continue;
                }
                i++;
                last = 1;
            }
            if (slavePtr != NULL) {
                Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
                return TCL_ERROR;
            }
            if (i < objc) {
                slavePtr = objv[i];
            }
          }
          buf[0] = '\0';
          if (slavePtr == NULL) {
            /*
             * Create an anonymous interpreter -- we choose its name and
             * the name of the command. We check that the command name
             * that we use for the interpreter does not collide with an
             * existing command in the master interpreter.
             */
            
            for (i = 0; ; i++) {
                Tcl_CmdInfo cmdInfo;
                
                sprintf(buf, "interp%d", i);
                if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
                  break;
                }
            }
            slavePtr = Tcl_NewStringObj(buf, -1);
          }
          if (SlaveCreate(interp, slavePtr, safe) == NULL) {
            if (buf[0] != '\0') {
                Tcl_DecrRefCount(slavePtr);
            }
            return TCL_ERROR;
          }
          Tcl_SetObjResult(interp, slavePtr);
          return TCL_OK;
      }
      case OPT_DELETE: {
          int i;
          InterpInfo *iiPtr;
          Tcl_Interp *slaveInterp;
          
          for (i = 2; i < objc; i++) {
            slaveInterp = GetInterp(interp, objv[i]);
            if (slaveInterp == NULL) {
                return TCL_ERROR;
            } else if (slaveInterp == interp) {
                Tcl_ResetResult(interp);
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                      "cannot delete the current interpreter",
                      (char *) NULL);
                return TCL_ERROR;
            }
            iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
            Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
                  iiPtr->slave.interpCmd);
          }
          return TCL_OK;
      }
      case OPT_EVAL: {
          Tcl_Interp *slaveInterp;

          if (objc < 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
      }
      case OPT_EXISTS: {
          int exists;
          Tcl_Interp *slaveInterp;

          exists = 1;
          slaveInterp = GetInterp2(interp, objc, objv);
          if (slaveInterp == NULL) {
            if (objc > 3) {
                return TCL_ERROR;
            }
            Tcl_ResetResult(interp);
            exists = 0;
          }
          Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
          return TCL_OK;
      }
      case OPT_EXPOSE: {
          Tcl_Interp *slaveInterp;

          if ((objc < 4) || (objc > 5)) {
            Tcl_WrongNumArgs(interp, 2, objv,
                  "path hiddenCmdName ?cmdName?");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
      }
      case OPT_HIDE: {
          Tcl_Interp *slaveInterp;        /* A slave. */

          if ((objc < 4) || (objc > 5)) {
            Tcl_WrongNumArgs(interp, 2, objv,
                  "path cmdName ?hiddenCmdName?");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == (Tcl_Interp *) NULL) {
            return TCL_ERROR;
          }
          return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
      }
      case OPT_HIDDEN: {
          Tcl_Interp *slaveInterp;        /* A slave. */

          slaveInterp = GetInterp2(interp, objc, objv);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          return SlaveHidden(interp, slaveInterp);
      }
      case OPT_ISSAFE: {
          Tcl_Interp *slaveInterp;

          slaveInterp = GetInterp2(interp, objc, objv);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
          return TCL_OK;
      }
      case OPT_INVOKEHID: {
          int i, index, global;
          Tcl_Interp *slaveInterp;
          static CONST char *hiddenOptions[] = {
            "-global",  "--",       NULL
          };
          enum hiddenOption {
            OPT_GLOBAL, OPT_LAST
          };

          global = 0;
          for (i = 3; i < objc; i++) {
            if (Tcl_GetString(objv[i])[0] != '-') {
                break;
            }
            if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
                  "option", 0, &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if (index == OPT_GLOBAL) {
                global = 1;
            } else {
                i++;
                break;
            }
          }
          if (objc - i < 1) {
            Tcl_WrongNumArgs(interp, 2, objv,
                  "path ?-global? ?--? cmd ?arg ..?");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == (Tcl_Interp *) NULL) {
            return TCL_ERROR;
          }
          return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
                objv + i);
      }
      case OPT_MARKTRUSTED: {
          Tcl_Interp *slaveInterp;

          if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "path");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          return SlaveMarkTrusted(interp, slaveInterp);
      }
      case OPT_RECLIMIT: {
          Tcl_Interp *slaveInterp;

          if (objc != 3 && objc != 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
      }
      case OPT_SLAVES: {
          Tcl_Interp *slaveInterp;
          InterpInfo *iiPtr;
          Tcl_Obj *resultPtr;
          Tcl_HashEntry *hPtr;
          Tcl_HashSearch hashSearch;
          char *string;
          
          slaveInterp = GetInterp2(interp, objc, objv);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
          resultPtr = Tcl_GetObjResult(interp);
          hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
          for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
            string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
            Tcl_ListObjAppendElement(NULL, resultPtr,
                  Tcl_NewStringObj(string, -1));
          }
          return TCL_OK;
      }
      case OPT_SHARE: {
          Tcl_Interp *slaveInterp;        /* A slave. */
          Tcl_Interp *masterInterp;       /* Its master. */
          Tcl_Channel chan;

          if (objc != 5) {
            Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
            return TCL_ERROR;
          }
          masterInterp = GetInterp(interp, objv[2]);
          if (masterInterp == NULL) {
            return TCL_ERROR;
          }
          chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
                NULL);
          if (chan == NULL) {
            TclTransferResult(masterInterp, TCL_OK, interp);
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[4]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          Tcl_RegisterChannel(slaveInterp, chan);
          return TCL_OK;
      }
      case OPT_TARGET: {
          Tcl_Interp *slaveInterp;
          InterpInfo *iiPtr;
          Tcl_HashEntry *hPtr;      
          Alias *aliasPtr;          
          char *aliasName;

          if (objc != 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "path alias");
            return TCL_ERROR;
          }

          slaveInterp = GetInterp(interp, objv[2]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }

          aliasName = Tcl_GetString(objv[3]);

          iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
          hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
          if (hPtr == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                  "alias \"", aliasName, "\" in path \"",
                  Tcl_GetString(objv[2]), "\" not found",
                  (char *) NULL);
            return TCL_ERROR;
          }
          aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
          if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
            Tcl_ResetResult(interp);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                  "target interpreter for alias \"", aliasName,
                  "\" in path \"", Tcl_GetString(objv[2]),
                  "\" is not my descendant", (char *) NULL);
            return TCL_ERROR;
          }
          return TCL_OK;
      }
      case OPT_TRANSFER: {
          Tcl_Interp *slaveInterp;        /* A slave. */
          Tcl_Interp *masterInterp;       /* Its master. */
          Tcl_Channel chan;
                
          if (objc != 5) {
            Tcl_WrongNumArgs(interp, 2, objv,
                  "srcPath channelId destPath");
            return TCL_ERROR;
          }
          masterInterp = GetInterp(interp, objv[2]);
          if (masterInterp == NULL) {
            return TCL_ERROR;
          }
          chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
          if (chan == NULL) {
            TclTransferResult(masterInterp, TCL_OK, interp);
            return TCL_ERROR;
          }
          slaveInterp = GetInterp(interp, objv[4]);
          if (slaveInterp == NULL) {
            return TCL_ERROR;
          }
          Tcl_RegisterChannel(slaveInterp, chan);
          if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
            TclTransferResult(masterInterp, TCL_OK, interp);
            return TCL_ERROR;
          }
          return TCL_OK;
      }
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInterp2 --
 *
 *    Helper function for Tcl_InterpObjCmd() to convert the interp name
 *    potentially specified on the command line to an Tcl_Interp.
 *
 * Results:
 *    The return value is the interp specified on the command line,
 *    or the interp argument itself if no interp was specified on the
 *    command line.  If the interp could not be found or the wrong
 *    number of arguments was specified on the command line, the return
 *    value is NULL and an error message is left in the interp's result.
 *
 * Side effects:
 *    None.
 *
 *---------------------------------------------------------------------------
 */
 
static Tcl_Interp *
GetInterp2(interp, objc, objv)
    Tcl_Interp *interp;       /* Default interp if no interp was specified
                         * on the command line. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    if (objc == 2) {
      return interp;
    } else if (objc == 3) {
      return GetInterp(interp, objv[2]);
    } else {
      Tcl_WrongNumArgs(interp, 2, objv, "?path?");
      return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateAlias --
 *
 *    Creates an alias between two interpreters.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Creates a new alias, manipulates the result field of slaveInterp.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
    Tcl_Interp *slaveInterp;  /* Interpreter for source command. */
    CONST char *slaveCmd;     /* Command to install in slave. */
    Tcl_Interp *targetInterp; /* Interpreter for target command. */
    CONST char *targetCmd;    /* Name of target command. */
    int argc;                 /* How many additional arguments? */
    CONST char * CONST *argv; /* These are the additional args. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    int i;
    int result;
    
    objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
        objv[i] = Tcl_NewStringObj(argv[i], -1);
        Tcl_IncrRefCount(objv[i]);
    }
    
    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
          targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
      Tcl_DecrRefCount(objv[i]);
    }
    ckfree((char *) objv);
    Tcl_DecrRefCount(targetObjPtr);
    Tcl_DecrRefCount(slaveObjPtr);

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateAliasObj --
 *
 *    Object version: Creates an alias between two interpreters.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Creates a new alias.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
    Tcl_Interp *slaveInterp;  /* Interpreter for source command. */
    CONST char *slaveCmd;     /* Command to install in slave. */
    Tcl_Interp *targetInterp; /* Interpreter for target command. */
    CONST char *targetCmd;    /* Name of target command. */
    int objc;                 /* How many additional arguments? */
    Tcl_Obj *CONST objv[];    /* Argument vector. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    int result;

    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
          targetObjPtr, objc, objv);

    Tcl_DecrRefCount(slaveObjPtr);
    Tcl_DecrRefCount(targetObjPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAlias --
 *
 *    Gets information about an alias.
 *
 * Results:
 *    A standard Tcl result. 
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
        argvPtr)
    Tcl_Interp *interp;             /* Interp to start search from. */
    CONST char *aliasName;                /* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;   /* (Return) target interpreter. */
    CONST char **targetNamePtr;           /* (Return) name of target command. */
    int *argcPtr;             /* (Return) count of addnl args. */
    CONST char ***argvPtr;          /* (Return) additional arguments. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int i, objc;
    Tcl_Obj **objv;
    
    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "alias \"", aliasName, "\" not found", (char *) NULL);
      return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != NULL) {
      *targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != NULL) {
      *targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (argcPtr != NULL) {
      *argcPtr = objc - 1;
    }
    if (argvPtr != NULL) {
        *argvPtr = (CONST char **) 
            ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
        for (i = 1; i < objc; i++) {
            *argvPtr[i - 1] = Tcl_GetString(objv[i]);
        }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAliasObj --
 *
 *    Object version: Gets information about an alias.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
        objvPtr)
    Tcl_Interp *interp;             /* Interp to start search from. */
    CONST char *aliasName;          /* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;   /* (Return) target interpreter. */
    CONST char **targetNamePtr;           /* (Return) name of target command. */
    int *objcPtr;             /* (Return) count of addnl args. */
    Tcl_Obj ***objvPtr;             /* (Return) additional args. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;    
    int objc;
    Tcl_Obj **objv;

    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "alias \"", aliasName, "\" not found", (char *) NULL);
        return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != (Tcl_Interp **) NULL) {
        *targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != (CONST char **) NULL) {
        *targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (objcPtr != (int *) NULL) {
        *objcPtr = objc - 1;
    }
    if (objvPtr != (Tcl_Obj ***) NULL) {
        *objvPtr = objv + 1;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPreventAliasLoop --
 *
 *    When defining an alias or renaming a command, prevent an alias
 *    loop from being formed.
 *
 * Results:
 *    A standard Tcl object result.
 *
 * Side effects:
 *    If TCL_ERROR is returned, the function also stores an error message
 *    in the interpreter's result object.
 *
 * NOTE:
 *    This function is public internal (instead of being static to
 *    this file) because it is also used from TclRenameCommand.
 *
 *----------------------------------------------------------------------
 */

int
TclPreventAliasLoop(interp, cmdInterp, cmd)
    Tcl_Interp *interp;             /* Interp in which to report errors. */
    Tcl_Interp *cmdInterp;          /* Interp in which the command is
                                         * being defined. */
    Tcl_Command cmd;                    /* Tcl command we are attempting
                                         * to define. */
{
    Command *cmdPtr = (Command *) cmd;
    Alias *aliasPtr, *nextAliasPtr;
    Tcl_Command aliasCmd;
    Command *aliasCmdPtr;

    /*
     * If we are not creating or renaming an alias, then it is
     * always OK to create or rename the command.
     */
    
    if (cmdPtr->objProc != AliasObjCmd) {
        return TCL_OK;
    }

    /*
     * OK, we are dealing with an alias, so traverse the chain of aliases.
     * If we encounter the alias we are defining (or renaming to) any in
     * the chain then we have a loop.
     */

    aliasPtr = (Alias *) cmdPtr->objClientData;
    nextAliasPtr = aliasPtr;
    while (1) {
      Tcl_Obj *cmdNamePtr;

        /*
         * If the target of the next alias in the chain is the same as
         * the source alias, we have a loop.
       */

      if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
          /*
           * The slave interpreter can be deleted while creating the alias.
           * [Bug #641195]
           */

          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "cannot define or rename alias \"",
                Tcl_GetString(aliasPtr->namePtr),
                "\": interpreter deleted", (char *) NULL);
          return TCL_ERROR;
      }
      cmdNamePtr = nextAliasPtr->objPtr;
      aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
                Tcl_GetString(cmdNamePtr),
            Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
            /*flags*/ 0);
        if (aliasCmd == (Tcl_Command) NULL) {
            return TCL_OK;
        }
      aliasCmdPtr = (Command *) aliasCmd;
        if (aliasCmdPtr == cmdPtr) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "cannot define or rename alias \"",
                Tcl_GetString(aliasPtr->namePtr),
                "\": would create a loop", (char *) NULL);
            return TCL_ERROR;
        }

        /*
       * Otherwise, follow the chain one step further. See if the target
         * command is an alias - if so, follow the loop to its target
         * command. Otherwise we do not have a loop.
       */

        if (aliasCmdPtr->objProc != AliasObjCmd) {
            return TCL_OK;
        }
        nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
    }

    /* NOTREACHED */
}

/*
 *----------------------------------------------------------------------
 *
 * AliasCreate --
 *
 *    Helper function to do the work to actually create an alias.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    An alias command is created and entered into the alias table
 *    for the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
      objc, objv)
    Tcl_Interp *interp;       /* Interp for error reporting. */
    Tcl_Interp *slaveInterp;  /* Interp where alias cmd will live or from
                         * which alias will be deleted. */
    Tcl_Interp *masterInterp; /* Interp in which target command will be
                         * invoked. */
    Tcl_Obj *namePtr;         /* Name of alias cmd. */
    Tcl_Obj *targetNamePtr;   /* Name of target cmd. */
    int objc;                 /* Additional arguments to store */
    Tcl_Obj *CONST objv[];    /* with alias. */
{
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;
    Target *targetPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Tcl_Obj **prefv;
    int new, i;

    aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) 
            + objc * sizeof(Tcl_Obj *)));
    aliasPtr->namePtr         = namePtr;
    Tcl_IncrRefCount(aliasPtr->namePtr);
    aliasPtr->targetInterp    = masterInterp;

    aliasPtr->objc = objc + 1;
    prefv = &aliasPtr->objPtr;

    *prefv = targetNamePtr;
    Tcl_IncrRefCount(targetNamePtr);
    for (i = 0; i < objc; i++) {
      *(++prefv) = objv[i];
      Tcl_IncrRefCount(objv[i]);
    }

    Tcl_Preserve(slaveInterp);
    Tcl_Preserve(masterInterp);

    aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
          Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
          AliasObjCmdDeleteProc);

    if (TclPreventAliasLoop(interp, slaveInterp,
          aliasPtr->slaveCmd) != TCL_OK) {
      /*
       * Found an alias loop!  The last call to Tcl_CreateObjCommand made
       * the alias point to itself.  Delete the command and its alias
       * record.  Be careful to wipe out its client data first, so the
       * command doesn't try to delete itself.
       */

      Command *cmdPtr;
      
      Tcl_DecrRefCount(aliasPtr->namePtr);
      Tcl_DecrRefCount(targetNamePtr);
      for (i = 0; i < objc; i++) {
          Tcl_DecrRefCount(objv[i]);
      }
      
      cmdPtr = (Command *) aliasPtr->slaveCmd;
      cmdPtr->clientData = NULL;
      cmdPtr->deleteProc = NULL;
      cmdPtr->deleteData = NULL;
      Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);

      ckfree((char *) aliasPtr);

      /*
       * The result was already set by TclPreventAliasLoop.
       */

      Tcl_Release(slaveInterp);
      Tcl_Release(masterInterp);
      return TCL_ERROR;
    }

    /*
     * Make an entry in the alias table. If it already exists delete
     * the alias command. Then retry.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    while (1) {
      Alias *oldAliasPtr;
      char *string;
      
      string = Tcl_GetString(namePtr);
      hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
      if (new != 0) {
          break;
      }

      oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
      Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd);
    }

    aliasPtr->aliasEntryPtr = hPtr;
    Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
    
    /*
     * Create the new command. We must do it after deleting any old command,
     * because the alias may be pointing at a renamed alias, as in:
     *
     * interp alias {} foo {} bar         # Create an alias "foo"
     * rename foo zop                     # Now rename the alias
     * interp alias {} foo {} zop         # Now recreate "foo"...
     */

    targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
    targetPtr->slaveCmd = aliasPtr->slaveCmd;
    targetPtr->slaveInterp = slaveInterp;

    Tcl_MutexLock(&cntMutex);
    masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master;
    do {
        hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable,
                (char *) aliasCounter, &new);
      aliasCounter++;
    } while (new == 0);
    Tcl_MutexUnlock(&cntMutex);

    Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
    aliasPtr->targetEntryPtr = hPtr;

    Tcl_SetObjResult(interp, namePtr);

    Tcl_Release(slaveInterp);
    Tcl_Release(masterInterp);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasDelete --
 *
 *    Deletes the given alias from the slave interpreter given.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Deletes the alias from the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
AliasDelete(interp, slaveInterp, namePtr)
    Tcl_Interp *interp;       /* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;  /* Interpreter containing alias. */
    Tcl_Obj *namePtr;         /* Name of alias to delete. */
{
    Slave *slavePtr;
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * delete it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"",
            Tcl_GetString(namePtr), "\" not found", NULL);
        return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasDescribe --
 *
 *    Sets the interpreter's result object to a Tcl list describing
 *    the given alias in the given interpreter: its target command
 *    and the additional arguments to prepend to any invocation
 *    of the alias.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
AliasDescribe(interp, slaveInterp, namePtr)
    Tcl_Interp *interp;       /* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;  /* Interpreter containing alias. */
    Tcl_Obj *namePtr;         /* Name of alias to describe. */
{
    Slave *slavePtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;    
    Tcl_Obj *prefixPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
        return TCL_OK;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
    Tcl_SetObjResult(interp, prefixPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasList --
 *
 *    Computes a list of aliases defined in a slave interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
AliasList(interp, slaveInterp)
    Tcl_Interp *interp;       /* Interp for data return. */
    Tcl_Interp *slaveInterp;  /* Interp whose aliases to compute. */
{
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch hashSearch;
    Tcl_Obj *resultPtr; 
    Alias *aliasPtr;
    Slave *slavePtr;

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    resultPtr = Tcl_GetObjResult(interp);

    entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
    for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
        aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
        Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmd --
 *
 *    This is the procedure that services invocations of aliases in a
 *    slave interpreter. One such command exists for each alias. When
 *    invoked, this procedure redirects the invocation to the target
 *    command in the master interpreter as designated by the Alias
 *    record associated with this command.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Causes forwarding of the invocation; all possible side effects
 *    may occur as a result of invoking the command to which the
 *    invocation is forwarded.
 *
 *----------------------------------------------------------------------
 */

static int
AliasObjCmd(clientData, interp, objc, objv)
    ClientData clientData;    /* Alias record. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument vector. */  
{
#define ALIAS_CMDV_PREALLOC 10
    Tcl_Interp *targetInterp; 
    Alias *aliasPtr;          
    int result, prefc, cmdc, i;
    Tcl_Obj **prefv, **cmdv;
    Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
    aliasPtr = (Alias *) clientData;
    targetInterp = aliasPtr->targetInterp;

    /*
     * Append the arguments to the command prefix and invoke the command
     * in the target interp's global namespace.
     */
     
    prefc = aliasPtr->objc;
    prefv = &aliasPtr->objPtr;
    cmdc = prefc + objc - 1;
    if (cmdc <= ALIAS_CMDV_PREALLOC) {
      cmdv = cmdArr;
    } else {
      cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
    }

    prefv = &aliasPtr->objPtr;
    memcpy((VOID *) cmdv, (VOID *) prefv, 
            (size_t) (prefc * sizeof(Tcl_Obj *)));
    memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), 
          (size_t) ((objc-1) * sizeof(Tcl_Obj *)));

    Tcl_ResetResult(targetInterp);

    for (i=0; i<cmdc; i++) {
      Tcl_IncrRefCount(cmdv[i]);
    }
    if (targetInterp != interp) {
      Tcl_Preserve((ClientData) targetInterp);
      result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
      TclTransferResult(targetInterp, result, interp);      
      Tcl_Release((ClientData) targetInterp);
    } else {
      result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
    }
    for (i=0; i<cmdc; i++) {
      Tcl_DecrRefCount(cmdv[i]);
    }

    if (cmdv != cmdArr) {
      ckfree((char *) cmdv);
    }
    return result;        
#undef ALIAS_CMDV_PREALLOC
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *
 *    Is invoked when an alias command is deleted in a slave. Cleans up
 *    all storage associated with this alias.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Deletes the alias record and its entry in the alias table for
 *    the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
AliasObjCmdDeleteProc(clientData)
    ClientData clientData;    /* The alias record for this alias. */
{
    Alias *aliasPtr;          
    Target *targetPtr;        
    int i;
    Tcl_Obj **objv;

    aliasPtr = (Alias *) clientData;
    
    Tcl_DecrRefCount(aliasPtr->namePtr);
    objv = &aliasPtr->objPtr;
    for (i = 0; i < aliasPtr->objc; i++) {
      Tcl_DecrRefCount(objv[i]);
    }
    Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);

    targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
    ckfree((char *) targetPtr);
    Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);

    ckfree((char *) aliasPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateSlave --
 *
 *    Creates a slave interpreter. The slavePath argument denotes the
 *    name of the new slave relative to the current interpreter; the
 *    slave is a direct descendant of the one-before-last component of
 *    the path, e.g. it is a descendant of the current interpreter if
 *    the slavePath argument contains only one component. Optionally makes
 *    the slave interpreter safe.
 *
 * Results:
 *    Returns the interpreter structure created, or NULL if an error
 *    occurred.
 *
 * Side effects:
 *    Creates a new interpreter and a new interpreter object command in
 *    the interpreter indicated by the slavePath argument.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateSlave(interp, slavePath, isSafe)
    Tcl_Interp *interp;       /* Interpreter to start search at. */
    CONST char *slavePath;    /* Name of slave to create. */
    int isSafe;               /* Should new slave be "safe" ? */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *slaveInterp;

    pathPtr = Tcl_NewStringObj(slavePath, -1);
    slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
    Tcl_DecrRefCount(pathPtr);

    return slaveInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetSlave --
 *
 *    Finds a slave interpreter by its path name.
 *
 * Results:
 *    Returns a Tcl_Interp * for the named interpreter or NULL if not
 *    found.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_GetSlave(interp, slavePath)
    Tcl_Interp *interp;       /* Interpreter to start search from. */
    CONST char *slavePath;    /* Path of slave to find. */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *slaveInterp;

    pathPtr = Tcl_NewStringObj(slavePath, -1);
    slaveInterp = GetInterp(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);

    return slaveInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMaster --
 *
 *    Finds the master interpreter of a slave interpreter.
 *
 * Results:
 *    Returns a Tcl_Interp * for the master interpreter or NULL if none.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_GetMaster(interp)
    Tcl_Interp *interp;       /* Get the master of this interpreter. */
{
    Slave *slavePtr;          /* Slave record of this interpreter. */

    if (interp == (Tcl_Interp *) NULL) {
        return NULL;
    }
    slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
    return slavePtr->masterInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInterpPath --
 *
 *    Sets the result of the asking interpreter to a proper Tcl list
 *    containing the names of interpreters between the asking and
 *    target interpreters. The target interpreter must be either the
 *    same as the asking interpreter or one of its slaves (including
 *    recursively).
 *
 * Results:
 *    TCL_OK if the target interpreter is the same as, or a descendant
 *    of, the asking interpreter; TCL_ERROR else. This way one can
 *    distinguish between the case where the asking and target interps
 *    are the same (an empty list is the result, and TCL_OK is returned)
 *    and when the target is not a descendant of the asking interpreter
 *    (in which case the Tcl result is an error message and the function
 *    returns TCL_ERROR).
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInterpPath(askingInterp, targetInterp)
    Tcl_Interp *askingInterp; /* Interpreter to start search from. */
    Tcl_Interp *targetInterp; /* Interpreter to find. */
{
    InterpInfo *iiPtr;
    
    if (targetInterp == askingInterp) {
        return TCL_OK;
    }
    if (targetInterp == NULL) {
      return TCL_ERROR;
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
        return TCL_ERROR;
    }
    Tcl_AppendElement(askingInterp,
          Tcl_GetHashKey(&iiPtr->master.slaveTable,
                iiPtr->slave.slaveEntryPtr));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --
 *
 *    Helper function to find a slave interpreter given a pathname.
 *
 * Results:
 *    Returns the slave interpreter known by that name in the calling
 *    interpreter, or NULL if no interpreter known by that name exists. 
 *
 * Side effects:
 *    Assigns to the pointer variable passed in, if not NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
GetInterp(interp, pathPtr)
    Tcl_Interp *interp;       /* Interp. to start search from. */
    Tcl_Obj *pathPtr;         /* List object containing name of interp. to 
                         * be found. */
{
    Tcl_HashEntry *hPtr;      /* Search element. */
    Slave *slavePtr;          /* Interim slave record. */
    Tcl_Obj **objv;
    int objc, i;  
    Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
    InterpInfo *masterInfoPtr;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
      return NULL;
    }

    searchInterp = interp;
    for (i = 0; i < objc; i++) {
      masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
        hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
            Tcl_GetString(objv[i]));
        if (hPtr == NULL) {
          searchInterp = NULL;
          break;
      }
        slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
        searchInterp = slavePtr->slaveInterp;
        if (searchInterp == NULL) {
          break;
      }
    }
    if (searchInterp == NULL) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "could not find interpreter \"",
                Tcl_GetString(pathPtr), "\"", (char *) NULL);
    }
    return searchInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCreate --
 *
 *    Helper function to do the actual work of creating a slave interp
 *    and new object command. Also optionally makes the new slave
 *    interpreter "safe".
 *
 * Results:
 *    Returns the new Tcl_Interp * if successful or NULL if not. If failed,
 *    the result of the invoking interpreter contains an error message.
 *
 * Side effects:
 *    Creates a new slave interpreter and a new object command.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
SlaveCreate(interp, pathPtr, safe)
    Tcl_Interp *interp;       /* Interp. to start search from. */
    Tcl_Obj *pathPtr;         /* Path (name) of slave to create. */
    int safe;                 /* Should we make it "safe"? */
{
    Tcl_Interp *masterInterp, *slaveInterp;
    Slave *slavePtr;
    InterpInfo *masterInfoPtr;
    Tcl_HashEntry *hPtr;
    char *path;
    int new, objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
      return NULL;
    }
    if (objc < 2) {
      masterInterp = interp;
      path = Tcl_GetString(pathPtr);
    } else {
      Tcl_Obj *objPtr;
      
      objPtr = Tcl_NewListObj(objc - 1, objv);
      masterInterp = GetInterp(interp, objPtr);
      Tcl_DecrRefCount(objPtr);
      if (masterInterp == NULL) {
          return NULL;
      }
      path = Tcl_GetString(objv[objc - 1]);
    }
    if (safe == 0) {
      safe = Tcl_IsSafe(masterInterp);
    }

    masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
    hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
    if (new == 0) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "interpreter named \"", path,
            "\" already exists, cannot create", (char *) NULL);
        return NULL;
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
            SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
    
    /*
     * Inherit the recursion limit.
     */
    ((Interp *) slaveInterp)->maxNestingDepth =
      ((Interp *) masterInterp)->maxNestingDepth ;

    if (safe) {
        if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
            goto error;
        }
    } else {
        if (Tcl_Init(slaveInterp) == TCL_ERROR) {
            goto error;
        }
      /*
       * This will create the "memory" command in slave interpreters
       * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing.
       */
      Tcl_InitMemory(slaveInterp);
    }
    return slaveInterp;

    error:
    TclTransferResult(slaveInterp, TCL_ERROR, interp);
    Tcl_DeleteInterp(slaveInterp);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmd --
 *
 *    Command to manipulate an interpreter, e.g. to send commands to it
 *    to be evaluated. One such command exists for each slave interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See user documentation for details.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveObjCmd(clientData, interp, objc, objv)
    ClientData clientData;    /* Slave interpreter. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    Tcl_Interp *slaveInterp;
    int index;
    static CONST char *options[] = {
        "alias",  "aliases",  "eval",           "expose",
        "hide",         "hidden",   "issafe",   "invokehidden",
        "marktrusted",  "recursionlimit", NULL
    };
    enum options {
      OPT_ALIAS,  OPT_ALIASES,      OPT_EVAL,   OPT_EXPOSE,
      OPT_HIDE,   OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
      OPT_MARKTRUSTED, OPT_RECLIMIT
    };
    
    slaveInterp = (Tcl_Interp *) clientData;
    if (slaveInterp == NULL) {
      panic("SlaveObjCmd: interpreter has been deleted");
    }

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
          &index) != TCL_OK) {
      return TCL_ERROR;
    }

    switch ((enum options) index) {
      case OPT_ALIAS: {
          if (objc > 2) {
            if (objc == 3) {
                return AliasDescribe(interp, slaveInterp, objv[2]);
            }
            if (Tcl_GetString(objv[3])[0] == '\0') {
                if (objc == 4) {
                  return AliasDelete(interp, slaveInterp, objv[2]);
                }
            } else {
                return AliasCreate(interp, slaveInterp, interp, objv[2],
                      objv[3], objc - 4, objv + 4);
            }
          }
          Tcl_WrongNumArgs(interp, 2, objv,
                "aliasName ?targetName? ?args..?");
            return TCL_ERROR;
      }
      case OPT_ALIASES: {
          if (objc != 2) {
            Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
            return TCL_ERROR;
          }
          return AliasList(interp, slaveInterp);
      }
      case OPT_EVAL: {
          if (objc < 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
            return TCL_ERROR;
          }
          return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
      }
        case OPT_EXPOSE: {
          if ((objc < 3) || (objc > 4)) {
            Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
            return TCL_ERROR;
          }
            return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
      }
      case OPT_HIDE: {
          if ((objc < 3) || (objc > 4)) {
            Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
            return TCL_ERROR;
          }
            return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
      }
        case OPT_HIDDEN: {
          if (objc != 2) {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
            return TCL_ERROR;
          }
            return SlaveHidden(interp, slaveInterp);
      }
        case OPT_ISSAFE: {
          if (objc != 2) {
            Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
            return TCL_ERROR;
          }
          Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
          return TCL_OK;
      }
        case OPT_INVOKEHIDDEN: {
          int global, i, index;
          static CONST char *hiddenOptions[] = {
            "-global",  "--",       NULL
          };
          enum hiddenOption {
            OPT_GLOBAL, OPT_LAST
          };
          global = 0;
          for (i = 2; i < objc; i++) {
            if (Tcl_GetString(objv[i])[0] != '-') {
                break;
            }
            if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
                  "option", 0, &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if (index == OPT_GLOBAL) {
                global = 1;
            } else {
                i++;
                break;
            }
          }
          if (objc - i < 1) {
            Tcl_WrongNumArgs(interp, 2, objv,
                  "?-global? ?--? cmd ?arg ..?");
            return TCL_ERROR;
          }
          return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
                objv + i);
      }
      case OPT_MARKTRUSTED: {
          if (objc != 2) {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
            return TCL_ERROR;
          }
            return SlaveMarkTrusted(interp, slaveInterp);
      }
      case OPT_RECLIMIT: {
          if (objc != 2 && objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
            return TCL_ERROR;
          }
          return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
      }
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmdDeleteProc --
 *
 *    Invoked when an object command for a slave interpreter is deleted;
 *    cleans up all state associated with the slave interpreter and destroys
 *    the slave interpreter.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Cleans up all state associated with the slave interpreter and
 *    destroys the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
SlaveObjCmdDeleteProc(clientData)
    ClientData clientData;          /* The SlaveRecord for the command. */
{
    Slave *slavePtr;                /* Interim storage for Slave record. */
    Tcl_Interp *slaveInterp;        /* And for a slave interp. */

    slaveInterp = (Tcl_Interp *) clientData;
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;

    /*
     * Unlink the slave from its master interpreter.
     */

    Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);

    /*
     * Set to NULL so that when the InterpInfo is cleaned up in the slave
     * it does not try to delete the command causing all sorts of grief.
     * See SlaveRecordDeleteProc().
     */

    slavePtr->interpCmd = NULL;

    if (slavePtr->slaveInterp != NULL) {
      Tcl_DeleteInterp(slavePtr->slaveInterp);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveEval --
 *
 *    Helper function to evaluate a command in a slave interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Whatever the command does.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveEval(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;       /* Interp for error return. */
    Tcl_Interp *slaveInterp;  /* The slave interpreter in which command
                         * will be evaluated. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    int result;
    Tcl_Obj *objPtr;
    
    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (objc == 1) {
      result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
    } else {
      objPtr = Tcl_ConcatObj(objc, objv);
      Tcl_IncrRefCount(objPtr);
      result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
      Tcl_DecrRefCount(objPtr);
    }
    TclTransferResult(slaveInterp, result, interp);

    Tcl_Release((ClientData) slaveInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveExpose --
 *
 *    Helper function to expose a command in a slave interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    After this call scripts in the slave will be able to invoke
 *    the newly exposed command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveExpose(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;       /* Interp for error return. */
    Tcl_Interp    *slaveInterp;     /* Interp in which command will be exposed. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument strings. */
{
    char *name;
    
    if (Tcl_IsSafe(interp)) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "permission denied: safe interpreter cannot expose commands",
            (char *) NULL);
      return TCL_ERROR;
    }

    name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
    if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
          name) != TCL_OK) {
      TclTransferResult(slaveInterp, TCL_ERROR, interp);
      return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveRecursionLimit --
 *
 *    Helper function to set/query the Recursion limit of an interp
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *      When (objc == 1), slaveInterp will be set to a new recursion
 *    limit of objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveRecursionLimit(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;       /* Interp for error return. */
    Tcl_Interp    *slaveInterp;     /* Interp in which limit is set/queried. */
    int objc;                 /* Set or Query. */
    Tcl_Obj *CONST objv[];    /* Argument strings. */
{
    Interp *iPtr;
    int limit;

    if (objc) {
      if (Tcl_IsSafe(interp)) {
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "permission denied: ",
                "safe interpreters cannot change recursion limit",
                (char *) NULL);
          return TCL_ERROR;
      }
      if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
          return TCL_ERROR;
      }
      if (limit <= 0) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "recursion limit must be > 0", -1));
          return TCL_ERROR;
      }
      Tcl_SetRecursionLimit(slaveInterp, limit);
      iPtr = (Interp *) slaveInterp;
      if (interp == slaveInterp && iPtr->numLevels > limit) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "falling back due to new recursion limit", -1));
          return TCL_ERROR;
      }
      Tcl_SetObjResult(interp, objv[0]);
        return TCL_OK;
    } else {
      limit = Tcl_SetRecursionLimit(slaveInterp, 0);
      Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
        return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveHide --
 *
 *    Helper function to hide a command in a slave interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    After this call scripts in the slave will no longer be able
 *    to invoke the named command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveHide(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;       /* Interp for error return. */
    Tcl_Interp    *slaveInterp;     /* Interp in which command will be exposed. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument strings. */
{
    char *name;
    
    if (Tcl_IsSafe(interp)) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "permission denied: safe interpreter cannot hide commands",
            (char *) NULL);
      return TCL_ERROR;
    }

    name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
    if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
          name) != TCL_OK) {
      TclTransferResult(slaveInterp, TCL_ERROR, interp);
      return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveHidden --
 *
 *    Helper function to compute list of hidden commands in a slave
 *    interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveHidden(interp, slaveInterp)
    Tcl_Interp *interp;       /* Interp for data return. */
    Tcl_Interp *slaveInterp;  /* Interp whose hidden commands to query. */
{
    Tcl_Obj *listObjPtr;            /* Local object pointer. */
    Tcl_HashTable *hTblPtr;         /* For local searches. */
    Tcl_HashEntry *hPtr;            /* For local searches. */
    Tcl_HashSearch hSearch;         /* For local searches. */
    
    listObjPtr = Tcl_GetObjResult(interp);
    hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
    if (hTblPtr != (Tcl_HashTable *) NULL) {
      for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
           hPtr != (Tcl_HashEntry *) NULL;
           hPtr = Tcl_NextHashEntry(&hSearch)) {

          Tcl_ListObjAppendElement(NULL, listObjPtr,
                Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
      }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveInvokeHidden --
 *
 *    Helper function to invoke a hidden command in a slave interpreter.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Whatever the hidden command does.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveInvokeHidden(interp, slaveInterp, global, objc, objv)
    Tcl_Interp *interp;       /* Interp for error return. */
    Tcl_Interp *slaveInterp;  /* The slave interpreter in which command
                         * will be invoked. */
    int global;               /* Non-zero to invoke in global namespace. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    int result;
    
    if (Tcl_IsSafe(interp)) {
      Tcl_SetStringObj(Tcl_GetObjResult(interp),
            "not allowed to invoke hidden commands from safe interpreter",
            -1);
      return TCL_ERROR;
    }

    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);
    
    if (global) {
        result = TclObjInvokeGlobal(slaveInterp, objc, objv,
                TCL_INVOKE_HIDDEN);
    } else {
        result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
    }

    TclTransferResult(slaveInterp, result, interp);

    Tcl_Release((ClientData) slaveInterp);
    return result;        
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveMarkTrusted --
 *
 *    Helper function to mark a slave interpreter as trusted (unsafe).
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    After this call the hard-wired security checks in the core no
 *    longer prevent the slave from performing certain operations.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveMarkTrusted(interp, slaveInterp)
    Tcl_Interp *interp;       /* Interp for error return. */
    Tcl_Interp *slaveInterp;  /* The slave interpreter which will be
                         * marked trusted. */
{
    if (Tcl_IsSafe(interp)) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "permission denied: safe interpreter cannot mark trusted",
            (char *) NULL);
      return TCL_ERROR;
    }
    ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsSafe --
 *
 *    Determines whether an interpreter is safe
 *
 * Results:
 *    1 if it is safe, 0 if it is not.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsSafe(interp)
    Tcl_Interp *interp;       /* Is this interpreter "safe" ? */
{
    Interp *iPtr;

    if (interp == (Tcl_Interp *) NULL) {
        return 0;
    }
    iPtr = (Interp *) interp;

    return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeSafe --
 *
 *    Makes its argument interpreter contain only functionality that is
 *    defined to be part of Safe Tcl. Unsafe commands are hidden, the
 *    env array is unset, and the standard channels are removed.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Hides commands in its argument interpreter, and removes settings
 *    and channels.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MakeSafe(interp)
    Tcl_Interp *interp;       /* Interpreter to be made safe. */
{
    Tcl_Channel chan;                     /* Channel to remove from
                                                 * safe interpreter. */
    Interp *iPtr = (Interp *) interp;

    TclHideUnsafeCommands(interp);
    
    iPtr->flags |= SAFE_INTERP;

    /*
     *  Unsetting variables : (which should not have been set 
     *  in the first place, but...)
     */

    /*
     * No env array in a safe slave.
     */

    Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);

    /* 
     * Remove unsafe parts of tcl_platform
     */

    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);

    /*
     * Unset path informations variables
     * (the only one remaining is [info nameofexecutable])
     */

    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
    
    /*
     * Remove the standard channels from the interpreter; safe interpreters
     * do not ordinarily have access to stdin, stdout and stderr.
     *
     * NOTE: These channels are not added to the interpreter by the
     * Tcl_CreateInterp call, but may be added later, by another I/O
     * operation. We want to ensure that the interpreter does not have
     * these channels even if it is being made safe after being used for
     * some time..
     */

    chan = Tcl_GetStdChannel(TCL_STDIN);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDOUT);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDERR);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }

    return TCL_OK;
}

Generated by  Doxygen 1.6.0   Back to index