path: root/generic/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.
 * Copyright (c) 2004 Donal K. Fellows
 *
 * 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.52 2004/11/22 21:24:30 dgp Exp $
 */

#include "tclInt.h"
#include <stdio.h>

/*
 * In order to find init.tcl during initialization, the following script
 * is invoked by Tcl_Init().  It looks in several different directories:
 *
 *	$tcl_library		- can specify a primary location, if set,
 *				  no other locations will be checked.  This
 *				  is the recommended way for a program that
 *				  embeds Tcl to specifically tell Tcl where
 *				  to find an init.tcl file.
 *
 *	$env(TCL_LIBRARY)	- highest priority so user can always override
 *				  the search path unless the application has
 *				  specified an exact directory above
 *
 *	$tclDefaultLibrary	- INTERNAL:  This variable is set by Tcl
 *				  on those platforms where it can determine
 *				  at runtime the directory where it expects
 *				  the init.tcl file to be.  After [tclInit]
 *				  reads and uses this value, it [unset]s it.
 *				  External users of Tcl should not make use
 *				  of the variable to customize [tclInit].
 *
 *	$tcl_libPath		- OBSOLETE:  This variable is no longer
 *				  set by Tcl itself, but [tclInit] examines
 *				  it in case some program that embeds Tcl
 *				  is customizing [tclInit] by setting this
 *				  variable to a list of directories in which
 *				  to search.
 *
 *      [tcl::pkgconfig get scriptdir,runtime]
 *      			- the directory determined by configure to 
 *      			  be the place where Tcl's script library
 *      			  is to be installed. 
 *
 * The first directory on this path that contains a valid init.tcl script
 * will be set as the value of tcl_library.
 *
 * Note that this entire search mechanism can be bypassed by defining an
 * alternate tclInit procedure before calling Tcl_Init().
 */

static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
  proc tclInit {} {\n\
    global tcl_libPath tcl_library\n\
    global env tclDefaultLibrary\n\
    variable ::tcl::LibPath\n\
    rename tclInit {}\n\
    set errors {}\n\
    set LibPath {}\n\
    if {[info exists tcl_library]} {\n\
	lappend LibPath $tcl_library\n\
    } else {\n\
	if {[info exists env(TCL_LIBRARY)]} {\n\
	    lappend LibPath $env(TCL_LIBRARY)\n\
	    if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n\
		if {$tail ne [info tclversion]} {\n\
		    lappend LibPath [file join [file dirname\\\n\
			    $env(TCL_LIBRARY)] tcl[info tclversion]]\n\
		}\n\
	    }\n\
	}\n\
	if {[catch {\n\
	    lappend LibPath $tclDefaultLibrary\n\
	    unset tclDefaultLibrary\n\
	}]} {\n\
	    lappend LibPath [::tcl::pkgconfig get scriptdir,runtime]\n\
	}\n\
	set parentDir [file normalize [file dirname [file dirname\\\n\
		[info nameofexecutable]]]]\n\
	set grandParentDir [file dirname $parentDir]\n\
	lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n\
	lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n\
	lappend LibPath [file join $parentDir library]\n\
	lappend LibPath [file join $grandParentDir library]\n\
	lappend LibPath [file join $grandParentDir\\\n\
       		tcl[info patchlevel] library]\n\
	lappend LibPath [file join [file dirname $grandParentDir]\\\n\
       		tcl[info patchlevel] library]\n\
	catch {\n\
            set LibPath [concat $LibPath $tcl_libPath]\n\
	}\n\
    }\n\
    foreach i $LibPath {\n\
	set tcl_library $i\n\
	set tclfile [file join $i init.tcl]\n\
	if {[file exists $tclfile]} {\n\
	    if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n\
		return\n\
	    } else {\n\
		append errors \"$tclfile: $msg\n\"\n\
		append errors \"[dict get $opts -errorinfo]\n\"\n\
	    }\n\
	}\n\
    }\n\
    set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
    append msg \"    $LibPath\n\n\"\n\
    append msg \"$errors\n\n\"\n\
    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
    error $msg\n\
  }\n\
}\n\
tclInit";

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script
 * above.  This variable can be modified by the procedure below.
 */
 
static char *          tclPreInitScript = NULL;


/*
 * 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 *token;		/* Token for the alias command in the slave
				 * interp. This used to be the command name
				 * in the slave when the alias was first
				 * created. */
    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;

/*
 * Limit callbacks handled by scripts are modelled as structures which
 * are stored in hashes indexed by a two-word key.  Note that the type
 * of the 'type' field in the key is not int; this is to make sure
 * that things are likely to work properly on 64-bit architectures.
 */

struct ScriptLimitCallback {
    Tcl_Interp *interp;
    Tcl_Obj *scriptObj;
    int type;
    Tcl_HashEntry *entryPtr;
};

struct ScriptLimitCallbackKey {
    Tcl_Interp *interp;
    long type;
};

/*
 * 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 int		SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
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,
			    CONST char *namespaceName, 
			    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[]));
static int		SlaveCommandLimitCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int consumedObjc,
			    int objc, Tcl_Obj *CONST objv[]));
static int		SlaveTimeLimitCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int consumedObjc,
			    int objc, Tcl_Obj *CONST objv[]));
static void		InheritLimitsFromMaster _ANSI_ARGS_((
			    Tcl_Interp *slaveInterp,
			    Tcl_Interp *masterInterp));
static void		SetScriptLimitCallback _ANSI_ARGS_((Tcl_Interp *interp,
			    int type, Tcl_Interp *targetInterp,
			    Tcl_Obj *scriptObj));
static void		CallScriptLimitCallback _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static void		DeleteScriptLimitCallback _ANSI_ARGS_((
			    ClientData clientData));
static void		RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr,
			    Tcl_Interp *interp));


/*
 *----------------------------------------------------------------------
 *
 * TclSetPreInitScript --
 *
 *	This routine is used to change the value of the internal
 *	variable, tclPreInitScript.
 *
 * Results:
 *	Returns the current value of tclPreInitScript.
 *
 * Side effects:
 *	Changes the way Tcl_Init() routine behaves.
 *
 *----------------------------------------------------------------------
 */

char *
TclSetPreInitScript (string)
    char *string;		/* Pointer to a script. */
{
    char *prevString = tclPreInitScript;
    tclPreInitScript = string;
    return(prevString);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *      This procedure is typically invoked by Tcl_AppInit procedures
 *      to find and source the "init.tcl" script, which should exist
 *      somewhere on the Tcl library path.
 *
 * Results:
 *      Returns a standard Tcl completion code and sets the interp's
 *      result if there is an error.
 *
 * Side effects:
 *      Depends on what's in the init.tcl script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Init(interp)
    Tcl_Interp *interp;         /* Interpreter to initialize. */
{
    if (tclPreInitScript != NULL) {
	if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
	    return (TCL_ERROR);
	};
    }
    return Tcl_Eval(interp, initScript);
}

/*
 *---------------------------------------------------------------------------
 *
 * 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) {
	Tcl_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) {
	Tcl_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",	"bgerror",	"create",
	"delete",	"eval",		"exists",	"expose",
	"hide",		"hidden",	"issafe",	"invokehidden",
	"limit",	"marktrusted",	"recursionlimit","slaves",
	"share",	"target",	"transfer",
        NULL
    };
    enum option {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_CREATE,
	OPT_DELETE,	OPT_EVAL,	OPT_EXISTS,	OPT_EXPOSE,
	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,	OPT_INVOKEHID,
	OPT_LIMIT,	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_BGERROR: {
	    Tcl_Interp *slaveInterp;

	    if (objc != 3 && objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
	}
	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_SetObjResult(interp, Tcl_NewStringObj(
			    "cannot delete the current interpreter", -1));
		    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_SetObjResult(interp, Tcl_NewBooleanObj(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_SetObjResult(interp,
		    Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	    return TCL_OK;
	}
	case OPT_INVOKEHID: {
	    int i, index;
	    CONST char *namespaceName;
	    Tcl_Interp *slaveInterp;
	    static CONST char *hiddenOptions[] = {
		"-global",	"-namespace",	"--",		NULL
	    };
	    enum hiddenOption {
		OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	    };

	    namespaceName = NULL;
	    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) {
		    namespaceName = "::";
		} else {
		    if (index == OPT_NAMESPACE) {
			if (++i == objc) { /* There must be more arguments. */
		            break;
			} else {
		            namespaceName = Tcl_GetString(objv[i]);
			}
		    } else {
			i++;
			break;
		    }
		}
	    }
	    if (objc - i < 1) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
		    objc - i, objv + i);
	}
	case OPT_LIMIT: {
	    Tcl_Interp *slaveInterp;
	    static CONST char *limitTypes[] = {
		"commands", "time", NULL
	    };
	    enum LimitTypes {
		LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
	    };
	    int limitType;

	    if (objc < 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type",
		    0, &limitType) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum LimitTypes) limitType) {
	    case LIMIT_TYPE_COMMANDS:
		return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
	    case LIMIT_TYPE_TIME:
		return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
	    }
	}
	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_NewObj();
	    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));
	    }
	    Tcl_SetObjResult(interp, resultPtr);
	    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_AppendResult(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_AppendResult(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_AppendResult(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_AppendResult(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_AppendResult(interp, "cannot define or rename alias \"",
		    Tcl_GetCommandName(cmdInterp, cmd),
		    "\": 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_AppendResult(interp, "cannot define or rename alias \"",
		    Tcl_GetCommandName(cmdInterp, cmd),
		    "\": 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->token		= namePtr;
    Tcl_IncrRefCount(aliasPtr->token);
    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->token);
	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, retry.
     */

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

	/*
	 * The alias name cannot be used as unique token, it is already
	 * taken. We can produce a unique token by prepending "::"
	 * repeatedly. This algorithm is a stop-gap to try to maintain
	 * the command name as token for most use cases, fearful of
	 * possible backwards compat problems. A better algorithm would
	 * produce unique tokens that need not be related to the command
	 * name.
	 *
	 * ATTENTION: the tests in interp.test and possibly safe.test
	 * depend on the precise definition of these tokens.
	 */
	
	newToken = Tcl_NewStringObj("::",-1);
	Tcl_AppendObjToObj(newToken, aliasPtr->token);
	Tcl_DecrRefCount(aliasPtr->token);
	aliasPtr->token = newToken;
	Tcl_IncrRefCount(aliasPtr->token);
    }

    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, aliasPtr->token);

    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_AppendResult(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 = Tcl_NewObj();
    Alias *aliasPtr;
    Slave *slavePtr;

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

    entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
    for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
        aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
        Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
    }
    Tcl_SetObjResult(interp, resultPtr);
    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->token);
    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_AppendResult(interp, "could not find interpreter \"",
                Tcl_GetString(pathPtr), "\"", (char *) NULL);
    }
    return searchInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveBgerror --
 *
 *	Helper function to set/query the background error handling
 *	command prefix of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *      When (objc == 1), slaveInterp will be set to a new background
 *	handler of objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveBgerror(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. */
{
    if (objc) {
	int length;

	if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) 
		|| (length < 1)) {
	    Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	TclSetBgErrorHandler(interp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
    Tcl_Obj* clockObj;
    int status;

    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_AppendResult(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);
    }

    /*
     * Inherit the TIP#143 limits.
     */
    InheritLimitsFromMaster(slaveInterp, masterInterp);

    if ( safe ) {
	clockObj = Tcl_NewStringObj( "clock", -1 );
	Tcl_IncrRefCount( clockObj );
	status = AliasCreate( interp, slaveInterp, masterInterp,
			      clockObj, clockObj, 0, (Tcl_Obj *CONST *) NULL );
	Tcl_DecrRefCount( clockObj );
	if ( status != TCL_OK ) {
	    goto error2;
	}
    }
    

    return slaveInterp;

 error:
    TclTransferResult(slaveInterp, TCL_ERROR, interp);
 error2:
    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",	"bgerror",	"eval",
	"expose",	"hide",		"hidden",	"issafe",
	"invokehidden",	"limit",	"marktrusted",	"recursionlimit", NULL
    };
    enum options {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_EVAL,
	OPT_EXPOSE,	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,
	OPT_INVOKEHIDDEN, OPT_LIMIT,	OPT_MARKTRUSTED, OPT_RECLIMIT
    };
    
    slaveInterp = (Tcl_Interp *) clientData;
    if (slaveInterp == NULL) {
	Tcl_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_BGERROR: {
	    if (objc != 2 && objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
		return TCL_ERROR;
	    }
	    return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
	}
	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_SetObjResult(interp,
		    Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	    return TCL_OK;
	}
        case OPT_INVOKEHIDDEN: {
	    int i, index;
	    CONST char *namespaceName;
	    static CONST char *hiddenOptions[] = {
		"-global",	"-namespace",	"--",		NULL
	    };
	    enum hiddenOption {
		OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	    };

	    namespaceName = NULL;
	    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) {
		    namespaceName = "::";
		} else {
		    if (index == OPT_NAMESPACE) {
			if (++i == objc) { /* There must be more arguments. */
		            break;
			} else {
		            namespaceName = Tcl_GetString(objv[i]);
			}
		    } else {
			i++;
			break;
		    }
		}
	    }
	    if (objc - i < 1) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"?-namespace ns? ?-global? ?--? cmd ?arg ..?");
		return TCL_ERROR;
	    }
	    return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
		    objc - i, objv + i);
	}
	case OPT_LIMIT: {
	    static CONST char *limitTypes[] = {
		"commands", "time", NULL
	    };
	    enum LimitTypes {
		LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
	    };
	    int limitType;

	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?");
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type",
		    0, &limitType) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum LimitTypes) limitType) {
	    case LIMIT_TYPE_COMMANDS:
		return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
	    case LIMIT_TYPE_TIME:
		return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
	    }
	}
	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_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot expose commands",
		-1));
	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_AppendResult(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_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot hide commands",
		-1));
	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 = Tcl_NewObj();	/* Local object pointer. */
    Tcl_HashTable *hTblPtr;		/* For local searches. */
    Tcl_HashEntry *hPtr;		/* For local searches. */
    Tcl_HashSearch hSearch;		/* For local searches. */
    
    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));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    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, namespaceName, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp *slaveInterp;	/* The slave interpreter in which command
				 * will be invoked. */
    CONST char *namespaceName;	/* The namespace to use, if any. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result;
    
    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"not allowed to invoke hidden commands from safe interpreter",
		-1));
	return TCL_ERROR;
    }

    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);
    
    if (namespaceName == NULL) {
        result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
    } else {
	Namespace *nsPtr, *dummy1, *dummy2;
	CONST char *tail;

	result = TclGetNamespaceForQualName(slaveInterp, namespaceName,
		(Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY 
		| TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr,
		&dummy1, &dummy2, &tail);
	if (result == TCL_OK) {
	    result = TclObjInvokeNamespace(slaveInterp, objc, objv,
		    (Tcl_Namespace *)nsPtr, 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_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot mark trusted",
		-1));
	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;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitExceeded --
 *
 *	Tests whether any limit has been exceededin the given
 *	interpreter (i.e. whether the interpreter is currently unable
 *	to process further scripts).
 *
 * Results:
 *	A boolean value.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitExceeded(interp)
    Tcl_Interp *interp;
{
    register Interp *iPtr = (Interp *) interp;

    return iPtr->limit.exceeded != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitReady --
 *
 *	Find out whether any limit has been set on the interpreter,
 *	and if so check whether the granularity of that limit is such
 *	that the full limit check should be carried out.
 *
 * Results:
 *	A boolean value that indicates whether to call Tcl_LimitCheck.
 *
 * Side effects:
 *	Increments the limit granularity counter.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitReady(interp)
    Tcl_Interp *interp;
{
    register Interp *iPtr = (Interp *) interp;

    if (iPtr->limit.active != 0) {
	register int ticker = ++iPtr->limit.granularityTicker;

	if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
		((iPtr->limit.cmdGranularity == 1) ||
			(ticker % iPtr->limit.cmdGranularity == 0))) {
	    return 1;
	}
	if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
		((iPtr->limit.timeGranularity == 1) ||
			(ticker % iPtr->limit.timeGranularity == 0))) {
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitCheck --
 *
 *	Check all currently set limits in the interpreter (where
 *	permitted by granularity).  If a limit is exceeded, call its
 *	callbacks and, if the limit is still exceeded after the
 *	callbacks have run, make the interpreter generate an error
 *	that cannot be caught within the limited interpreter.
 *
 * Results:
 *	A Tcl result value (TCL_OK if no limit is exceeded, and
 *	TCL_ERROR if a limit has been exceeded).
 *
 * Side effects:
 *	May invoke system calls.  May invoke other interpreters.  May
 *	be reentrant.  May put the interpreter into a state where it
 *	can no longer execute commands without outside intervention.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitCheck(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;
    register int ticker = iPtr->limit.granularityTicker;

    if (Tcl_InterpDeleted(interp)) {
	return TCL_OK;
    }

    if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
	    ((iPtr->limit.cmdGranularity == 1) ||
		    (ticker % iPtr->limit.cmdGranularity == 0)) &&
	    (iPtr->limit.cmdCount < iPtr->cmdCount)) {
	iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS;
	Tcl_Preserve(interp);
	RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
	if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
	    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
	} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "command count limit exceeded", NULL);
	    Tcl_Release(interp);
	    return TCL_ERROR;
	}
	Tcl_Release(interp);
    }

    if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
	    ((iPtr->limit.timeGranularity == 1) ||
		    (ticker % iPtr->limit.timeGranularity == 0))) {
	Tcl_Time now;

	Tcl_GetTime(&now);
	if (iPtr->limit.time.sec < now.sec ||
		(iPtr->limit.time.sec == now.sec &&
		iPtr->limit.time.usec < now.usec)) {
	    iPtr->limit.exceeded |= TCL_LIMIT_TIME;
	    Tcl_Preserve(interp);
	    RunLimitHandlers(iPtr->limit.timeHandlers, interp);
	    if (iPtr->limit.time.sec >= now.sec ||
		    (iPtr->limit.time.sec == now.sec &&
		    iPtr->limit.time.usec >= now.usec)) {
		iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
	    } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "time limit exceeded", NULL);
		Tcl_Release(interp);
		return TCL_ERROR;
	    }
	    Tcl_Release(interp);
	}
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * RunLimitHandlers --
 *
 *	Invoke all the limit handlers in a list (for a particular
 *	limit).  Note that no particular limit handler callback will
 *	be invoked reentrantly.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the limit handlers.
 *
 *----------------------------------------------------------------------
 */

static void
RunLimitHandlers(handlerPtr, interp)
    LimitHandler *handlerPtr;
    Tcl_Interp *interp;
{
    LimitHandler *nextPtr;
    for (; handlerPtr!=NULL ; handlerPtr=nextPtr) {
	if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) {
	    /*
	     * Reentrant call or something seriously strange in the
	     * delete code.
	     */
	    nextPtr = handlerPtr->nextPtr;
	    continue;
	}

	/*
	 * Set the ACTIVE flag while running the limit handler itself
	 * so we cannot reentrantly call this handler and know to use
	 * the alternate method of deletion if necessary.
	 */

	handlerPtr->flags |= LIMIT_HANDLER_ACTIVE;
	(handlerPtr->handlerProc)(handlerPtr->clientData, interp);
	handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE;

	/*
	 * Rediscover this value; it might have changed during the
	 * processing of a limit handler.  We have to record it here
	 * because we might delete the structure below, and reading a
	 * value out of a deleted structure is unsafe (even if
	 * actually legal with some malloc()/free() implementations.)
	 */

	nextPtr = handlerPtr->nextPtr;

	/*
	 * If we deleted the current handler while we were executing
	 * it, we will have spliced it out of the list and set the
	 * LIMIT_HANDLER_DELETED flag.
	 */
	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitAddHandler --
 *
 *	Add a callback handler for a particular resource limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Extends the internal linked list of handlers for a limit.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc)
    Tcl_Interp *interp;
    int type;
    Tcl_LimitHandlerProc *handlerProc;
    ClientData clientData;
    Tcl_LimitHandlerDeleteProc *deleteProc;
{
    Interp *iPtr = (Interp *) interp;
    LimitHandler *handlerPtr;

    /*
     * Convert everything into a real deletion callback.
     */

    if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
	deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
    }
    if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) {
	deleteProc = (Tcl_LimitHandlerDeleteProc *) NULL;
    }

    /*
     * Allocate a handler record.
     */

    handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler));
    handlerPtr->flags = 0;
    handlerPtr->handlerProc = handlerProc;
    handlerPtr->clientData = clientData;
    handlerPtr->deleteProc = deleteProc;
    handlerPtr->prevPtr = NULL;

    /*
     * Prepend onto the front of the correct linked list.
     */

    switch (type) {
    case TCL_LIMIT_COMMANDS:
	handlerPtr->nextPtr = iPtr->limit.cmdHandlers;
	if (handlerPtr->nextPtr != NULL) {
	    handlerPtr->nextPtr->prevPtr = handlerPtr;
	}
	iPtr->limit.cmdHandlers = handlerPtr;
	return;

    case TCL_LIMIT_TIME:
	handlerPtr->nextPtr = iPtr->limit.timeHandlers;
	if (handlerPtr->nextPtr != NULL) {
	    handlerPtr->nextPtr->prevPtr = handlerPtr;
	}
	iPtr->limit.timeHandlers = handlerPtr;
	return;
    }

    Tcl_Panic("unknown type of resource limit");
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitRemoveHandler --
 *
 *	Remove a callback handler for a particular resource limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The handler is spliced out of the internal linked list for the
 *	limit, and if not currently being invoked, deleted.  Otherwise
 *	it is just marked for deletion and removed when the limit
 *	handler has finished executing.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData)
    Tcl_Interp *interp;
    int type;
    Tcl_LimitHandlerProc *handlerProc;
    ClientData clientData;
{
    Interp *iPtr = (Interp *) interp;
    LimitHandler *handlerPtr;

    switch (type) {
    case TCL_LIMIT_COMMANDS:
	handlerPtr = iPtr->limit.cmdHandlers;
	break;
    case TCL_LIMIT_TIME:
	handlerPtr = iPtr->limit.timeHandlers;
	break;
    default:
	Tcl_Panic("unknown type of resource limit");
	return;
    }

    for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) {
	if ((handlerPtr->handlerProc != handlerProc) ||
		(handlerPtr->clientData != clientData)) {
	    continue;
	}

	/*
	 * We've found the handler to delete; mark it as doomed if not
	 * already so marked (which shouldn't actually happen).
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    return;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;

	/*
	 * Splice the handler out of the doubly-linked list.
	 */

	if (handlerPtr->prevPtr == NULL) {
	    switch (type) {
	    case TCL_LIMIT_COMMANDS:
		iPtr->limit.cmdHandlers = handlerPtr->nextPtr;
		break;
	    case TCL_LIMIT_TIME:
		iPtr->limit.timeHandlers = handlerPtr->nextPtr;
		break;
	    }
	} else {
	    handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr;
	}
	if (handlerPtr->nextPtr != NULL) {
	    handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr;
	}

	/*
	 * If nothing is currently executing the handler, delete its
	 * client data and the overall handler structure now.
	 * Otherwise it will all go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
	return;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclLimitRemoveAllHandlers --
 *
 *	Remove all limit callback handlers for an interpreter.  This
 *	is invoked as part of deleting the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Limit handlers are deleted or marked for deletion (as with
 *	Tcl_LimitRemoveHandler).
 *
 *----------------------------------------------------------------------
 */

void
TclLimitRemoveAllHandlers(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;
    LimitHandler *handlerPtr, *nextHandlerPtr;

    /*
     * Delete all command-limit handlers.
     */

    for (handlerPtr=iPtr->limit.cmdHandlers, iPtr->limit.cmdHandlers=NULL;
	    handlerPtr!=NULL; handlerPtr=nextHandlerPtr) {
	nextHandlerPtr = handlerPtr->nextPtr;

	/*
	 * Do not delete here if it has already been marked for deletion.
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    continue;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;
	handlerPtr->prevPtr = NULL;
	handlerPtr->nextPtr = NULL;

	/*
	 * If nothing is currently executing the handler, delete its
	 * client data and the overall handler structure now.
	 * Otherwise it will all go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }

    /*
     * Delete all time-limit handlers.
     */

    for (handlerPtr=iPtr->limit.timeHandlers, iPtr->limit.timeHandlers=NULL;
	    handlerPtr!=NULL; handlerPtr=nextHandlerPtr) {
	nextHandlerPtr = handlerPtr->nextPtr;

	/*
	 * Do not delete here if it has already been marked for deletion.
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    continue;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;
	handlerPtr->prevPtr = NULL;
	handlerPtr->nextPtr = NULL;

	/*
	 * If nothing is currently executing the handler, delete its
	 * client data and the overall handler structure now.
	 * Otherwise it will all go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeEnabled --
 *
 *	Check whether a particular limit has been enabled for an
 *	interpreter.
 *
 * Results:
 *	A boolean value.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitTypeEnabled(interp, type)
    Tcl_Interp *interp;
    int type;
{
    Interp *iPtr = (Interp *) interp;

    return (iPtr->limit.active & type) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeExceeded --
 *
 *	Check whether a particular limit has been exceeded for an
 *	interpreter.
 *
 * Results:
 *	A boolean value (note that Tcl_LimitExceeded will always
 *	return non-zero when this function returns non-zero).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitTypeExceeded(interp, type)
    Tcl_Interp *interp;
    int type;
{
    Interp *iPtr = (Interp *) interp;

    return (iPtr->limit.exceeded & type) != 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeSet --
 *
 *	Enable a particular limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The limit is turned on and will be checked in future at an
 *	interval determined by the frequency of calling of
 *	Tcl_LimitReady and the granularity of the limit in question.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitTypeSet(interp, type)
    Tcl_Interp *interp;
    int type;
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.active |= type;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeReset --
 *
 *	Disable a particular limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The limit is disabled.  If the limit was exceeded when this
 *	function was called, the limit will no longer be exceeded
 *	afterwards and the interpreter will be free to execute further
 *	scripts (assuming it isn't also deleted, of course).
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitTypeReset(interp, type)
    Tcl_Interp *interp;
    int type;
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.active &= ~type;
    iPtr->limit.exceeded &= ~type;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetCommands --
 *
 *	Set the command limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Also resets whether the command limit was exceeded.  This
 *	might permit a small amount of further execution in the
 *	interpreter even if the limit itself is theoretically
 *	exceeded.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetCommands(interp, commandLimit)
    Tcl_Interp *interp;
    int commandLimit;
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.cmdCount = commandLimit;
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetCommands --
 *
 *	Get the number of commands that may be executed in the
 *	interpreter before the command-limit is reached.
 *
 * Results:
 *	An upper bound on the number of commands.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitGetCommands(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;

    return iPtr->limit.cmdCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetTime --
 *
 *	Set the time limit for an interpreter by copying it from the
 *	value pointed to by the timeLimitPtr argument.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Also resets whether the time limit was exceeded.  This might
 *	permit a small amount of further execution in the interpreter
 *	even if the limit itself is theoretically exceeded.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetTime(interp, timeLimitPtr)
    Tcl_Interp *interp;
    Tcl_Time *timeLimitPtr;
{
    Interp *iPtr = (Interp *) interp;

    memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time));
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetTime --
 *
 *	Get the current time limit.
 *
 * Results:
 *	The time limit (by it being copied into the variable pointed
 *	to by the timeLimitPtr).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitGetTime(interp, timeLimitPtr)
    Tcl_Interp *interp;
    Tcl_Time *timeLimitPtr;
{
    Interp *iPtr = (Interp *) interp;

    memcpy(timeLimitPtr, &iPtr->limit.time, sizeof(Tcl_Time));
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetGranularity --
 *
 *	Set the granularity divisor (which must be positive) for a
 *	particular limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The granularity is updated.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetGranularity(interp, type, granularity)
    Tcl_Interp *interp;
    int type;
    int granularity;
{
    Interp *iPtr = (Interp *) interp;
    if (granularity < 1) {
	Tcl_Panic("limit granularity must be positive");
    }

    switch (type) {
    case TCL_LIMIT_COMMANDS:
	iPtr->limit.cmdGranularity = granularity;
	return;
    case TCL_LIMIT_TIME:
	iPtr->limit.timeGranularity = granularity;
	return;
    }
    Tcl_Panic("unknown type of resource limit");
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetGranularity --
 *
 *	Get the granularity divisor for a particular limit.
 *
 * Results:
 *	The granularity divisor for the given limit.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitGetGranularity(interp, type)
    Tcl_Interp *interp;
    int type;
{
    Interp *iPtr = (Interp *) interp;

    switch (type) {
    case TCL_LIMIT_COMMANDS:
	return iPtr->limit.cmdGranularity;
    case TCL_LIMIT_TIME:
	return iPtr->limit.timeGranularity;
    }
    Tcl_Panic("unknown type of resource limit");
    return -1; /* NOT REACHED */
}    

/*
 *----------------------------------------------------------------------
 *
 * DeleteScriptLimitCallback --
 *
 *	Callback for when a script limit (a limit callback implemented
 *	as a Tcl script in a master interpreter, as set up from Tcl)
 *	is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference to the script callback from the controlling
 *	interpreter is removed.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScriptLimitCallback(clientData)
    ClientData clientData;
{
    struct ScriptLimitCallback *limitCBPtr =
	    (struct ScriptLimitCallback *) clientData;

    Tcl_DecrRefCount(limitCBPtr->scriptObj);
    Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
    ckfree((char *) limitCBPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * CallScriptLimitCallback --
 *
 *	Invoke a script limit callback.  Used to implement limit
 *	callbacks set at the Tcl level on child interpreters.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the callback script.  Errors are reported as
 *	background errors.
 *
 *----------------------------------------------------------------------
 */

static void
CallScriptLimitCallback(clientData, interp)
    ClientData clientData;
    Tcl_Interp *interp;		/* Interpreter which failed the limit */
{
    struct ScriptLimitCallback *limitCBPtr =
	    (struct ScriptLimitCallback *) clientData;
    int code;

    if (Tcl_InterpDeleted(limitCBPtr->interp)) {
	return;
    }
    Tcl_Preserve(limitCBPtr->interp);
    code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj,
	    TCL_EVAL_GLOBAL);
    if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) {
	Tcl_BackgroundError(limitCBPtr->interp);
    }
    Tcl_Release(limitCBPtr->interp);
}

/*
 *----------------------------------------------------------------------
 *
 * SetScriptLimitCallback --
 *
 *	Install (or remove, if scriptObj is NULL) a limit callback
 *	script that is called when the target interpreter exceeds the
 *	type of limit specified.  Each interpreter may only have one
 *	callback set on another interpreter through this mechanism
 *	(though as many interpreters may be limited as the programmer
 *	chooses overall).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A limit callback implemented as an invokation of a Tcl script
 *	in another interpreter is either installed or removed.
 *
 *----------------------------------------------------------------------
 */

static void
SetScriptLimitCallback(interp, type, targetInterp, scriptObj)
    Tcl_Interp *interp;
    int type;
    Tcl_Interp *targetInterp;
    Tcl_Obj *scriptObj;
{
    struct ScriptLimitCallback *limitCBPtr;
    Tcl_HashEntry *hashPtr;
    int isNew;
    struct ScriptLimitCallbackKey key;
    Interp *iPtr = (Interp *) interp;

    if (interp == targetInterp) {
	Tcl_Panic("installing limit callback to the limited interpreter");
    }

    key.interp = targetInterp;
    key.type = type;

    if (scriptObj == NULL) {
	hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
	if (hashPtr != NULL) {
	    Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
		    Tcl_GetHashValue(hashPtr));
	}
	return;
    }

    hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key,
	    &isNew);
    if (!isNew) {
	Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
		Tcl_GetHashValue(hashPtr));
    }

    limitCBPtr = (struct ScriptLimitCallback *)
	    ckalloc(sizeof(struct ScriptLimitCallback));
    limitCBPtr->interp = interp;
    limitCBPtr->scriptObj = scriptObj;
    limitCBPtr->entryPtr = hashPtr;
    limitCBPtr->type = type;
    Tcl_IncrRefCount(scriptObj);

    Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback,
	    (ClientData) limitCBPtr, DeleteScriptLimitCallback);
    Tcl_SetHashValue(hashPtr, (ClientData) limitCBPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclRemoveScriptLimitCallbacks --
 *
 *	Remove all script-implemented limit callbacks that make calls
 *	back into the given interpreter.  This invoked as part of
 *	deleting an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The script limit callbacks are removed or marked for later
 *	removal.
 *
 *----------------------------------------------------------------------
 */

void
TclRemoveScriptLimitCallbacks(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hashPtr;
    Tcl_HashSearch search;
    struct ScriptLimitCallbackKey *keyPtr;

    hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search);
    while (hashPtr != NULL) {
	keyPtr = (struct ScriptLimitCallbackKey *)
		Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr);
	Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type,
		CallScriptLimitCallback, Tcl_GetHashValue(hashPtr));
	hashPtr = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(&iPtr->limit.callbacks);
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitLimitSupport --
 *
 *	Initialise all the parts of the interpreter relating to
 *	resource limit management.  This allows an interpreter to both
 *	have limits set upon itself and set limits upon other
 *	interpreters.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The resource limit subsystem is initialised for the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
TclInitLimitSupport(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.active = 0;
    iPtr->limit.granularityTicker = 0;
    iPtr->limit.exceeded = 0;
    iPtr->limit.cmdCount = 0;
    iPtr->limit.cmdHandlers = NULL;
    iPtr->limit.cmdGranularity = 1;
    memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
    iPtr->limit.timeHandlers = NULL;
    iPtr->limit.timeGranularity = 10;
    Tcl_InitHashTable(&iPtr->limit.callbacks,
	    sizeof(struct ScriptLimitCallbackKey)/sizeof(int));
}

/*
 *----------------------------------------------------------------------
 *
 * InheritLimitsFromMaster --
 *
 *	Derive the interpreter limit configuration for a slave
 *	interpreter from the limit config for the master.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The slave interpreter limits are set so that if the master has
 *	a limit, it may not exceed it by handing off work to slave
 *	interpreters.  Note that this does not transfer limit
 *	callbacks from the master to the slave.
 *
 *----------------------------------------------------------------------
 */

static void
InheritLimitsFromMaster(slaveInterp, masterInterp)
    Tcl_Interp *slaveInterp, *masterInterp;
{
    Interp *slavePtr = (Interp *) slaveInterp;
    Interp *masterPtr = (Interp *) masterInterp;

    if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) {
	slavePtr->limit.active |= TCL_LIMIT_COMMANDS;
	slavePtr->limit.cmdCount = 0;
	slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity;
    }
    if (masterPtr->limit.active & TCL_LIMIT_TIME) {
	slavePtr->limit.active |= TCL_LIMIT_TIME;
	memcpy(&slavePtr->limit.time, &masterPtr->limit.time,
		sizeof(Tcl_Time));
	slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCommandLimitCmd --
 *
 *	Implementation of the [interp limit $i commands] and [$i limit
 *	commands] subcommands.  See the interp manual page for a full
 *	description.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Depends on the arguments.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    Tcl_Interp *slaveInterp;		/* Interpreter being adjusted. */
    int consumedObjc;			/* Number of args already parsed. */
    int objc;				/* Total number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static CONST char *options[] = {
	"-command", "-granularity", "-value", NULL
    };
    enum Options {
	OPT_CMD, OPT_GRAN, OPT_VAL
    };
    Interp *iPtr = (Interp *) interp;
    int index;
    struct ScriptLimitCallbackKey key;
    struct ScriptLimitCallback *limitCBPtr;
    Tcl_HashEntry *hPtr;

    if (objc == consumedObjc) {
	Tcl_Obj *dictPtr;

	TclNewObj(dictPtr);
	key.interp = slaveInterp;
	key.type = TCL_LIMIT_COMMANDS;
	hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
	if (hPtr != NULL) {
	    limitCBPtr = (struct ScriptLimitCallback *)
		    Tcl_GetHashValue(hPtr);
	    if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;
	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], -1), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
		Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
		TCL_LIMIT_COMMANDS)));

	if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
		    Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp)));
	} else {
	    Tcl_Obj *empty;

	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[2], -1), empty);
	}
	Tcl_SetObjResult(interp, dictPtr);
	return TCL_OK;
    } else if (objc == consumedObjc+1) {
	if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
		0, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum Options) index) {
	case OPT_CMD:
	    key.interp = slaveInterp;
	    key.type = TCL_LIMIT_COMMANDS;
	    hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
	    if (hPtr != NULL) {
		limitCBPtr = (struct ScriptLimitCallback *)
			Tcl_GetHashValue(hPtr);
		if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		    Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
		}
	    }
	    break;
	case OPT_GRAN:
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(
		    Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS)));
	    break;
	case OPT_VAL:
	    if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
		Tcl_SetObjResult(interp,
			Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp)));
	    }
	    break;
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv,
		"?-option? ?value? ?-option value ...?");
	return TCL_ERROR;
    } else {
	int i, scriptLen = 0, limitLen = 0;
	Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
	int gran = 0, limit = 0;

	for (i=consumedObjc ; i<objc ; i+=2) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum Options) index) {
	    case OPT_CMD:
		scriptObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
		break;
	    case OPT_GRAN:
		granObj = objv[i+1];
		if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_AppendResult(interp, "granularity must be at ",
			    "least 1", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_VAL:
		limitObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
		if (limitLen == 0) {
		    break;
		}
		if (Tcl_GetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (limit < 0) {
		    Tcl_AppendResult(interp, "command limit value must be at ",
			    "least 0", NULL);
		    return TCL_ERROR;
		}
		break;
	    }
	}
	if (scriptObj != NULL) {
	    SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp,
		    (scriptLen > 0 ? scriptObj : NULL));
	}
	if (granObj != NULL) {
	    Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran);
	}
	if (limitObj != NULL) {
	    if (limitLen > 0) {
		Tcl_LimitSetCommands(slaveInterp, limit);
		Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS);
	    } else {
		Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS);
	    }
	}
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveTimeLimitCmd --
 *
 *	Implementation of the [interp limit $i time] and [$i limit
 *	time] subcommands.  See the interp manual page for a full
 *	description.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Depends on the arguments.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    Tcl_Interp *slaveInterp;		/* Interpreter being adjusted. */
    int consumedObjc;			/* Number of args already parsed. */
    int objc;				/* Total number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static CONST char *options[] = {
	"-command", "-granularity", "-milliseconds", "-seconds", NULL
    };
    enum Options {
	OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC
    };
    Interp *iPtr = (Interp *) interp;
    int index;
    struct ScriptLimitCallbackKey key;
    struct ScriptLimitCallback *limitCBPtr;
    Tcl_HashEntry *hPtr;

    if (objc == consumedObjc) {
	Tcl_Obj *dictPtr;

	TclNewObj(dictPtr);
	key.interp = slaveInterp;
	key.type = TCL_LIMIT_TIME;
	hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
	if (hPtr != NULL) {
	    limitCBPtr = (struct ScriptLimitCallback *)
		    Tcl_GetHashValue(hPtr);
	    if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;
	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], -1), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
		Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
		TCL_LIMIT_TIME)));

	if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
	    Tcl_Time limitMoment;

	    Tcl_LimitGetTime(slaveInterp, &limitMoment);
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
		    Tcl_NewLongObj(limitMoment.usec/1000));
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
		    Tcl_NewLongObj(limitMoment.sec));
	} else {
	    Tcl_Obj *empty;

	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[2], -1), empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[3], -1), empty);
	}
	Tcl_SetObjResult(interp, dictPtr);
	return TCL_OK;
    } else if (objc == consumedObjc+1) {
	if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
		0, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum Options) index) {
	case OPT_CMD:
	    key.interp = slaveInterp;
	    key.type = TCL_LIMIT_TIME;
	    hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
	    if (hPtr != NULL) {
		limitCBPtr = (struct ScriptLimitCallback *)
			Tcl_GetHashValue(hPtr);
		if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		    Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
		}
	    }
	    break;
	case OPT_GRAN:
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(
		    Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME)));
	    break;
	case OPT_MILLI:
	    if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
		Tcl_Time limitMoment;

		Tcl_LimitGetTime(slaveInterp, &limitMoment);
		Tcl_SetObjResult(interp,
			Tcl_NewLongObj(limitMoment.usec/1000));
	    }
	    break;
	case OPT_SEC:
	    if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
		Tcl_Time limitMoment;

		Tcl_LimitGetTime(slaveInterp, &limitMoment);
		Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec));
	    }
	    break;
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv,
		"?-option? ?value? ?-option value ...?");
	return TCL_ERROR;
    } else {
	int i, scriptLen = 0, milliLen = 0, secLen = 0;
	Tcl_Obj *scriptObj = NULL, *granObj = NULL;
	Tcl_Obj *milliObj = NULL, *secObj = NULL;
	int gran = 0;
	Tcl_Time limitMoment;
	int tmp;

	Tcl_LimitGetTime(slaveInterp, &limitMoment);
	for (i=consumedObjc ; i<objc ; i+=2) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum Options) index) {
	    case OPT_CMD:
		scriptObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
		break;
	    case OPT_GRAN:
		granObj = objv[i+1];
		if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_AppendResult(interp, "granularity must be at ",
			    "least 1", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_MILLI:
		milliObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
		if (milliLen == 0) {
		    break;
		}
		if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tmp < 0) {
		    Tcl_AppendResult(interp, "milliseconds must be at least 0",
			    NULL);
		    return TCL_ERROR;
		}
		limitMoment.usec = ((long)tmp)*1000;
		break;
	    case OPT_SEC:
		secObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &secLen);
		if (secLen == 0) {
		    break;
		}
		if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tmp < 0) {
		    Tcl_AppendResult(interp, "seconds must be at least 0",
			    NULL);
		    return TCL_ERROR;
		}
		limitMoment.sec = tmp;
		break;
	    }
	}
	if (milliObj != NULL || secObj != NULL) {
	    if (milliObj != NULL) {
		/*
		 * Setting -milliseconds but clearing -seconds, or
		 * resetting -milliseconds but not resetting -seconds?
		 * Bad voodoo!
		 */
		if (secObj != NULL && secLen == 0 && milliLen > 0) {
		    Tcl_AppendResult(interp, "may only set -milliseconds ",
			    "if -seconds is not also being reset", NULL);
		    return TCL_ERROR;
		}
		if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
		    Tcl_AppendResult(interp, "may only reset -milliseconds ",
			    "if -seconds is also being reset", NULL);
		    return TCL_ERROR;
		}
	    }

	    if (milliLen > 0 || secLen > 0) {
		/*
		 * Force usec to be in range [0..1000000), possibly
		 * incrementing sec in the process.  This makes it
		 * much easier for people to write scripts that do
		 * small time increments.
		 */
		limitMoment.sec += limitMoment.usec / 1000000;
		limitMoment.usec %= 1000000;

		Tcl_LimitSetTime(slaveInterp, &limitMoment);
		Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME);
	    } else {
		Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME);
	    }
	}
	if (scriptObj != NULL) {
	    SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp,
		    (scriptLen > 0 ? scriptObj : NULL));
	}
	if (granObj != NULL) {
	    Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran);
	}
	return TCL_OK;
    }
}