WebSVN - Open64 - Blame - Rev 2072 - /sim/fsim/shell/tclsh/generic/tclInterp.c

[/] [sim/] [fsim/] [shell/] [tclsh/] [generic/] [tclInterp.c] - Blame information for rev 2072

Details | Compare with Previous | View Log

/*
 * 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;
}
Line No.	Rev	Author	Line
1	2072	malin	`/*`
2			`* tclInterp.c --`
3			`*`
4			`* This file implements the "interp" command which allows creation`
5			`* and manipulation of Tcl interpreters from within Tcl scripts.`
6			`*`
7			`* Copyright (c) 1995-1997 Sun Microsystems, Inc.`
8			`*`
9			`* See the file "license.terms" for information on usage and redistribution`
10			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
11			`*`
12			`* RCS: @(#) $Id: tclInterp.c,v 1.20.2.2 2003/05/12 22:35:40 dgp Exp $`
13			`*/`
14
15			`#include "tclInt.h"`
16			`#include "tclPort.h"`
17			`#include <stdio.h>`
18
19			`/*`
20			`* Counter for how many aliases were created (global)`
21			`*/`
22
23			`static int aliasCounter = 0;`
24			`TCL_DECLARE_MUTEX(cntMutex)`
25
26			`/*`
27			`* struct Alias:`
28			`*`
29			`* Stores information about an alias. Is stored in the slave interpreter`
30			`* and used by the source command to find the target command in the master`
31			`* when the source command is invoked.`
32			`*/`
33
34			`typedef struct Alias {`
35			`Tcl_Obj namePtr; / Name of alias command in slave interp. */`
36			`Tcl_Interp targetInterp; / Interp in which target command will be`
37			`* invoked. */`
38			`Tcl_Command slaveCmd; /* Source command in slave interpreter,`
39			`* bound to command that invokes the target`
40			`* command in the target interpreter. */`
Subversion Repositories Open64

[/] [sim/] [fsim/] [shell/] [tclsh/] [generic/] [tclInterp.c] - Blame information for rev 2072
