Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclInterp.c@260cb5ec6c19 (annotated)

sl@0	1	/*
sl@0	2	* tclInterp.c --
sl@0	3	*
sl@0	4	* This file implements the "interp" command which allows creation
sl@0	5	* and manipulation of Tcl interpreters from within Tcl scripts.
sl@0	6	*
sl@0	7	* Copyright (c) 1995-1997 Sun Microsystems, Inc.
sl@0	8	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	9	*
sl@0	10	* See the file "license.terms" for information on usage and redistribution
sl@0	11	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	12	*
sl@0	13	* RCS: @(#) $Id: tclInterp.c,v 1.20.2.3 2006/11/28 22:20:02 andreas_kupries Exp $
sl@0	14	*/
sl@0	15
sl@0	16	#include "tclInt.h"
sl@0	17	#include "tclPort.h"
sl@0	18	#include <stdio.h>
sl@0	19
sl@0	20	/*
sl@0	21	* Counter for how many aliases were created (global)
sl@0	22	*/
sl@0	23
sl@0	24	static int aliasCounter = 0;
sl@0	25	TCL_DECLARE_MUTEX(cntMutex)
sl@0	26
sl@0	27	/*
sl@0	28	* struct Alias:
sl@0	29	*
sl@0	30	* Stores information about an alias. Is stored in the slave interpreter
sl@0	31	* and used by the source command to find the target command in the master
sl@0	32	* when the source command is invoked.
sl@0	33	*/
sl@0	34
sl@0	35	typedef struct Alias {
sl@0	36	Tcl_Obj namePtr; / Name of alias command in slave interp. */
sl@0	37	Tcl_Interp targetInterp; / Interp in which target command will be
sl@0	38	* invoked. */
sl@0	39	Tcl_Command slaveCmd; /* Source command in slave interpreter,
sl@0	40	* bound to command that invokes the target
sl@0	41	* command in the target interpreter. */
sl@0	42	Tcl_HashEntry *aliasEntryPtr;
sl@0	43	/* Entry for the alias hash table in slave.
sl@0	44	* This is used by alias deletion to remove
sl@0	45	* the alias from the slave interpreter
sl@0	46	* alias table. */
sl@0	47	Tcl_HashEntry *targetEntryPtr;
sl@0	48	/* Entry for target command in master.
sl@0	49	* This is used in the master interpreter to
sl@0	50	* map back from the target command to aliases
sl@0	51	* redirecting to it. Random access to this
sl@0	52	* hash table is never required - we are using
sl@0	53	* a hash table only for convenience. */
sl@0	54	int objc; /* Count of Tcl_Obj in the prefix of the
sl@0	55	* target command to be invoked in the
sl@0	56	* target interpreter. Additional arguments
sl@0	57	* specified when calling the alias in the
sl@0	58	* slave interp will be appended to the prefix
sl@0	59	* before the command is invoked. */
sl@0	60	Tcl_Obj objPtr; / The first actual prefix object - the target
sl@0	61	* command name; this has to be at the end of the
sl@0	62	* structure, which will be extended to accomodate
sl@0	63	* the remaining objects in the prefix. */
sl@0	64	} Alias;
sl@0	65
sl@0	66	/*
sl@0	67	*
sl@0	68	* struct Slave:
sl@0	69	*
sl@0	70	* Used by the "interp" command to record and find information about slave
sl@0	71	* interpreters. Maps from a command name in the master to information about
sl@0	72	* a slave interpreter, e.g. what aliases are defined in it.
sl@0	73	*/
sl@0	74
sl@0	75	typedef struct Slave {
sl@0	76	Tcl_Interp masterInterp; / Master interpreter for this slave. */
sl@0	77	Tcl_HashEntry *slaveEntryPtr;
sl@0	78	/* Hash entry in masters slave table for
sl@0	79	* this slave interpreter. Used to find
sl@0	80	* this record, and used when deleting the
sl@0	81	* slave interpreter to delete it from the
sl@0	82	* master's table. */
sl@0	83	Tcl_Interp slaveInterp; / The slave interpreter. */
sl@0	84	Tcl_Command interpCmd; /* Interpreter object command. */
sl@0	85	Tcl_HashTable aliasTable; /* Table which maps from names of commands
sl@0	86	* in slave interpreter to struct Alias
sl@0	87	* defined below. */
sl@0	88	} Slave;
sl@0	89
sl@0	90	/*
sl@0	91	* struct Target:
sl@0	92	*
sl@0	93	* Maps from master interpreter commands back to the source commands in slave
sl@0	94	* interpreters. This is needed because aliases can be created between sibling
sl@0	95	* interpreters and must be deleted when the target interpreter is deleted. In
sl@0	96	* case they would not be deleted the source interpreter would be left with a
sl@0	97	* "dangling pointer". One such record is stored in the Master record of the
sl@0	98	* master interpreter (in the targetTable hashtable, see below) with the
sl@0	99	* master for each alias which directs to a command in the master. These
sl@0	100	* records are used to remove the source command for an from a slave if/when
sl@0	101	* the master is deleted.
sl@0	102	*/
sl@0	103
sl@0	104	typedef struct Target {
sl@0	105	Tcl_Command slaveCmd; /* Command for alias in slave interp. */
sl@0	106	Tcl_Interp slaveInterp; / Slave Interpreter. */
sl@0	107	} Target;
sl@0	108
sl@0	109	/*
sl@0	110	* struct Master:
sl@0	111	*
sl@0	112	* This record is used for two purposes: First, slaveTable (a hashtable)
sl@0	113	* maps from names of commands to slave interpreters. This hashtable is
sl@0	114	* used to store information about slave interpreters of this interpreter,
sl@0	115	* to map over all slaves, etc. The second purpose is to store information
sl@0	116	* about all aliases in slaves (or siblings) which direct to target commands
sl@0	117	* in this interpreter (using the targetTable hashtable).
sl@0	118	*
sl@0	119	* NB: the flags field in the interp structure, used with SAFE_INTERP
sl@0	120	* mask denotes whether the interpreter is safe or not. Safe
sl@0	121	* interpreters have restricted functionality, can only create safe slave
sl@0	122	* interpreters and can only load safe extensions.
sl@0	123	*/
sl@0	124
sl@0	125	typedef struct Master {
sl@0	126	Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
sl@0	127	* Maps from command names to Slave records. */
sl@0	128	Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
sl@0	129	* all Target records which denote aliases
sl@0	130	* from slaves or sibling interpreters that
sl@0	131	* direct to commands in this interpreter. This
sl@0	132	* table is used to remove dangling pointers
sl@0	133	* from the slave (or sibling) interpreters
sl@0	134	* when this interpreter is deleted. */
sl@0	135	} Master;
sl@0	136
sl@0	137	/*
sl@0	138	* The following structure keeps track of all the Master and Slave information
sl@0	139	* on a per-interp basis.
sl@0	140	*/
sl@0	141
sl@0	142	typedef struct InterpInfo {
sl@0	143	Master master; /* Keeps track of all interps for which this
sl@0	144	* interp is the Master. */
sl@0	145	Slave slave; /* Information necessary for this interp to
sl@0	146	* function as a slave. */
sl@0	147	} InterpInfo;
sl@0	148
sl@0	149	/*
sl@0	150	* Prototypes for local static procedures:
sl@0	151	*/
sl@0	152
sl@0	153	static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	154	Tcl_Interp slaveInterp, Tcl_Interp masterInterp,
sl@0	155	Tcl_Obj namePtr, Tcl_Obj targetPtr, int objc,
sl@0	156	Tcl_Obj *CONST objv[]));
sl@0	157	static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	158	Tcl_Interp slaveInterp, Tcl_Obj namePtr));
sl@0	159	static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	160	Tcl_Interp slaveInterp, Tcl_Obj objPtr));
sl@0	161	static int AliasList _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	162	Tcl_Interp *slaveInterp));
sl@0	163	static int AliasObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	164	Tcl_Interp *currentInterp, int objc,
sl@0	165	Tcl_Obj *CONST objv[]));
sl@0	166	static void AliasObjCmdDeleteProc _ANSI_ARGS_((
sl@0	167	ClientData clientData));
sl@0	168
sl@0	169	static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	170	Tcl_Obj *pathPtr));
sl@0	171	static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
sl@0	172	Tcl_Obj *CONST objv[]));
sl@0	173	static void InterpInfoDeleteProc _ANSI_ARGS_((
sl@0	174	ClientData clientData, Tcl_Interp *interp));
sl@0	175	static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	176	Tcl_Obj *pathPtr, int safe));
sl@0	177	static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	178	Tcl_Interp *slaveInterp, int objc,
sl@0	179	Tcl_Obj *CONST objv[]));
sl@0	180	static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	181	Tcl_Interp *slaveInterp, int objc,
sl@0	182	Tcl_Obj *CONST objv[]));
sl@0	183	static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	184	Tcl_Interp *slaveInterp, int objc,
sl@0	185	Tcl_Obj *CONST objv[]));
sl@0	186	static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	187	Tcl_Interp *slaveInterp));
sl@0	188	static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	189	Tcl_Interp *slaveInterp, int global, int objc,
sl@0	190	Tcl_Obj *CONST objv[]));
sl@0	191	static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	192	Tcl_Interp *slaveInterp));
sl@0	193	static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	194	Tcl_Interp *interp, int objc,
sl@0	195	Tcl_Obj *CONST objv[]));
sl@0	196	static void SlaveObjCmdDeleteProc _ANSI_ARGS_((
sl@0	197	ClientData clientData));
sl@0	198	static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	199	Tcl_Interp *slaveInterp, int objc,
sl@0	200	Tcl_Obj *CONST objv[]));
sl@0	201
sl@0	202
sl@0	203	/*
sl@0	204	*---------------------------------------------------------------------------
sl@0	205	*
sl@0	206	* TclInterpInit --
sl@0	207	*
sl@0	208	* Initializes the invoking interpreter for using the master, slave
sl@0	209	* and safe interp facilities. This is called from inside
sl@0	210	* Tcl_CreateInterp().
sl@0	211	*
sl@0	212	* Results:
sl@0	213	* Always returns TCL_OK for backwards compatibility.
sl@0	214	*
sl@0	215	* Side effects:
sl@0	216	* Adds the "interp" command to an interpreter and initializes the
sl@0	217	* interpInfoPtr field of the invoking interpreter.
sl@0	218	*
sl@0	219	*---------------------------------------------------------------------------
sl@0	220	*/
sl@0	221
sl@0	222	int
sl@0	223	TclInterpInit(interp)
sl@0	224	Tcl_Interp interp; / Interpreter to initialize. */
sl@0	225	{
sl@0	226	InterpInfo *interpInfoPtr;
sl@0	227	Master *masterPtr;
sl@0	228	Slave *slavePtr;
sl@0	229
sl@0	230	interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
sl@0	231	((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;
sl@0	232
sl@0	233	masterPtr = &interpInfoPtr->master;
sl@0	234	Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
sl@0	235	Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS);
sl@0	236
sl@0	237	slavePtr = &interpInfoPtr->slave;
sl@0	238	slavePtr->masterInterp = NULL;
sl@0	239	slavePtr->slaveEntryPtr = NULL;
sl@0	240	slavePtr->slaveInterp = interp;
sl@0	241	slavePtr->interpCmd = NULL;
sl@0	242	Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
sl@0	243
sl@0	244	Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
sl@0	245
sl@0	246	Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
sl@0	247	return TCL_OK;
sl@0	248	}
sl@0	249
sl@0	250	/*
sl@0	251	*---------------------------------------------------------------------------
sl@0	252	*
sl@0	253	* InterpInfoDeleteProc --
sl@0	254	*
sl@0	255	* Invoked when an interpreter is being deleted. It releases all
sl@0	256	* storage used by the master/slave/safe interpreter facilities.
sl@0	257	*
sl@0	258	* Results:
sl@0	259	* None.
sl@0	260	*
sl@0	261	* Side effects:
sl@0	262	* Cleans up storage. Sets the interpInfoPtr field of the interp
sl@0	263	* to NULL.
sl@0	264	*
sl@0	265	*---------------------------------------------------------------------------
sl@0	266	*/
sl@0	267
sl@0	268	static void
sl@0	269	InterpInfoDeleteProc(clientData, interp)
sl@0	270	ClientData clientData; /* Ignored. */
sl@0	271	Tcl_Interp interp; / Interp being deleted. All commands for
sl@0	272	* slave interps should already be deleted. */
sl@0	273	{
sl@0	274	InterpInfo *interpInfoPtr;
sl@0	275	Slave *slavePtr;
sl@0	276	Master *masterPtr;
sl@0	277	Tcl_HashSearch hSearch;
sl@0	278	Tcl_HashEntry *hPtr;
sl@0	279	Target *targetPtr;
sl@0	280
sl@0	281	interpInfoPtr = (InterpInfo ) ((Interp ) interp)->interpInfo;
sl@0	282
sl@0	283	/*
sl@0	284	* There shouldn't be any commands left.
sl@0	285	*/
sl@0	286
sl@0	287	masterPtr = &interpInfoPtr->master;
sl@0	288	if (masterPtr->slaveTable.numEntries != 0) {
sl@0	289	panic("InterpInfoDeleteProc: still exist commands");
sl@0	290	}
sl@0	291	Tcl_DeleteHashTable(&masterPtr->slaveTable);
sl@0	292
sl@0	293	/*
sl@0	294	* Tell any interps that have aliases to this interp that they should
sl@0	295	* delete those aliases. If the other interp was already dead, it
sl@0	296	* would have removed the target record already.
sl@0	297	*/
sl@0	298
sl@0	299	hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch);
sl@0	300	while (hPtr != NULL) {
sl@0	301	targetPtr = (Target *) Tcl_GetHashValue(hPtr);
sl@0	302	Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
sl@0	303	targetPtr->slaveCmd);
sl@0	304	hPtr = Tcl_NextHashEntry(&hSearch);
sl@0	305	}
sl@0	306	Tcl_DeleteHashTable(&masterPtr->targetTable);
sl@0	307
sl@0	308	slavePtr = &interpInfoPtr->slave;
sl@0	309	if (slavePtr->interpCmd != NULL) {
sl@0	310	/*
sl@0	311	* Tcl_DeleteInterp() was called on this interpreter, rather
sl@0	312	* "interp delete" or the equivalent deletion of the command in the
sl@0	313	* master. First ensure that the cleanup callback doesn't try to
sl@0	314	* delete the interp again.
sl@0	315	*/
sl@0	316
sl@0	317	slavePtr->slaveInterp = NULL;
sl@0	318	Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
sl@0	319	slavePtr->interpCmd);
sl@0	320	}
sl@0	321
sl@0	322	/*
sl@0	323	* There shouldn't be any aliases left.
sl@0	324	*/
sl@0	325
sl@0	326	if (slavePtr->aliasTable.numEntries != 0) {
sl@0	327	panic("InterpInfoDeleteProc: still exist aliases");
sl@0	328	}
sl@0	329	Tcl_DeleteHashTable(&slavePtr->aliasTable);
sl@0	330
sl@0	331	ckfree((char *) interpInfoPtr);
sl@0	332	}
sl@0	333
sl@0	334	/*
sl@0	335	*----------------------------------------------------------------------
sl@0	336	*
sl@0	337	* Tcl_InterpObjCmd --
sl@0	338	*
sl@0	339	* This procedure is invoked to process the "interp" Tcl command.
sl@0	340	* See the user documentation for details on what it does.
sl@0	341	*
sl@0	342	* Results:
sl@0	343	* A standard Tcl result.
sl@0	344	*
sl@0	345	* Side effects:
sl@0	346	* See the user documentation.
sl@0	347	*
sl@0	348	*----------------------------------------------------------------------
sl@0	349	*/
sl@0	350	/* ARGSUSED */
sl@0	351	int
sl@0	352	Tcl_InterpObjCmd(clientData, interp, objc, objv)
sl@0	353	ClientData clientData; /* Unused. */
sl@0	354	Tcl_Interp interp; / Current interpreter. */
sl@0	355	int objc; /* Number of arguments. */
sl@0	356	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	357	{
sl@0	358	int index;
sl@0	359	static CONST char *options[] = {
sl@0	360	"alias", "aliases", "create", "delete",
sl@0	361	"eval", "exists", "expose", "hide",
sl@0	362	"hidden", "issafe", "invokehidden", "marktrusted",
sl@0	363	"recursionlimit", "slaves", "share",
sl@0	364	"target", "transfer",
sl@0	365	NULL
sl@0	366	};
sl@0	367	enum option {
sl@0	368	OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
sl@0	369	OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
sl@0	370	OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED,
sl@0	371	OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE,
sl@0	372	OPT_TARGET, OPT_TRANSFER
sl@0	373	};
sl@0	374
sl@0	375
sl@0	376	if (objc < 2) {
sl@0	377	Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
sl@0	378	return TCL_ERROR;
sl@0	379	}
sl@0	380	if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
sl@0	381	&index) != TCL_OK) {
sl@0	382	return TCL_ERROR;
sl@0	383	}
sl@0	384	switch ((enum option) index) {
sl@0	385	case OPT_ALIAS: {
sl@0	386	Tcl_Interp slaveInterp, masterInterp;
sl@0	387
sl@0	388	if (objc < 4) {
sl@0	389	aliasArgs:
sl@0	390	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	391	"slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
sl@0	392	return TCL_ERROR;
sl@0	393	}
sl@0	394	slaveInterp = GetInterp(interp, objv[2]);
sl@0	395	if (slaveInterp == (Tcl_Interp *) NULL) {
sl@0	396	return TCL_ERROR;
sl@0	397	}
sl@0	398	if (objc == 4) {
sl@0	399	return AliasDescribe(interp, slaveInterp, objv[3]);
sl@0	400	}
sl@0	401	if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
sl@0	402	return AliasDelete(interp, slaveInterp, objv[3]);
sl@0	403	}
sl@0	404	if (objc > 5) {
sl@0	405	masterInterp = GetInterp(interp, objv[4]);
sl@0	406	if (masterInterp == (Tcl_Interp *) NULL) {
sl@0	407	return TCL_ERROR;
sl@0	408	}
sl@0	409	if (Tcl_GetString(objv[5])[0] == '\0') {
sl@0	410	if (objc == 6) {
sl@0	411	return AliasDelete(interp, slaveInterp, objv[3]);
sl@0	412	}
sl@0	413	} else {
sl@0	414	return AliasCreate(interp, slaveInterp, masterInterp,
sl@0	415	objv[3], objv[5], objc - 6, objv + 6);
sl@0	416	}
sl@0	417	}
sl@0	418	goto aliasArgs;
sl@0	419	}
sl@0	420	case OPT_ALIASES: {
sl@0	421	Tcl_Interp *slaveInterp;
sl@0	422
sl@0	423	slaveInterp = GetInterp2(interp, objc, objv);
sl@0	424	if (slaveInterp == NULL) {
sl@0	425	return TCL_ERROR;
sl@0	426	}
sl@0	427	return AliasList(interp, slaveInterp);
sl@0	428	}
sl@0	429	case OPT_CREATE: {
sl@0	430	int i, last, safe;
sl@0	431	Tcl_Obj *slavePtr;
sl@0	432	char buf[16 + TCL_INTEGER_SPACE];
sl@0	433	static CONST char *options[] = {
sl@0	434	"-safe", "--", NULL
sl@0	435	};
sl@0	436	enum option {
sl@0	437	OPT_SAFE, OPT_LAST
sl@0	438	};
sl@0	439
sl@0	440	safe = Tcl_IsSafe(interp);
sl@0	441
sl@0	442	/*
sl@0	443	* Weird historical rules: "-safe" is accepted at the end, too.
sl@0	444	*/
sl@0	445
sl@0	446	slavePtr = NULL;
sl@0	447	last = 0;
sl@0	448	for (i = 2; i < objc; i++) {
sl@0	449	if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
sl@0	450	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
sl@0	451	0, &index) != TCL_OK) {
sl@0	452	return TCL_ERROR;
sl@0	453	}
sl@0	454	if (index == OPT_SAFE) {
sl@0	455	safe = 1;
sl@0	456	continue;
sl@0	457	}
sl@0	458	i++;
sl@0	459	last = 1;
sl@0	460	}
sl@0	461	if (slavePtr != NULL) {
sl@0	462	Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
sl@0	463	return TCL_ERROR;
sl@0	464	}
sl@0	465	if (i < objc) {
sl@0	466	slavePtr = objv[i];
sl@0	467	}
sl@0	468	}
sl@0	469	buf[0] = '\0';
sl@0	470	if (slavePtr == NULL) {
sl@0	471	/*
sl@0	472	* Create an anonymous interpreter -- we choose its name and
sl@0	473	* the name of the command. We check that the command name
sl@0	474	* that we use for the interpreter does not collide with an
sl@0	475	* existing command in the master interpreter.
sl@0	476	*/
sl@0	477
sl@0	478	for (i = 0; ; i++) {
sl@0	479	Tcl_CmdInfo cmdInfo;
sl@0	480
sl@0	481	sprintf(buf, "interp%d", i);
sl@0	482	if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
sl@0	483	break;
sl@0	484	}
sl@0	485	}
sl@0	486	slavePtr = Tcl_NewStringObj(buf, -1);
sl@0	487	}
sl@0	488	if (SlaveCreate(interp, slavePtr, safe) == NULL) {
sl@0	489	if (buf[0] != '\0') {
sl@0	490	Tcl_DecrRefCount(slavePtr);
sl@0	491	}
sl@0	492	return TCL_ERROR;
sl@0	493	}
sl@0	494	Tcl_SetObjResult(interp, slavePtr);
sl@0	495	return TCL_OK;
sl@0	496	}
sl@0	497	case OPT_DELETE: {
sl@0	498	int i;
sl@0	499	InterpInfo *iiPtr;
sl@0	500	Tcl_Interp *slaveInterp;
sl@0	501
sl@0	502	for (i = 2; i < objc; i++) {
sl@0	503	slaveInterp = GetInterp(interp, objv[i]);
sl@0	504	if (slaveInterp == NULL) {
sl@0	505	return TCL_ERROR;
sl@0	506	} else if (slaveInterp == interp) {
sl@0	507	Tcl_ResetResult(interp);
sl@0	508	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	509	"cannot delete the current interpreter",
sl@0	510	(char *) NULL);
sl@0	511	return TCL_ERROR;
sl@0	512	}
sl@0	513	iiPtr = (InterpInfo ) ((Interp ) slaveInterp)->interpInfo;
sl@0	514	Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
sl@0	515	iiPtr->slave.interpCmd);
sl@0	516	}
sl@0	517	return TCL_OK;
sl@0	518	}
sl@0	519	case OPT_EVAL: {
sl@0	520	Tcl_Interp *slaveInterp;
sl@0	521
sl@0	522	if (objc < 4) {
sl@0	523	Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
sl@0	524	return TCL_ERROR;
sl@0	525	}
sl@0	526	slaveInterp = GetInterp(interp, objv[2]);
sl@0	527	if (slaveInterp == NULL) {
sl@0	528	return TCL_ERROR;
sl@0	529	}
sl@0	530	return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
sl@0	531	}
sl@0	532	case OPT_EXISTS: {
sl@0	533	int exists;
sl@0	534	Tcl_Interp *slaveInterp;
sl@0	535
sl@0	536	exists = 1;
sl@0	537	slaveInterp = GetInterp2(interp, objc, objv);
sl@0	538	if (slaveInterp == NULL) {
sl@0	539	if (objc > 3) {
sl@0	540	return TCL_ERROR;
sl@0	541	}
sl@0	542	Tcl_ResetResult(interp);
sl@0	543	exists = 0;
sl@0	544	}
sl@0	545	Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
sl@0	546	return TCL_OK;
sl@0	547	}
sl@0	548	case OPT_EXPOSE: {
sl@0	549	Tcl_Interp *slaveInterp;
sl@0	550
sl@0	551	if ((objc < 4) \|\| (objc > 5)) {
sl@0	552	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	553	"path hiddenCmdName ?cmdName?");
sl@0	554	return TCL_ERROR;
sl@0	555	}
sl@0	556	slaveInterp = GetInterp(interp, objv[2]);
sl@0	557	if (slaveInterp == NULL) {
sl@0	558	return TCL_ERROR;
sl@0	559	}
sl@0	560	return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
sl@0	561	}
sl@0	562	case OPT_HIDE: {
sl@0	563	Tcl_Interp slaveInterp; / A slave. */
sl@0	564
sl@0	565	if ((objc < 4) \|\| (objc > 5)) {
sl@0	566	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	567	"path cmdName ?hiddenCmdName?");
sl@0	568	return TCL_ERROR;
sl@0	569	}
sl@0	570	slaveInterp = GetInterp(interp, objv[2]);
sl@0	571	if (slaveInterp == (Tcl_Interp *) NULL) {
sl@0	572	return TCL_ERROR;
sl@0	573	}
sl@0	574	return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
sl@0	575	}
sl@0	576	case OPT_HIDDEN: {
sl@0	577	Tcl_Interp slaveInterp; / A slave. */
sl@0	578
sl@0	579	slaveInterp = GetInterp2(interp, objc, objv);
sl@0	580	if (slaveInterp == NULL) {
sl@0	581	return TCL_ERROR;
sl@0	582	}
sl@0	583	return SlaveHidden(interp, slaveInterp);
sl@0	584	}
sl@0	585	case OPT_ISSAFE: {
sl@0	586	Tcl_Interp *slaveInterp;
sl@0	587
sl@0	588	slaveInterp = GetInterp2(interp, objc, objv);
sl@0	589	if (slaveInterp == NULL) {
sl@0	590	return TCL_ERROR;
sl@0	591	}
sl@0	592	Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
sl@0	593	return TCL_OK;
sl@0	594	}
sl@0	595	case OPT_INVOKEHID: {
sl@0	596	int i, index, global;
sl@0	597	Tcl_Interp *slaveInterp;
sl@0	598	static CONST char *hiddenOptions[] = {
sl@0	599	"-global", "--", NULL
sl@0	600	};
sl@0	601	enum hiddenOption {
sl@0	602	OPT_GLOBAL, OPT_LAST
sl@0	603	};
sl@0	604
sl@0	605	global = 0;
sl@0	606	for (i = 3; i < objc; i++) {
sl@0	607	if (Tcl_GetString(objv[i])[0] != '-') {
sl@0	608	break;
sl@0	609	}
sl@0	610	if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
sl@0	611	"option", 0, &index) != TCL_OK) {
sl@0	612	return TCL_ERROR;
sl@0	613	}
sl@0	614	if (index == OPT_GLOBAL) {
sl@0	615	global = 1;
sl@0	616	} else {
sl@0	617	i++;
sl@0	618	break;
sl@0	619	}
sl@0	620	}
sl@0	621	if (objc - i < 1) {
sl@0	622	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	623	"path ?-global? ?--? cmd ?arg ..?");
sl@0	624	return TCL_ERROR;
sl@0	625	}
sl@0	626	slaveInterp = GetInterp(interp, objv[2]);
sl@0	627	if (slaveInterp == (Tcl_Interp *) NULL) {
sl@0	628	return TCL_ERROR;
sl@0	629	}
sl@0	630	return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
sl@0	631	objv + i);
sl@0	632	}
sl@0	633	case OPT_MARKTRUSTED: {
sl@0	634	Tcl_Interp *slaveInterp;
sl@0	635
sl@0	636	if (objc != 3) {
sl@0	637	Tcl_WrongNumArgs(interp, 2, objv, "path");
sl@0	638	return TCL_ERROR;
sl@0	639	}
sl@0	640	slaveInterp = GetInterp(interp, objv[2]);
sl@0	641	if (slaveInterp == NULL) {
sl@0	642	return TCL_ERROR;
sl@0	643	}
sl@0	644	return SlaveMarkTrusted(interp, slaveInterp);
sl@0	645	}
sl@0	646	case OPT_RECLIMIT: {
sl@0	647	Tcl_Interp *slaveInterp;
sl@0	648
sl@0	649	if (objc != 3 && objc != 4) {
sl@0	650	Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
sl@0	651	return TCL_ERROR;
sl@0	652	}
sl@0	653	slaveInterp = GetInterp(interp, objv[2]);
sl@0	654	if (slaveInterp == NULL) {
sl@0	655	return TCL_ERROR;
sl@0	656	}
sl@0	657	return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
sl@0	658	}
sl@0	659	case OPT_SLAVES: {
sl@0	660	Tcl_Interp *slaveInterp;
sl@0	661	InterpInfo *iiPtr;
sl@0	662	Tcl_Obj *resultPtr;
sl@0	663	Tcl_HashEntry *hPtr;
sl@0	664	Tcl_HashSearch hashSearch;
sl@0	665	char *string;
sl@0	666
sl@0	667	slaveInterp = GetInterp2(interp, objc, objv);
sl@0	668	if (slaveInterp == NULL) {
sl@0	669	return TCL_ERROR;
sl@0	670	}
sl@0	671	iiPtr = (InterpInfo ) ((Interp ) slaveInterp)->interpInfo;
sl@0	672	resultPtr = Tcl_GetObjResult(interp);
sl@0	673	hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
sl@0	674	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
sl@0	675	string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
sl@0	676	Tcl_ListObjAppendElement(NULL, resultPtr,
sl@0	677	Tcl_NewStringObj(string, -1));
sl@0	678	}
sl@0	679	return TCL_OK;
sl@0	680	}
sl@0	681	case OPT_SHARE: {
sl@0	682	Tcl_Interp slaveInterp; / A slave. */
sl@0	683	Tcl_Interp masterInterp; / Its master. */
sl@0	684	Tcl_Channel chan;
sl@0	685
sl@0	686	if (objc != 5) {
sl@0	687	Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
sl@0	688	return TCL_ERROR;
sl@0	689	}
sl@0	690	masterInterp = GetInterp(interp, objv[2]);
sl@0	691	if (masterInterp == NULL) {
sl@0	692	return TCL_ERROR;
sl@0	693	}
sl@0	694	chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
sl@0	695	NULL);
sl@0	696	if (chan == NULL) {
sl@0	697	TclTransferResult(masterInterp, TCL_OK, interp);
sl@0	698	return TCL_ERROR;
sl@0	699	}
sl@0	700	slaveInterp = GetInterp(interp, objv[4]);
sl@0	701	if (slaveInterp == NULL) {
sl@0	702	return TCL_ERROR;
sl@0	703	}
sl@0	704	Tcl_RegisterChannel(slaveInterp, chan);
sl@0	705	return TCL_OK;
sl@0	706	}
sl@0	707	case OPT_TARGET: {
sl@0	708	Tcl_Interp *slaveInterp;
sl@0	709	InterpInfo *iiPtr;
sl@0	710	Tcl_HashEntry *hPtr;
sl@0	711	Alias *aliasPtr;
sl@0	712	char *aliasName;
sl@0	713
sl@0	714	if (objc != 4) {
sl@0	715	Tcl_WrongNumArgs(interp, 2, objv, "path alias");
sl@0	716	return TCL_ERROR;
sl@0	717	}
sl@0	718
sl@0	719	slaveInterp = GetInterp(interp, objv[2]);
sl@0	720	if (slaveInterp == NULL) {
sl@0	721	return TCL_ERROR;
sl@0	722	}
sl@0	723
sl@0	724	aliasName = Tcl_GetString(objv[3]);
sl@0	725
sl@0	726	iiPtr = (InterpInfo ) ((Interp ) slaveInterp)->interpInfo;
sl@0	727	hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
sl@0	728	if (hPtr == NULL) {
sl@0	729	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	730	"alias \"", aliasName, "\" in path \"",
sl@0	731	Tcl_GetString(objv[2]), "\" not found",
sl@0	732	(char *) NULL);
sl@0	733	return TCL_ERROR;
sl@0	734	}
sl@0	735	aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
sl@0	736	if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
sl@0	737	Tcl_ResetResult(interp);
sl@0	738	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	739	"target interpreter for alias \"", aliasName,
sl@0	740	"\" in path \"", Tcl_GetString(objv[2]),
sl@0	741	"\" is not my descendant", (char *) NULL);
sl@0	742	return TCL_ERROR;
sl@0	743	}
sl@0	744	return TCL_OK;
sl@0	745	}
sl@0	746	case OPT_TRANSFER: {
sl@0	747	Tcl_Interp slaveInterp; / A slave. */
sl@0	748	Tcl_Interp masterInterp; / Its master. */
sl@0	749	Tcl_Channel chan;
sl@0	750
sl@0	751	if (objc != 5) {
sl@0	752	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	753	"srcPath channelId destPath");
sl@0	754	return TCL_ERROR;
sl@0	755	}
sl@0	756	masterInterp = GetInterp(interp, objv[2]);
sl@0	757	if (masterInterp == NULL) {
sl@0	758	return TCL_ERROR;
sl@0	759	}
sl@0	760	chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
sl@0	761	if (chan == NULL) {
sl@0	762	TclTransferResult(masterInterp, TCL_OK, interp);
sl@0	763	return TCL_ERROR;
sl@0	764	}
sl@0	765	slaveInterp = GetInterp(interp, objv[4]);
sl@0	766	if (slaveInterp == NULL) {
sl@0	767	return TCL_ERROR;
sl@0	768	}
sl@0	769	Tcl_RegisterChannel(slaveInterp, chan);
sl@0	770	if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
sl@0	771	TclTransferResult(masterInterp, TCL_OK, interp);
sl@0	772	return TCL_ERROR;
sl@0	773	}
sl@0	774	return TCL_OK;
sl@0	775	}
sl@0	776	}
sl@0	777	return TCL_OK;
sl@0	778	}
sl@0	779
sl@0	780	/*
sl@0	781	*---------------------------------------------------------------------------
sl@0	782	*
sl@0	783	* GetInterp2 --
sl@0	784	*
sl@0	785	* Helper function for Tcl_InterpObjCmd() to convert the interp name
sl@0	786	* potentially specified on the command line to an Tcl_Interp.
sl@0	787	*
sl@0	788	* Results:
sl@0	789	* The return value is the interp specified on the command line,
sl@0	790	* or the interp argument itself if no interp was specified on the
sl@0	791	* command line. If the interp could not be found or the wrong
sl@0	792	* number of arguments was specified on the command line, the return
sl@0	793	* value is NULL and an error message is left in the interp's result.
sl@0	794	*
sl@0	795	* Side effects:
sl@0	796	* None.
sl@0	797	*
sl@0	798	*---------------------------------------------------------------------------
sl@0	799	*/
sl@0	800
sl@0	801	static Tcl_Interp *
sl@0	802	GetInterp2(interp, objc, objv)
sl@0	803	Tcl_Interp interp; / Default interp if no interp was specified
sl@0	804	* on the command line. */
sl@0	805	int objc; /* Number of arguments. */
sl@0	806	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	807	{
sl@0	808	if (objc == 2) {
sl@0	809	return interp;
sl@0	810	} else if (objc == 3) {
sl@0	811	return GetInterp(interp, objv[2]);
sl@0	812	} else {
sl@0	813	Tcl_WrongNumArgs(interp, 2, objv, "?path?");
sl@0	814	return NULL;
sl@0	815	}
sl@0	816	}
sl@0	817
sl@0	818	/*
sl@0	819	*----------------------------------------------------------------------
sl@0	820	*
sl@0	821	* Tcl_CreateAlias --
sl@0	822	*
sl@0	823	* Creates an alias between two interpreters.
sl@0	824	*
sl@0	825	* Results:
sl@0	826	* A standard Tcl result.
sl@0	827	*
sl@0	828	* Side effects:
sl@0	829	* Creates a new alias, manipulates the result field of slaveInterp.
sl@0	830	*
sl@0	831	*----------------------------------------------------------------------
sl@0	832	*/
sl@0	833
sl@0	834	EXPORT_C int
sl@0	835	Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
sl@0	836	Tcl_Interp slaveInterp; / Interpreter for source command. */
sl@0	837	CONST char slaveCmd; / Command to install in slave. */
sl@0	838	Tcl_Interp targetInterp; / Interpreter for target command. */
sl@0	839	CONST char targetCmd; / Name of target command. */
sl@0	840	int argc; /* How many additional arguments? */
sl@0	841	CONST char * CONST argv; / These are the additional args. */
sl@0	842	{
sl@0	843	Tcl_Obj slaveObjPtr, targetObjPtr;
sl@0	844	Tcl_Obj **objv;
sl@0	845	int i;
sl@0	846	int result;
sl@0	847
sl@0	848	objv = (Tcl_Obj *) ckalloc((unsigned) sizeof(Tcl_Obj ) * argc);
sl@0	849	for (i = 0; i < argc; i++) {
sl@0	850	objv[i] = Tcl_NewStringObj(argv[i], -1);
sl@0	851	Tcl_IncrRefCount(objv[i]);
sl@0	852	}
sl@0	853
sl@0	854	slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
sl@0	855	Tcl_IncrRefCount(slaveObjPtr);
sl@0	856
sl@0	857	targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
sl@0	858	Tcl_IncrRefCount(targetObjPtr);
sl@0	859
sl@0	860	result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
sl@0	861	targetObjPtr, argc, objv);
sl@0	862
sl@0	863	for (i = 0; i < argc; i++) {
sl@0	864	Tcl_DecrRefCount(objv[i]);
sl@0	865	}
sl@0	866	ckfree((char *) objv);
sl@0	867	Tcl_DecrRefCount(targetObjPtr);
sl@0	868	Tcl_DecrRefCount(slaveObjPtr);
sl@0	869
sl@0	870	return result;
sl@0	871	}
sl@0	872
sl@0	873	/*
sl@0	874	*----------------------------------------------------------------------
sl@0	875	*
sl@0	876	* Tcl_CreateAliasObj --
sl@0	877	*
sl@0	878	* Object version: Creates an alias between two interpreters.
sl@0	879	*
sl@0	880	* Results:
sl@0	881	* A standard Tcl result.
sl@0	882	*
sl@0	883	* Side effects:
sl@0	884	* Creates a new alias.
sl@0	885	*
sl@0	886	*----------------------------------------------------------------------
sl@0	887	*/
sl@0	888
sl@0	889	EXPORT_C int
sl@0	890	Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
sl@0	891	Tcl_Interp slaveInterp; / Interpreter for source command. */
sl@0	892	CONST char slaveCmd; / Command to install in slave. */
sl@0	893	Tcl_Interp targetInterp; / Interpreter for target command. */
sl@0	894	CONST char targetCmd; / Name of target command. */
sl@0	895	int objc; /* How many additional arguments? */
sl@0	896	Tcl_Obj CONST objv[]; / Argument vector. */
sl@0	897	{
sl@0	898	Tcl_Obj slaveObjPtr, targetObjPtr;
sl@0	899	int result;
sl@0	900
sl@0	901	slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
sl@0	902	Tcl_IncrRefCount(slaveObjPtr);
sl@0	903
sl@0	904	targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
sl@0	905	Tcl_IncrRefCount(targetObjPtr);
sl@0	906
sl@0	907	result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
sl@0	908	targetObjPtr, objc, objv);
sl@0	909
sl@0	910	Tcl_DecrRefCount(slaveObjPtr);
sl@0	911	Tcl_DecrRefCount(targetObjPtr);
sl@0	912	return result;
sl@0	913	}
sl@0	914
sl@0	915	/*
sl@0	916	*----------------------------------------------------------------------
sl@0	917	*
sl@0	918	* Tcl_GetAlias --
sl@0	919	*
sl@0	920	* Gets information about an alias.
sl@0	921	*
sl@0	922	* Results:
sl@0	923	* A standard Tcl result.
sl@0	924	*
sl@0	925	* Side effects:
sl@0	926	* None.
sl@0	927	*
sl@0	928	*----------------------------------------------------------------------
sl@0	929	*/
sl@0	930
sl@0	931	EXPORT_C int
sl@0	932	Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
sl@0	933	argvPtr)
sl@0	934	Tcl_Interp interp; / Interp to start search from. */
sl@0	935	CONST char aliasName; / Name of alias to find. */
sl@0	936	Tcl_Interp *targetInterpPtr; / (Return) target interpreter. */
sl@0	937	CONST char *targetNamePtr; / (Return) name of target command. */
sl@0	938	int argcPtr; / (Return) count of addnl args. */
sl@0	939	CONST char **argvPtr; / (Return) additional arguments. */
sl@0	940	{
sl@0	941	InterpInfo *iiPtr;
sl@0	942	Tcl_HashEntry *hPtr;
sl@0	943	Alias *aliasPtr;
sl@0	944	int i, objc;
sl@0	945	Tcl_Obj **objv;
sl@0	946
sl@0	947	iiPtr = (InterpInfo ) ((Interp ) interp)->interpInfo;
sl@0	948	hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
sl@0	949	if (hPtr == NULL) {
sl@0	950	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	951	"alias \"", aliasName, "\" not found", (char *) NULL);
sl@0	952	return TCL_ERROR;
sl@0	953	}
sl@0	954	aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
sl@0	955	objc = aliasPtr->objc;
sl@0	956	objv = &aliasPtr->objPtr;
sl@0	957
sl@0	958	if (targetInterpPtr != NULL) {
sl@0	959	*targetInterpPtr = aliasPtr->targetInterp;
sl@0	960	}
sl@0	961	if (targetNamePtr != NULL) {
sl@0	962	*targetNamePtr = Tcl_GetString(objv[0]);
sl@0	963	}
sl@0	964	if (argcPtr != NULL) {
sl@0	965	*argcPtr = objc - 1;
sl@0	966	}
sl@0	967	if (argvPtr != NULL) {
sl@0	968	argvPtr = (CONST char *)
sl@0	969	ckalloc((unsigned) sizeof(CONST char ) (objc - 1));
sl@0	970	for (i = 1; i < objc; i++) {
sl@0	971	*argvPtr[i - 1] = Tcl_GetString(objv[i]);
sl@0	972	}
sl@0	973	}
sl@0	974	return TCL_OK;
sl@0	975	}
sl@0	976
sl@0	977	/*
sl@0	978	*----------------------------------------------------------------------
sl@0	979	*
sl@0	980	* Tcl_GetAliasObj --
sl@0	981	*
sl@0	982	* Object version: Gets information about an alias.
sl@0	983	*
sl@0	984	* Results:
sl@0	985	* A standard Tcl result.
sl@0	986	*
sl@0	987	* Side effects:
sl@0	988	* None.
sl@0	989	*
sl@0	990	*----------------------------------------------------------------------
sl@0	991	*/
sl@0	992
sl@0	993	EXPORT_C int
sl@0	994	Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
sl@0	995	objvPtr)
sl@0	996	Tcl_Interp interp; / Interp to start search from. */
sl@0	997	CONST char aliasName; / Name of alias to find. */
sl@0	998	Tcl_Interp *targetInterpPtr; / (Return) target interpreter. */
sl@0	999	CONST char *targetNamePtr; / (Return) name of target command. */
sl@0	1000	int objcPtr; / (Return) count of addnl args. */
sl@0	1001	Tcl_Obj **objvPtr; / (Return) additional args. */
sl@0	1002	{
sl@0	1003	InterpInfo *iiPtr;
sl@0	1004	Tcl_HashEntry *hPtr;
sl@0	1005	Alias *aliasPtr;
sl@0	1006	int objc;
sl@0	1007	Tcl_Obj **objv;
sl@0	1008
sl@0	1009	iiPtr = (InterpInfo ) ((Interp ) interp)->interpInfo;
sl@0	1010	hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
sl@0	1011	if (hPtr == (Tcl_HashEntry *) NULL) {
sl@0	1012	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1013	"alias \"", aliasName, "\" not found", (char *) NULL);
sl@0	1014	return TCL_ERROR;
sl@0	1015	}
sl@0	1016	aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
sl@0	1017	objc = aliasPtr->objc;
sl@0	1018	objv = &aliasPtr->objPtr;
sl@0	1019
sl@0	1020	if (targetInterpPtr != (Tcl_Interp **) NULL) {
sl@0	1021	*targetInterpPtr = aliasPtr->targetInterp;
sl@0	1022	}
sl@0	1023	if (targetNamePtr != (CONST char **) NULL) {
sl@0	1024	*targetNamePtr = Tcl_GetString(objv[0]);
sl@0	1025	}
sl@0	1026	if (objcPtr != (int *) NULL) {
sl@0	1027	*objcPtr = objc - 1;
sl@0	1028	}
sl@0	1029	if (objvPtr != (Tcl_Obj ***) NULL) {
sl@0	1030	*objvPtr = objv + 1;
sl@0	1031	}
sl@0	1032	return TCL_OK;
sl@0	1033	}
sl@0	1034
sl@0	1035	/*
sl@0	1036	*----------------------------------------------------------------------
sl@0	1037	*
sl@0	1038	* TclPreventAliasLoop --
sl@0	1039	*
sl@0	1040	* When defining an alias or renaming a command, prevent an alias
sl@0	1041	* loop from being formed.
sl@0	1042	*
sl@0	1043	* Results:
sl@0	1044	* A standard Tcl object result.
sl@0	1045	*
sl@0	1046	* Side effects:
sl@0	1047	* If TCL_ERROR is returned, the function also stores an error message
sl@0	1048	* in the interpreter's result object.
sl@0	1049	*
sl@0	1050	* NOTE:
sl@0	1051	* This function is public internal (instead of being static to
sl@0	1052	* this file) because it is also used from TclRenameCommand.
sl@0	1053	*
sl@0	1054	*----------------------------------------------------------------------
sl@0	1055	*/
sl@0	1056
sl@0	1057	int
sl@0	1058	TclPreventAliasLoop(interp, cmdInterp, cmd)
sl@0	1059	Tcl_Interp interp; / Interp in which to report errors. */
sl@0	1060	Tcl_Interp cmdInterp; / Interp in which the command is
sl@0	1061	* being defined. */
sl@0	1062	Tcl_Command cmd; /* Tcl command we are attempting
sl@0	1063	* to define. */
sl@0	1064	{
sl@0	1065	Command cmdPtr = (Command ) cmd;
sl@0	1066	Alias aliasPtr, nextAliasPtr;
sl@0	1067	Tcl_Command aliasCmd;
sl@0	1068	Command *aliasCmdPtr;
sl@0	1069
sl@0	1070	/*
sl@0	1071	* If we are not creating or renaming an alias, then it is
sl@0	1072	* always OK to create or rename the command.
sl@0	1073	*/
sl@0	1074
sl@0	1075	if (cmdPtr->objProc != AliasObjCmd) {
sl@0	1076	return TCL_OK;
sl@0	1077	}
sl@0	1078
sl@0	1079	/*
sl@0	1080	* OK, we are dealing with an alias, so traverse the chain of aliases.
sl@0	1081	* If we encounter the alias we are defining (or renaming to) any in
sl@0	1082	* the chain then we have a loop.
sl@0	1083	*/
sl@0	1084
sl@0	1085	aliasPtr = (Alias *) cmdPtr->objClientData;
sl@0	1086	nextAliasPtr = aliasPtr;
sl@0	1087	while (1) {
sl@0	1088	Tcl_Obj *cmdNamePtr;
sl@0	1089
sl@0	1090	/*
sl@0	1091	* If the target of the next alias in the chain is the same as
sl@0	1092	* the source alias, we have a loop.
sl@0	1093	*/
sl@0	1094
sl@0	1095	if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
sl@0	1096	/*
sl@0	1097	* The slave interpreter can be deleted while creating the alias.
sl@0	1098	* [Bug #641195]
sl@0	1099	*/
sl@0	1100
sl@0	1101	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1102	"cannot define or rename alias \"",
sl@0	1103	Tcl_GetString(aliasPtr->namePtr),
sl@0	1104	"\": interpreter deleted", (char *) NULL);
sl@0	1105	return TCL_ERROR;
sl@0	1106	}
sl@0	1107	cmdNamePtr = nextAliasPtr->objPtr;
sl@0	1108	aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
sl@0	1109	Tcl_GetString(cmdNamePtr),
sl@0	1110	Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
sl@0	1111	/flags/ 0);
sl@0	1112	if (aliasCmd == (Tcl_Command) NULL) {
sl@0	1113	return TCL_OK;
sl@0	1114	}
sl@0	1115	aliasCmdPtr = (Command *) aliasCmd;
sl@0	1116	if (aliasCmdPtr == cmdPtr) {
sl@0	1117	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1118	"cannot define or rename alias \"",
sl@0	1119	Tcl_GetString(aliasPtr->namePtr),
sl@0	1120	"\": would create a loop", (char *) NULL);
sl@0	1121	return TCL_ERROR;
sl@0	1122	}
sl@0	1123
sl@0	1124	/*
sl@0	1125	* Otherwise, follow the chain one step further. See if the target
sl@0	1126	* command is an alias - if so, follow the loop to its target
sl@0	1127	* command. Otherwise we do not have a loop.
sl@0	1128	*/
sl@0	1129
sl@0	1130	if (aliasCmdPtr->objProc != AliasObjCmd) {
sl@0	1131	return TCL_OK;
sl@0	1132	}
sl@0	1133	nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
sl@0	1134	}
sl@0	1135
sl@0	1136	/* NOTREACHED */
sl@0	1137	}
sl@0	1138
sl@0	1139	/*
sl@0	1140	*----------------------------------------------------------------------
sl@0	1141	*
sl@0	1142	* AliasCreate --
sl@0	1143	*
sl@0	1144	* Helper function to do the work to actually create an alias.
sl@0	1145	*
sl@0	1146	* Results:
sl@0	1147	* A standard Tcl result.
sl@0	1148	*
sl@0	1149	* Side effects:
sl@0	1150	* An alias command is created and entered into the alias table
sl@0	1151	* for the slave interpreter.
sl@0	1152	*
sl@0	1153	*----------------------------------------------------------------------
sl@0	1154	*/
sl@0	1155
sl@0	1156	static int
sl@0	1157	AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
sl@0	1158	objc, objv)
sl@0	1159	Tcl_Interp interp; / Interp for error reporting. */
sl@0	1160	Tcl_Interp slaveInterp; / Interp where alias cmd will live or from
sl@0	1161	* which alias will be deleted. */
sl@0	1162	Tcl_Interp masterInterp; / Interp in which target command will be
sl@0	1163	* invoked. */
sl@0	1164	Tcl_Obj namePtr; / Name of alias cmd. */
sl@0	1165	Tcl_Obj targetNamePtr; / Name of target cmd. */
sl@0	1166	int objc; /* Additional arguments to store */
sl@0	1167	Tcl_Obj CONST objv[]; / with alias. */
sl@0	1168	{
sl@0	1169	Alias *aliasPtr;
sl@0	1170	Tcl_HashEntry *hPtr;
sl@0	1171	Target *targetPtr;
sl@0	1172	Slave *slavePtr;
sl@0	1173	Master *masterPtr;
sl@0	1174	Tcl_Obj **prefv;
sl@0	1175	int new, i;
sl@0	1176
sl@0	1177	aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
sl@0	1178	+ objc * sizeof(Tcl_Obj *)));
sl@0	1179	aliasPtr->namePtr = namePtr;
sl@0	1180	Tcl_IncrRefCount(aliasPtr->namePtr);
sl@0	1181	aliasPtr->targetInterp = masterInterp;
sl@0	1182
sl@0	1183	aliasPtr->objc = objc + 1;
sl@0	1184	prefv = &aliasPtr->objPtr;
sl@0	1185
sl@0	1186	*prefv = targetNamePtr;
sl@0	1187	Tcl_IncrRefCount(targetNamePtr);
sl@0	1188	for (i = 0; i < objc; i++) {
sl@0	1189	*(++prefv) = objv[i];
sl@0	1190	Tcl_IncrRefCount(objv[i]);
sl@0	1191	}
sl@0	1192
sl@0	1193	Tcl_Preserve(slaveInterp);
sl@0	1194	Tcl_Preserve(masterInterp);
sl@0	1195
sl@0	1196	aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
sl@0	1197	Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
sl@0	1198	AliasObjCmdDeleteProc);
sl@0	1199
sl@0	1200	if (TclPreventAliasLoop(interp, slaveInterp,
sl@0	1201	aliasPtr->slaveCmd) != TCL_OK) {
sl@0	1202	/*
sl@0	1203	* Found an alias loop! The last call to Tcl_CreateObjCommand made
sl@0	1204	* the alias point to itself. Delete the command and its alias
sl@0	1205	* record. Be careful to wipe out its client data first, so the
sl@0	1206	* command doesn't try to delete itself.
sl@0	1207	*/
sl@0	1208
sl@0	1209	Command *cmdPtr;
sl@0	1210
sl@0	1211	Tcl_DecrRefCount(aliasPtr->namePtr);
sl@0	1212	Tcl_DecrRefCount(targetNamePtr);
sl@0	1213	for (i = 0; i < objc; i++) {
sl@0	1214	Tcl_DecrRefCount(objv[i]);
sl@0	1215	}
sl@0	1216
sl@0	1217	cmdPtr = (Command *) aliasPtr->slaveCmd;
sl@0	1218	cmdPtr->clientData = NULL;
sl@0	1219	cmdPtr->deleteProc = NULL;
sl@0	1220	cmdPtr->deleteData = NULL;
sl@0	1221	Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
sl@0	1222
sl@0	1223	ckfree((char *) aliasPtr);
sl@0	1224
sl@0	1225	/*
sl@0	1226	* The result was already set by TclPreventAliasLoop.
sl@0	1227	*/
sl@0	1228
sl@0	1229	Tcl_Release(slaveInterp);
sl@0	1230	Tcl_Release(masterInterp);
sl@0	1231	return TCL_ERROR;
sl@0	1232	}
sl@0	1233
sl@0	1234	/*
sl@0	1235	* Make an entry in the alias table. If it already exists delete
sl@0	1236	* the alias command. Then retry.
sl@0	1237	*/
sl@0	1238
sl@0	1239	slavePtr = &((InterpInfo ) ((Interp ) slaveInterp)->interpInfo)->slave;
sl@0	1240	while (1) {
sl@0	1241	Alias *oldAliasPtr;
sl@0	1242	char *string;
sl@0	1243
sl@0	1244	string = Tcl_GetString(namePtr);
sl@0	1245	hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
sl@0	1246	if (new != 0) {
sl@0	1247	break;
sl@0	1248	}
sl@0	1249
sl@0	1250	oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
sl@0	1251	Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd);
sl@0	1252	}
sl@0	1253
sl@0	1254	aliasPtr->aliasEntryPtr = hPtr;
sl@0	1255	Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
sl@0	1256
sl@0	1257	/*
sl@0	1258	* Create the new command. We must do it after deleting any old command,
sl@0	1259	* because the alias may be pointing at a renamed alias, as in:
sl@0	1260	*
sl@0	1261	* interp alias {} foo {} bar # Create an alias "foo"
sl@0	1262	* rename foo zop # Now rename the alias
sl@0	1263	* interp alias {} foo {} zop # Now recreate "foo"...
sl@0	1264	*/
sl@0	1265
sl@0	1266	targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
sl@0	1267	targetPtr->slaveCmd = aliasPtr->slaveCmd;
sl@0	1268	targetPtr->slaveInterp = slaveInterp;
sl@0	1269
sl@0	1270	Tcl_MutexLock(&cntMutex);
sl@0	1271	masterPtr = &((InterpInfo ) ((Interp ) masterInterp)->interpInfo)->master;
sl@0	1272	do {
sl@0	1273	hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable,
sl@0	1274	(char *) aliasCounter, &new);
sl@0	1275	aliasCounter++;
sl@0	1276	} while (new == 0);
sl@0	1277	Tcl_MutexUnlock(&cntMutex);
sl@0	1278
sl@0	1279	Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
sl@0	1280	aliasPtr->targetEntryPtr = hPtr;
sl@0	1281
sl@0	1282	Tcl_SetObjResult(interp, namePtr);
sl@0	1283
sl@0	1284	Tcl_Release(slaveInterp);
sl@0	1285	Tcl_Release(masterInterp);
sl@0	1286	return TCL_OK;
sl@0	1287	}
sl@0	1288
sl@0	1289	/*
sl@0	1290	*----------------------------------------------------------------------
sl@0	1291	*
sl@0	1292	* AliasDelete --
sl@0	1293	*
sl@0	1294	* Deletes the given alias from the slave interpreter given.
sl@0	1295	*
sl@0	1296	* Results:
sl@0	1297	* A standard Tcl result.
sl@0	1298	*
sl@0	1299	* Side effects:
sl@0	1300	* Deletes the alias from the slave interpreter.
sl@0	1301	*
sl@0	1302	*----------------------------------------------------------------------
sl@0	1303	*/
sl@0	1304
sl@0	1305	static int
sl@0	1306	AliasDelete(interp, slaveInterp, namePtr)
sl@0	1307	Tcl_Interp interp; / Interpreter for result & errors. */
sl@0	1308	Tcl_Interp slaveInterp; / Interpreter containing alias. */
sl@0	1309	Tcl_Obj namePtr; / Name of alias to delete. */
sl@0	1310	{
sl@0	1311	Slave *slavePtr;
sl@0	1312	Alias *aliasPtr;
sl@0	1313	Tcl_HashEntry *hPtr;
sl@0	1314
sl@0	1315	/*
sl@0	1316	* If the alias has been renamed in the slave, the master can still use
sl@0	1317	* the original name (with which it was created) to find the alias to
sl@0	1318	* delete it.
sl@0	1319	*/
sl@0	1320
sl@0	1321	slavePtr = &((InterpInfo ) ((Interp ) slaveInterp)->interpInfo)->slave;
sl@0	1322	hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
sl@0	1323	if (hPtr == NULL) {
sl@0	1324	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"",
sl@0	1325	Tcl_GetString(namePtr), "\" not found", NULL);
sl@0	1326	return TCL_ERROR;
sl@0	1327	}
sl@0	1328	aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
sl@0	1329	Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
sl@0	1330	return TCL_OK;
sl@0	1331	}
sl@0	1332
sl@0	1333	/*
sl@0	1334	*----------------------------------------------------------------------
sl@0	1335	*
sl@0	1336	* AliasDescribe --
sl@0	1337	*
sl@0	1338	* Sets the interpreter's result object to a Tcl list describing
sl@0	1339	* the given alias in the given interpreter: its target command
sl@0	1340	* and the additional arguments to prepend to any invocation
sl@0	1341	* of the alias.
sl@0	1342	*
sl@0	1343	* Results:
sl@0	1344	* A standard Tcl result.
sl@0	1345	*
sl@0	1346	* Side effects:
sl@0	1347	* None.
sl@0	1348	*
sl@0	1349	*----------------------------------------------------------------------
sl@0	1350	*/
sl@0	1351
sl@0	1352	static int
sl@0	1353	AliasDescribe(interp, slaveInterp, namePtr)
sl@0	1354	Tcl_Interp interp; / Interpreter for result & errors. */
sl@0	1355	Tcl_Interp slaveInterp; / Interpreter containing alias. */
sl@0	1356	Tcl_Obj namePtr; / Name of alias to describe. */
sl@0	1357	{
sl@0	1358	Slave *slavePtr;
sl@0	1359	Tcl_HashEntry *hPtr;
sl@0	1360	Alias *aliasPtr;
sl@0	1361	Tcl_Obj *prefixPtr;
sl@0	1362
sl@0	1363	/*
sl@0	1364	* If the alias has been renamed in the slave, the master can still use
sl@0	1365	* the original name (with which it was created) to find the alias to
sl@0	1366	* describe it.
sl@0	1367	*/
sl@0	1368
sl@0	1369	slavePtr = &((InterpInfo ) ((Interp ) slaveInterp)->interpInfo)->slave;
sl@0	1370	hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
sl@0	1371	if (hPtr == NULL) {
sl@0	1372	return TCL_OK;
sl@0	1373	}
sl@0	1374	aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
sl@0	1375	prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
sl@0	1376	Tcl_SetObjResult(interp, prefixPtr);
sl@0	1377	return TCL_OK;
sl@0	1378	}
sl@0	1379
sl@0	1380	/*
sl@0	1381	*----------------------------------------------------------------------
sl@0	1382	*
sl@0	1383	* AliasList --
sl@0	1384	*
sl@0	1385	* Computes a list of aliases defined in a slave interpreter.
sl@0	1386	*
sl@0	1387	* Results:
sl@0	1388	* A standard Tcl result.
sl@0	1389	*
sl@0	1390	* Side effects:
sl@0	1391	* None.
sl@0	1392	*
sl@0	1393	*----------------------------------------------------------------------
sl@0	1394	*/
sl@0	1395
sl@0	1396	static int
sl@0	1397	AliasList(interp, slaveInterp)
sl@0	1398	Tcl_Interp interp; / Interp for data return. */
sl@0	1399	Tcl_Interp slaveInterp; / Interp whose aliases to compute. */
sl@0	1400	{
sl@0	1401	Tcl_HashEntry *entryPtr;
sl@0	1402	Tcl_HashSearch hashSearch;
sl@0	1403	Tcl_Obj *resultPtr;
sl@0	1404	Alias *aliasPtr;
sl@0	1405	Slave *slavePtr;
sl@0	1406
sl@0	1407	slavePtr = &((InterpInfo ) ((Interp ) slaveInterp)->interpInfo)->slave;
sl@0	1408	resultPtr = Tcl_GetObjResult(interp);
sl@0	1409
sl@0	1410	entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
sl@0	1411	for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
sl@0	1412	aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
sl@0	1413	Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
sl@0	1414	}
sl@0	1415	return TCL_OK;
sl@0	1416	}
sl@0	1417
sl@0	1418	/*
sl@0	1419	*----------------------------------------------------------------------
sl@0	1420	*
sl@0	1421	* AliasObjCmd --
sl@0	1422	*
sl@0	1423	* This is the procedure that services invocations of aliases in a
sl@0	1424	* slave interpreter. One such command exists for each alias. When
sl@0	1425	* invoked, this procedure redirects the invocation to the target
sl@0	1426	* command in the master interpreter as designated by the Alias
sl@0	1427	* record associated with this command.
sl@0	1428	*
sl@0	1429	* Results:
sl@0	1430	* A standard Tcl result.
sl@0	1431	*
sl@0	1432	* Side effects:
sl@0	1433	* Causes forwarding of the invocation; all possible side effects
sl@0	1434	* may occur as a result of invoking the command to which the
sl@0	1435	* invocation is forwarded.
sl@0	1436	*
sl@0	1437	*----------------------------------------------------------------------
sl@0	1438	*/
sl@0	1439
sl@0	1440	static int
sl@0	1441	AliasObjCmd(clientData, interp, objc, objv)
sl@0	1442	ClientData clientData; /* Alias record. */
sl@0	1443	Tcl_Interp interp; / Current interpreter. */
sl@0	1444	int objc; /* Number of arguments. */
sl@0	1445	Tcl_Obj CONST objv[]; / Argument vector. */
sl@0	1446	{
sl@0	1447	#define ALIAS_CMDV_PREALLOC 10
sl@0	1448	Tcl_Interp *targetInterp;
sl@0	1449	Alias *aliasPtr;
sl@0	1450	int result, prefc, cmdc, i;
sl@0	1451	Tcl_Obj prefv, cmdv;
sl@0	1452	Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
sl@0	1453	aliasPtr = (Alias *) clientData;
sl@0	1454	targetInterp = aliasPtr->targetInterp;
sl@0	1455
sl@0	1456	/*
sl@0	1457	* Append the arguments to the command prefix and invoke the command
sl@0	1458	* in the target interp's global namespace.
sl@0	1459	*/
sl@0	1460
sl@0	1461	prefc = aliasPtr->objc;
sl@0	1462	prefv = &aliasPtr->objPtr;
sl@0	1463	cmdc = prefc + objc - 1;
sl@0	1464	if (cmdc <= ALIAS_CMDV_PREALLOC) {
sl@0	1465	cmdv = cmdArr;
sl@0	1466	} else {
sl@0	1467	cmdv = (Tcl_Obj *) ckalloc((unsigned) (cmdc sizeof(Tcl_Obj *)));
sl@0	1468	}
sl@0	1469
sl@0	1470	prefv = &aliasPtr->objPtr;
sl@0	1471	memcpy((VOID ) cmdv, (VOID ) prefv,
sl@0	1472	(size_t) (prefc * sizeof(Tcl_Obj *)));
sl@0	1473	memcpy((VOID ) (cmdv+prefc), (VOID ) (objv+1),
sl@0	1474	(size_t) ((objc-1) * sizeof(Tcl_Obj *)));
sl@0	1475
sl@0	1476	Tcl_ResetResult(targetInterp);
sl@0	1477
sl@0	1478	for (i=0; i<cmdc; i++) {
sl@0	1479	Tcl_IncrRefCount(cmdv[i]);
sl@0	1480	}
sl@0	1481	if (targetInterp != interp) {
sl@0	1482	Tcl_Preserve((ClientData) targetInterp);
sl@0	1483	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
sl@0	1484	TclTransferResult(targetInterp, result, interp);
sl@0	1485	Tcl_Release((ClientData) targetInterp);
sl@0	1486	} else {
sl@0	1487	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
sl@0	1488	}
sl@0	1489	for (i=0; i<cmdc; i++) {
sl@0	1490	Tcl_DecrRefCount(cmdv[i]);
sl@0	1491	}
sl@0	1492
sl@0	1493	if (cmdv != cmdArr) {
sl@0	1494	ckfree((char *) cmdv);
sl@0	1495	}
sl@0	1496	return result;
sl@0	1497	#undef ALIAS_CMDV_PREALLOC
sl@0	1498	}
sl@0	1499
sl@0	1500	/*
sl@0	1501	*----------------------------------------------------------------------
sl@0	1502	*
sl@0	1503	* AliasObjCmdDeleteProc --
sl@0	1504	*
sl@0	1505	* Is invoked when an alias command is deleted in a slave. Cleans up
sl@0	1506	* all storage associated with this alias.
sl@0	1507	*
sl@0	1508	* Results:
sl@0	1509	* None.
sl@0	1510	*
sl@0	1511	* Side effects:
sl@0	1512	* Deletes the alias record and its entry in the alias table for
sl@0	1513	* the interpreter.
sl@0	1514	*
sl@0	1515	*----------------------------------------------------------------------
sl@0	1516	*/
sl@0	1517
sl@0	1518	static void
sl@0	1519	AliasObjCmdDeleteProc(clientData)
sl@0	1520	ClientData clientData; /* The alias record for this alias. */
sl@0	1521	{
sl@0	1522	Alias *aliasPtr;
sl@0	1523	Target *targetPtr;
sl@0	1524	int i;
sl@0	1525	Tcl_Obj **objv;
sl@0	1526
sl@0	1527	aliasPtr = (Alias *) clientData;
sl@0	1528
sl@0	1529	Tcl_DecrRefCount(aliasPtr->namePtr);
sl@0	1530	objv = &aliasPtr->objPtr;
sl@0	1531	for (i = 0; i < aliasPtr->objc; i++) {
sl@0	1532	Tcl_DecrRefCount(objv[i]);
sl@0	1533	}
sl@0	1534	Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
sl@0	1535
sl@0	1536	targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
sl@0	1537	ckfree((char *) targetPtr);
sl@0	1538	Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);
sl@0	1539
sl@0	1540	ckfree((char *) aliasPtr);
sl@0	1541	}
sl@0	1542
sl@0	1543	/*
sl@0	1544	*----------------------------------------------------------------------
sl@0	1545	*
sl@0	1546	* Tcl_CreateSlave --
sl@0	1547	*
sl@0	1548	* Creates a slave interpreter. The slavePath argument denotes the
sl@0	1549	* name of the new slave relative to the current interpreter; the
sl@0	1550	* slave is a direct descendant of the one-before-last component of
sl@0	1551	* the path, e.g. it is a descendant of the current interpreter if
sl@0	1552	* the slavePath argument contains only one component. Optionally makes
sl@0	1553	* the slave interpreter safe.
sl@0	1554	*
sl@0	1555	* Results:
sl@0	1556	* Returns the interpreter structure created, or NULL if an error
sl@0	1557	* occurred.
sl@0	1558	*
sl@0	1559	* Side effects:
sl@0	1560	* Creates a new interpreter and a new interpreter object command in
sl@0	1561	* the interpreter indicated by the slavePath argument.
sl@0	1562	*
sl@0	1563	*----------------------------------------------------------------------
sl@0	1564	*/
sl@0	1565
sl@0	1566	EXPORT_C Tcl_Interp *
sl@0	1567	Tcl_CreateSlave(interp, slavePath, isSafe)
sl@0	1568	Tcl_Interp interp; / Interpreter to start search at. */
sl@0	1569	CONST char slavePath; / Name of slave to create. */
sl@0	1570	int isSafe; /* Should new slave be "safe" ? */
sl@0	1571	{
sl@0	1572	Tcl_Obj *pathPtr;
sl@0	1573	Tcl_Interp *slaveInterp;
sl@0	1574
sl@0	1575	pathPtr = Tcl_NewStringObj(slavePath, -1);
sl@0	1576	slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
sl@0	1577	Tcl_DecrRefCount(pathPtr);
sl@0	1578
sl@0	1579	return slaveInterp;
sl@0	1580	}
sl@0	1581
sl@0	1582	/*
sl@0	1583	*----------------------------------------------------------------------
sl@0	1584	*
sl@0	1585	* Tcl_GetSlave --
sl@0	1586	*
sl@0	1587	* Finds a slave interpreter by its path name.
sl@0	1588	*
sl@0	1589	* Results:
sl@0	1590	* Returns a Tcl_Interp * for the named interpreter or NULL if not
sl@0	1591	* found.
sl@0	1592	*
sl@0	1593	* Side effects:
sl@0	1594	* None.
sl@0	1595	*
sl@0	1596	*----------------------------------------------------------------------
sl@0	1597	*/
sl@0	1598
sl@0	1599	EXPORT_C Tcl_Interp *
sl@0	1600	Tcl_GetSlave(interp, slavePath)
sl@0	1601	Tcl_Interp interp; / Interpreter to start search from. */
sl@0	1602	CONST char slavePath; / Path of slave to find. */
sl@0	1603	{
sl@0	1604	Tcl_Obj *pathPtr;
sl@0	1605	Tcl_Interp *slaveInterp;
sl@0	1606
sl@0	1607	pathPtr = Tcl_NewStringObj(slavePath, -1);
sl@0	1608	slaveInterp = GetInterp(interp, pathPtr);
sl@0	1609	Tcl_DecrRefCount(pathPtr);
sl@0	1610
sl@0	1611	return slaveInterp;
sl@0	1612	}
sl@0	1613
sl@0	1614	/*
sl@0	1615	*----------------------------------------------------------------------
sl@0	1616	*
sl@0	1617	* Tcl_GetMaster --
sl@0	1618	*
sl@0	1619	* Finds the master interpreter of a slave interpreter.
sl@0	1620	*
sl@0	1621	* Results:
sl@0	1622	* Returns a Tcl_Interp * for the master interpreter or NULL if none.
sl@0	1623	*
sl@0	1624	* Side effects:
sl@0	1625	* None.
sl@0	1626	*
sl@0	1627	*----------------------------------------------------------------------
sl@0	1628	*/
sl@0	1629
sl@0	1630	EXPORT_C Tcl_Interp *
sl@0	1631	Tcl_GetMaster(interp)
sl@0	1632	Tcl_Interp interp; / Get the master of this interpreter. */
sl@0	1633	{
sl@0	1634	Slave slavePtr; / Slave record of this interpreter. */
sl@0	1635
sl@0	1636	if (interp == (Tcl_Interp *) NULL) {
sl@0	1637	return NULL;
sl@0	1638	}
sl@0	1639	slavePtr = &((InterpInfo ) ((Interp ) interp)->interpInfo)->slave;
sl@0	1640	return slavePtr->masterInterp;
sl@0	1641	}
sl@0	1642
sl@0	1643	/*
sl@0	1644	*----------------------------------------------------------------------
sl@0	1645	*
sl@0	1646	* Tcl_GetInterpPath --
sl@0	1647	*
sl@0	1648	* Sets the result of the asking interpreter to a proper Tcl list
sl@0	1649	* containing the names of interpreters between the asking and
sl@0	1650	* target interpreters. The target interpreter must be either the
sl@0	1651	* same as the asking interpreter or one of its slaves (including
sl@0	1652	* recursively).
sl@0	1653	*
sl@0	1654	* Results:
sl@0	1655	* TCL_OK if the target interpreter is the same as, or a descendant
sl@0	1656	* of, the asking interpreter; TCL_ERROR else. This way one can
sl@0	1657	* distinguish between the case where the asking and target interps
sl@0	1658	* are the same (an empty list is the result, and TCL_OK is returned)
sl@0	1659	* and when the target is not a descendant of the asking interpreter
sl@0	1660	* (in which case the Tcl result is an error message and the function
sl@0	1661	* returns TCL_ERROR).
sl@0	1662	*
sl@0	1663	* Side effects:
sl@0	1664	* None.
sl@0	1665	*
sl@0	1666	*----------------------------------------------------------------------
sl@0	1667	*/
sl@0	1668
sl@0	1669	EXPORT_C int
sl@0	1670	Tcl_GetInterpPath(askingInterp, targetInterp)
sl@0	1671	Tcl_Interp askingInterp; / Interpreter to start search from. */
sl@0	1672	Tcl_Interp targetInterp; / Interpreter to find. */
sl@0	1673	{
sl@0	1674	InterpInfo *iiPtr;
sl@0	1675
sl@0	1676	if (targetInterp == askingInterp) {
sl@0	1677	return TCL_OK;
sl@0	1678	}
sl@0	1679	if (targetInterp == NULL) {
sl@0	1680	return TCL_ERROR;
sl@0	1681	}
sl@0	1682	iiPtr = (InterpInfo ) ((Interp ) targetInterp)->interpInfo;
sl@0	1683	if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
sl@0	1684	return TCL_ERROR;
sl@0	1685	}
sl@0	1686	Tcl_AppendElement(askingInterp,
sl@0	1687	Tcl_GetHashKey(&iiPtr->master.slaveTable,
sl@0	1688	iiPtr->slave.slaveEntryPtr));
sl@0	1689	return TCL_OK;
sl@0	1690	}
sl@0	1691
sl@0	1692	/*
sl@0	1693	*----------------------------------------------------------------------
sl@0	1694	*
sl@0	1695	* GetInterp --
sl@0	1696	*
sl@0	1697	* Helper function to find a slave interpreter given a pathname.
sl@0	1698	*
sl@0	1699	* Results:
sl@0	1700	* Returns the slave interpreter known by that name in the calling
sl@0	1701	* interpreter, or NULL if no interpreter known by that name exists.
sl@0	1702	*
sl@0	1703	* Side effects:
sl@0	1704	* Assigns to the pointer variable passed in, if not NULL.
sl@0	1705	*
sl@0	1706	*----------------------------------------------------------------------
sl@0	1707	*/
sl@0	1708
sl@0	1709	static Tcl_Interp *
sl@0	1710	GetInterp(interp, pathPtr)
sl@0	1711	Tcl_Interp interp; / Interp. to start search from. */
sl@0	1712	Tcl_Obj pathPtr; / List object containing name of interp. to
sl@0	1713	* be found. */
sl@0	1714	{
sl@0	1715	Tcl_HashEntry hPtr; / Search element. */
sl@0	1716	Slave slavePtr; / Interim slave record. */
sl@0	1717	Tcl_Obj **objv;
sl@0	1718	int objc, i;
sl@0	1719	Tcl_Interp searchInterp; / Interim storage for interp. to find. */
sl@0	1720	InterpInfo *masterInfoPtr;
sl@0	1721
sl@0	1722	if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
sl@0	1723	return NULL;
sl@0	1724	}
sl@0	1725
sl@0	1726	searchInterp = interp;
sl@0	1727	for (i = 0; i < objc; i++) {
sl@0	1728	masterInfoPtr = (InterpInfo ) ((Interp ) searchInterp)->interpInfo;
sl@0	1729	hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
sl@0	1730	Tcl_GetString(objv[i]));
sl@0	1731	if (hPtr == NULL) {
sl@0	1732	searchInterp = NULL;
sl@0	1733	break;
sl@0	1734	}
sl@0	1735	slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
sl@0	1736	searchInterp = slavePtr->slaveInterp;
sl@0	1737	if (searchInterp == NULL) {
sl@0	1738	break;
sl@0	1739	}
sl@0	1740	}
sl@0	1741	if (searchInterp == NULL) {
sl@0	1742	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1743	"could not find interpreter \"",
sl@0	1744	Tcl_GetString(pathPtr), "\"", (char *) NULL);
sl@0	1745	}
sl@0	1746	return searchInterp;
sl@0	1747	}
sl@0	1748
sl@0	1749	/*
sl@0	1750	*----------------------------------------------------------------------
sl@0	1751	*
sl@0	1752	* SlaveCreate --
sl@0	1753	*
sl@0	1754	* Helper function to do the actual work of creating a slave interp
sl@0	1755	* and new object command. Also optionally makes the new slave
sl@0	1756	* interpreter "safe".
sl@0	1757	*
sl@0	1758	* Results:
sl@0	1759	* Returns the new Tcl_Interp * if successful or NULL if not. If failed,
sl@0	1760	* the result of the invoking interpreter contains an error message.
sl@0	1761	*
sl@0	1762	* Side effects:
sl@0	1763	* Creates a new slave interpreter and a new object command.
sl@0	1764	*
sl@0	1765	*----------------------------------------------------------------------
sl@0	1766	*/
sl@0	1767
sl@0	1768	static Tcl_Interp *
sl@0	1769	SlaveCreate(interp, pathPtr, safe)
sl@0	1770	Tcl_Interp interp; / Interp. to start search from. */
sl@0	1771	Tcl_Obj pathPtr; / Path (name) of slave to create. */
sl@0	1772	int safe; /* Should we make it "safe"? */
sl@0	1773	{
sl@0	1774	Tcl_Interp masterInterp, slaveInterp;
sl@0	1775	Slave *slavePtr;
sl@0	1776	InterpInfo *masterInfoPtr;
sl@0	1777	Tcl_HashEntry *hPtr;
sl@0	1778	char *path;
sl@0	1779	int new, objc;
sl@0	1780	Tcl_Obj **objv;
sl@0	1781
sl@0	1782	if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
sl@0	1783	return NULL;
sl@0	1784	}
sl@0	1785	if (objc < 2) {
sl@0	1786	masterInterp = interp;
sl@0	1787	path = Tcl_GetString(pathPtr);
sl@0	1788	} else {
sl@0	1789	Tcl_Obj *objPtr;
sl@0	1790
sl@0	1791	objPtr = Tcl_NewListObj(objc - 1, objv);
sl@0	1792	masterInterp = GetInterp(interp, objPtr);
sl@0	1793	Tcl_DecrRefCount(objPtr);
sl@0	1794	if (masterInterp == NULL) {
sl@0	1795	return NULL;
sl@0	1796	}
sl@0	1797	path = Tcl_GetString(objv[objc - 1]);
sl@0	1798	}
sl@0	1799	if (safe == 0) {
sl@0	1800	safe = Tcl_IsSafe(masterInterp);
sl@0	1801	}
sl@0	1802
sl@0	1803	masterInfoPtr = (InterpInfo ) ((Interp ) masterInterp)->interpInfo;
sl@0	1804	hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
sl@0	1805	if (new == 0) {
sl@0	1806	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1807	"interpreter named \"", path,
sl@0	1808	"\" already exists, cannot create", (char *) NULL);
sl@0	1809	return NULL;
sl@0	1810	}
sl@0	1811
sl@0	1812	slaveInterp = Tcl_CreateInterp();
sl@0	1813	slavePtr = &((InterpInfo ) ((Interp ) slaveInterp)->interpInfo)->slave;
sl@0	1814	slavePtr->masterInterp = masterInterp;
sl@0	1815	slavePtr->slaveEntryPtr = hPtr;
sl@0	1816	slavePtr->slaveInterp = slaveInterp;
sl@0	1817	slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
sl@0	1818	SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
sl@0	1819	Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
sl@0	1820	Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
sl@0	1821	Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
sl@0	1822
sl@0	1823	/*
sl@0	1824	* Inherit the recursion limit.
sl@0	1825	*/
sl@0	1826	((Interp *) slaveInterp)->maxNestingDepth =
sl@0	1827	((Interp *) masterInterp)->maxNestingDepth ;
sl@0	1828
sl@0	1829	if (safe) {
sl@0	1830	if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
sl@0	1831	goto error;
sl@0	1832	}
sl@0	1833	} else {
sl@0	1834	if (Tcl_Init(slaveInterp) == TCL_ERROR) {
sl@0	1835	goto error;
sl@0	1836	}
sl@0	1837	/*
sl@0	1838	* This will create the "memory" command in slave interpreters
sl@0	1839	* if we compiled with TCL_MEM_DEBUG, otherwise it does nothing.
sl@0	1840	*/
sl@0	1841	Tcl_InitMemory(slaveInterp);
sl@0	1842	}
sl@0	1843	return slaveInterp;
sl@0	1844
sl@0	1845	error:
sl@0	1846	TclTransferResult(slaveInterp, TCL_ERROR, interp);
sl@0	1847	Tcl_DeleteInterp(slaveInterp);
sl@0	1848
sl@0	1849	return NULL;
sl@0	1850	}
sl@0	1851
sl@0	1852	/*
sl@0	1853	*----------------------------------------------------------------------
sl@0	1854	*
sl@0	1855	* SlaveObjCmd --
sl@0	1856	*
sl@0	1857	* Command to manipulate an interpreter, e.g. to send commands to it
sl@0	1858	* to be evaluated. One such command exists for each slave interpreter.
sl@0	1859	*
sl@0	1860	* Results:
sl@0	1861	* A standard Tcl result.
sl@0	1862	*
sl@0	1863	* Side effects:
sl@0	1864	* See user documentation for details.
sl@0	1865	*
sl@0	1866	*----------------------------------------------------------------------
sl@0	1867	*/
sl@0	1868
sl@0	1869	static int
sl@0	1870	SlaveObjCmd(clientData, interp, objc, objv)
sl@0	1871	ClientData clientData; /* Slave interpreter. */
sl@0	1872	Tcl_Interp interp; / Current interpreter. */
sl@0	1873	int objc; /* Number of arguments. */
sl@0	1874	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1875	{
sl@0	1876	Tcl_Interp *slaveInterp;
sl@0	1877	int index;
sl@0	1878	static CONST char *options[] = {
sl@0	1879	"alias", "aliases", "eval", "expose",
sl@0	1880	"hide", "hidden", "issafe", "invokehidden",
sl@0	1881	"marktrusted", "recursionlimit", NULL
sl@0	1882	};
sl@0	1883	enum options {
sl@0	1884	OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
sl@0	1885	OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
sl@0	1886	OPT_MARKTRUSTED, OPT_RECLIMIT
sl@0	1887	};
sl@0	1888
sl@0	1889	slaveInterp = (Tcl_Interp *) clientData;
sl@0	1890	if (slaveInterp == NULL) {
sl@0	1891	panic("SlaveObjCmd: interpreter has been deleted");
sl@0	1892	}
sl@0	1893
sl@0	1894	if (objc < 2) {
sl@0	1895	Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
sl@0	1896	return TCL_ERROR;
sl@0	1897	}
sl@0	1898	if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
sl@0	1899	&index) != TCL_OK) {
sl@0	1900	return TCL_ERROR;
sl@0	1901	}
sl@0	1902
sl@0	1903	switch ((enum options) index) {
sl@0	1904	case OPT_ALIAS: {
sl@0	1905	if (objc > 2) {
sl@0	1906	if (objc == 3) {
sl@0	1907	return AliasDescribe(interp, slaveInterp, objv[2]);
sl@0	1908	}
sl@0	1909	if (Tcl_GetString(objv[3])[0] == '\0') {
sl@0	1910	if (objc == 4) {
sl@0	1911	return AliasDelete(interp, slaveInterp, objv[2]);
sl@0	1912	}
sl@0	1913	} else {
sl@0	1914	return AliasCreate(interp, slaveInterp, interp, objv[2],
sl@0	1915	objv[3], objc - 4, objv + 4);
sl@0	1916	}
sl@0	1917	}
sl@0	1918	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	1919	"aliasName ?targetName? ?args..?");
sl@0	1920	return TCL_ERROR;
sl@0	1921	}
sl@0	1922	case OPT_ALIASES: {
sl@0	1923	if (objc != 2) {
sl@0	1924	Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
sl@0	1925	return TCL_ERROR;
sl@0	1926	}
sl@0	1927	return AliasList(interp, slaveInterp);
sl@0	1928	}
sl@0	1929	case OPT_EVAL: {
sl@0	1930	if (objc < 3) {
sl@0	1931	Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
sl@0	1932	return TCL_ERROR;
sl@0	1933	}
sl@0	1934	return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
sl@0	1935	}
sl@0	1936	case OPT_EXPOSE: {
sl@0	1937	if ((objc < 3) \|\| (objc > 4)) {
sl@0	1938	Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
sl@0	1939	return TCL_ERROR;
sl@0	1940	}
sl@0	1941	return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
sl@0	1942	}
sl@0	1943	case OPT_HIDE: {
sl@0	1944	if ((objc < 3) \|\| (objc > 4)) {
sl@0	1945	Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
sl@0	1946	return TCL_ERROR;
sl@0	1947	}
sl@0	1948	return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
sl@0	1949	}
sl@0	1950	case OPT_HIDDEN: {
sl@0	1951	if (objc != 2) {
sl@0	1952	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	1953	return TCL_ERROR;
sl@0	1954	}
sl@0	1955	return SlaveHidden(interp, slaveInterp);
sl@0	1956	}
sl@0	1957	case OPT_ISSAFE: {
sl@0	1958	if (objc != 2) {
sl@0	1959	Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
sl@0	1960	return TCL_ERROR;
sl@0	1961	}
sl@0	1962	Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
sl@0	1963	return TCL_OK;
sl@0	1964	}
sl@0	1965	case OPT_INVOKEHIDDEN: {
sl@0	1966	int global, i, index;
sl@0	1967	static CONST char *hiddenOptions[] = {
sl@0	1968	"-global", "--", NULL
sl@0	1969	};
sl@0	1970	enum hiddenOption {
sl@0	1971	OPT_GLOBAL, OPT_LAST
sl@0	1972	};
sl@0	1973	global = 0;
sl@0	1974	for (i = 2; i < objc; i++) {
sl@0	1975	if (Tcl_GetString(objv[i])[0] != '-') {
sl@0	1976	break;
sl@0	1977	}
sl@0	1978	if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
sl@0	1979	"option", 0, &index) != TCL_OK) {
sl@0	1980	return TCL_ERROR;
sl@0	1981	}
sl@0	1982	if (index == OPT_GLOBAL) {
sl@0	1983	global = 1;
sl@0	1984	} else {
sl@0	1985	i++;
sl@0	1986	break;
sl@0	1987	}
sl@0	1988	}
sl@0	1989	if (objc - i < 1) {
sl@0	1990	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	1991	"?-global? ?--? cmd ?arg ..?");
sl@0	1992	return TCL_ERROR;
sl@0	1993	}
sl@0	1994	return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
sl@0	1995	objv + i);
sl@0	1996	}
sl@0	1997	case OPT_MARKTRUSTED: {
sl@0	1998	if (objc != 2) {
sl@0	1999	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	2000	return TCL_ERROR;
sl@0	2001	}
sl@0	2002	return SlaveMarkTrusted(interp, slaveInterp);
sl@0	2003	}
sl@0	2004	case OPT_RECLIMIT: {
sl@0	2005	if (objc != 2 && objc != 3) {
sl@0	2006	Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
sl@0	2007	return TCL_ERROR;
sl@0	2008	}
sl@0	2009	return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
sl@0	2010	}
sl@0	2011	}
sl@0	2012
sl@0	2013	return TCL_ERROR;
sl@0	2014	}
sl@0	2015
sl@0	2016	/*
sl@0	2017	*----------------------------------------------------------------------
sl@0	2018	*
sl@0	2019	* SlaveObjCmdDeleteProc --
sl@0	2020	*
sl@0	2021	* Invoked when an object command for a slave interpreter is deleted;
sl@0	2022	* cleans up all state associated with the slave interpreter and destroys
sl@0	2023	* the slave interpreter.
sl@0	2024	*
sl@0	2025	* Results:
sl@0	2026	* None.
sl@0	2027	*
sl@0	2028	* Side effects:
sl@0	2029	* Cleans up all state associated with the slave interpreter and
sl@0	2030	* destroys the slave interpreter.
sl@0	2031	*
sl@0	2032	*----------------------------------------------------------------------
sl@0	2033	*/
sl@0	2034
sl@0	2035	static void
sl@0	2036	SlaveObjCmdDeleteProc(clientData)
sl@0	2037	ClientData clientData; /* The SlaveRecord for the command. */
sl@0	2038	{
sl@0	2039	Slave slavePtr; / Interim storage for Slave record. */
sl@0	2040	Tcl_Interp slaveInterp; / And for a slave interp. */
sl@0	2041
sl@0	2042	slaveInterp = (Tcl_Interp *) clientData;
sl@0	2043	slavePtr = &((InterpInfo ) ((Interp ) slaveInterp)->interpInfo)->slave;
sl@0	2044
sl@0	2045	/*
sl@0	2046	* Unlink the slave from its master interpreter.
sl@0	2047	*/
sl@0	2048
sl@0	2049	Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);
sl@0	2050
sl@0	2051	/*
sl@0	2052	* Set to NULL so that when the InterpInfo is cleaned up in the slave
sl@0	2053	* it does not try to delete the command causing all sorts of grief.
sl@0	2054	* See SlaveRecordDeleteProc().
sl@0	2055	*/
sl@0	2056
sl@0	2057	slavePtr->interpCmd = NULL;
sl@0	2058
sl@0	2059	if (slavePtr->slaveInterp != NULL) {
sl@0	2060	Tcl_DeleteInterp(slavePtr->slaveInterp);
sl@0	2061	}
sl@0	2062	}
sl@0	2063
sl@0	2064	/*
sl@0	2065	*----------------------------------------------------------------------
sl@0	2066	*
sl@0	2067	* SlaveEval --
sl@0	2068	*
sl@0	2069	* Helper function to evaluate a command in a slave interpreter.
sl@0	2070	*
sl@0	2071	* Results:
sl@0	2072	* A standard Tcl result.
sl@0	2073	*
sl@0	2074	* Side effects:
sl@0	2075	* Whatever the command does.
sl@0	2076	*
sl@0	2077	*----------------------------------------------------------------------
sl@0	2078	*/
sl@0	2079
sl@0	2080	static int
sl@0	2081	SlaveEval(interp, slaveInterp, objc, objv)
sl@0	2082	Tcl_Interp interp; / Interp for error return. */
sl@0	2083	Tcl_Interp slaveInterp; / The slave interpreter in which command
sl@0	2084	* will be evaluated. */
sl@0	2085	int objc; /* Number of arguments. */
sl@0	2086	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2087	{
sl@0	2088	int result;
sl@0	2089	Tcl_Obj *objPtr;
sl@0	2090
sl@0	2091	Tcl_Preserve((ClientData) slaveInterp);
sl@0	2092	Tcl_AllowExceptions(slaveInterp);
sl@0	2093
sl@0	2094	if (objc == 1) {
sl@0	2095	#ifndef TCL_TIP280
sl@0	2096	result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
sl@0	2097	#else
sl@0	2098	/* TIP #280 : Make invoker available to eval'd script */
sl@0	2099	Interp* iPtr = (Interp*) interp;
sl@0	2100	result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0);
sl@0	2101	#endif
sl@0	2102	} else {
sl@0	2103	objPtr = Tcl_ConcatObj(objc, objv);
sl@0	2104	Tcl_IncrRefCount(objPtr);
sl@0	2105	result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
sl@0	2106	Tcl_DecrRefCount(objPtr);
sl@0	2107	}
sl@0	2108	TclTransferResult(slaveInterp, result, interp);
sl@0	2109
sl@0	2110	Tcl_Release((ClientData) slaveInterp);
sl@0	2111	return result;
sl@0	2112	}
sl@0	2113
sl@0	2114	/*
sl@0	2115	*----------------------------------------------------------------------
sl@0	2116	*
sl@0	2117	* SlaveExpose --
sl@0	2118	*
sl@0	2119	* Helper function to expose a command in a slave interpreter.
sl@0	2120	*
sl@0	2121	* Results:
sl@0	2122	* A standard Tcl result.
sl@0	2123	*
sl@0	2124	* Side effects:
sl@0	2125	* After this call scripts in the slave will be able to invoke
sl@0	2126	* the newly exposed command.
sl@0	2127	*
sl@0	2128	*----------------------------------------------------------------------
sl@0	2129	*/
sl@0	2130
sl@0	2131	static int
sl@0	2132	SlaveExpose(interp, slaveInterp, objc, objv)
sl@0	2133	Tcl_Interp interp; / Interp for error return. */
sl@0	2134	Tcl_Interp slaveInterp; / Interp in which command will be exposed. */
sl@0	2135	int objc; /* Number of arguments. */
sl@0	2136	Tcl_Obj CONST objv[]; / Argument strings. */
sl@0	2137	{
sl@0	2138	char *name;
sl@0	2139
sl@0	2140	if (Tcl_IsSafe(interp)) {
sl@0	2141	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2142	"permission denied: safe interpreter cannot expose commands",
sl@0	2143	(char *) NULL);
sl@0	2144	return TCL_ERROR;
sl@0	2145	}
sl@0	2146
sl@0	2147	name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
sl@0	2148	if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
sl@0	2149	name) != TCL_OK) {
sl@0	2150	TclTransferResult(slaveInterp, TCL_ERROR, interp);
sl@0	2151	return TCL_ERROR;
sl@0	2152	}
sl@0	2153	return TCL_OK;
sl@0	2154	}
sl@0	2155
sl@0	2156	/*
sl@0	2157	*----------------------------------------------------------------------
sl@0	2158	*
sl@0	2159	* SlaveRecursionLimit --
sl@0	2160	*
sl@0	2161	* Helper function to set/query the Recursion limit of an interp
sl@0	2162	*
sl@0	2163	* Results:
sl@0	2164	* A standard Tcl result.
sl@0	2165	*
sl@0	2166	* Side effects:
sl@0	2167	* When (objc == 1), slaveInterp will be set to a new recursion
sl@0	2168	* limit of objv[0].
sl@0	2169	*
sl@0	2170	*----------------------------------------------------------------------
sl@0	2171	*/
sl@0	2172
sl@0	2173	static int
sl@0	2174	SlaveRecursionLimit(interp, slaveInterp, objc, objv)
sl@0	2175	Tcl_Interp interp; / Interp for error return. */
sl@0	2176	Tcl_Interp slaveInterp; / Interp in which limit is set/queried. */
sl@0	2177	int objc; /* Set or Query. */
sl@0	2178	Tcl_Obj CONST objv[]; / Argument strings. */
sl@0	2179	{
sl@0	2180	Interp *iPtr;
sl@0	2181	int limit;
sl@0	2182
sl@0	2183	if (objc) {
sl@0	2184	if (Tcl_IsSafe(interp)) {
sl@0	2185	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2186	"permission denied: ",
sl@0	2187	"safe interpreters cannot change recursion limit",
sl@0	2188	(char *) NULL);
sl@0	2189	return TCL_ERROR;
sl@0	2190	}
sl@0	2191	if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
sl@0	2192	return TCL_ERROR;
sl@0	2193	}
sl@0	2194	if (limit <= 0) {
sl@0	2195	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	2196	"recursion limit must be > 0", -1));
sl@0	2197	return TCL_ERROR;
sl@0	2198	}
sl@0	2199	Tcl_SetRecursionLimit(slaveInterp, limit);
sl@0	2200	iPtr = (Interp *) slaveInterp;
sl@0	2201	if (interp == slaveInterp && iPtr->numLevels > limit) {
sl@0	2202	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	2203	"falling back due to new recursion limit", -1));
sl@0	2204	return TCL_ERROR;
sl@0	2205	}
sl@0	2206	Tcl_SetObjResult(interp, objv[0]);
sl@0	2207	return TCL_OK;
sl@0	2208	} else {
sl@0	2209	limit = Tcl_SetRecursionLimit(slaveInterp, 0);
sl@0	2210	Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
sl@0	2211	return TCL_OK;
sl@0	2212	}
sl@0	2213	}
sl@0	2214
sl@0	2215	/*
sl@0	2216	*----------------------------------------------------------------------
sl@0	2217	*
sl@0	2218	* SlaveHide --
sl@0	2219	*
sl@0	2220	* Helper function to hide a command in a slave interpreter.
sl@0	2221	*
sl@0	2222	* Results:
sl@0	2223	* A standard Tcl result.
sl@0	2224	*
sl@0	2225	* Side effects:
sl@0	2226	* After this call scripts in the slave will no longer be able
sl@0	2227	* to invoke the named command.
sl@0	2228	*
sl@0	2229	*----------------------------------------------------------------------
sl@0	2230	*/
sl@0	2231
sl@0	2232	static int
sl@0	2233	SlaveHide(interp, slaveInterp, objc, objv)
sl@0	2234	Tcl_Interp interp; / Interp for error return. */
sl@0	2235	Tcl_Interp slaveInterp; / Interp in which command will be exposed. */
sl@0	2236	int objc; /* Number of arguments. */
sl@0	2237	Tcl_Obj CONST objv[]; / Argument strings. */
sl@0	2238	{
sl@0	2239	char *name;
sl@0	2240
sl@0	2241	if (Tcl_IsSafe(interp)) {
sl@0	2242	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2243	"permission denied: safe interpreter cannot hide commands",
sl@0	2244	(char *) NULL);
sl@0	2245	return TCL_ERROR;
sl@0	2246	}
sl@0	2247
sl@0	2248	name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
sl@0	2249	if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
sl@0	2250	name) != TCL_OK) {
sl@0	2251	TclTransferResult(slaveInterp, TCL_ERROR, interp);
sl@0	2252	return TCL_ERROR;
sl@0	2253	}
sl@0	2254	return TCL_OK;
sl@0	2255	}
sl@0	2256
sl@0	2257	/*
sl@0	2258	*----------------------------------------------------------------------
sl@0	2259	*
sl@0	2260	* SlaveHidden --
sl@0	2261	*
sl@0	2262	* Helper function to compute list of hidden commands in a slave
sl@0	2263	* interpreter.
sl@0	2264	*
sl@0	2265	* Results:
sl@0	2266	* A standard Tcl result.
sl@0	2267	*
sl@0	2268	* Side effects:
sl@0	2269	* None.
sl@0	2270	*
sl@0	2271	*----------------------------------------------------------------------
sl@0	2272	*/
sl@0	2273
sl@0	2274	static int
sl@0	2275	SlaveHidden(interp, slaveInterp)
sl@0	2276	Tcl_Interp interp; / Interp for data return. */
sl@0	2277	Tcl_Interp slaveInterp; / Interp whose hidden commands to query. */
sl@0	2278	{
sl@0	2279	Tcl_Obj listObjPtr; / Local object pointer. */
sl@0	2280	Tcl_HashTable hTblPtr; / For local searches. */
sl@0	2281	Tcl_HashEntry hPtr; / For local searches. */
sl@0	2282	Tcl_HashSearch hSearch; /* For local searches. */
sl@0	2283
sl@0	2284	listObjPtr = Tcl_GetObjResult(interp);
sl@0	2285	hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
sl@0	2286	if (hTblPtr != (Tcl_HashTable *) NULL) {
sl@0	2287	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
sl@0	2288	hPtr != (Tcl_HashEntry *) NULL;
sl@0	2289	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	2290
sl@0	2291	Tcl_ListObjAppendElement(NULL, listObjPtr,
sl@0	2292	Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
sl@0	2293	}
sl@0	2294	}
sl@0	2295	return TCL_OK;
sl@0	2296	}
sl@0	2297
sl@0	2298	/*
sl@0	2299	*----------------------------------------------------------------------
sl@0	2300	*
sl@0	2301	* SlaveInvokeHidden --
sl@0	2302	*
sl@0	2303	* Helper function to invoke a hidden command in a slave interpreter.
sl@0	2304	*
sl@0	2305	* Results:
sl@0	2306	* A standard Tcl result.
sl@0	2307	*
sl@0	2308	* Side effects:
sl@0	2309	* Whatever the hidden command does.
sl@0	2310	*
sl@0	2311	*----------------------------------------------------------------------
sl@0	2312	*/
sl@0	2313
sl@0	2314	static int
sl@0	2315	SlaveInvokeHidden(interp, slaveInterp, global, objc, objv)
sl@0	2316	Tcl_Interp interp; / Interp for error return. */
sl@0	2317	Tcl_Interp slaveInterp; / The slave interpreter in which command
sl@0	2318	* will be invoked. */
sl@0	2319	int global; /* Non-zero to invoke in global namespace. */
sl@0	2320	int objc; /* Number of arguments. */
sl@0	2321	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2322	{
sl@0	2323	int result;
sl@0	2324
sl@0	2325	if (Tcl_IsSafe(interp)) {
sl@0	2326	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	2327	"not allowed to invoke hidden commands from safe interpreter",
sl@0	2328	-1);
sl@0	2329	return TCL_ERROR;
sl@0	2330	}
sl@0	2331
sl@0	2332	Tcl_Preserve((ClientData) slaveInterp);
sl@0	2333	Tcl_AllowExceptions(slaveInterp);
sl@0	2334
sl@0	2335	if (global) {
sl@0	2336	result = TclObjInvokeGlobal(slaveInterp, objc, objv,
sl@0	2337	TCL_INVOKE_HIDDEN);
sl@0	2338	} else {
sl@0	2339	result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
sl@0	2340	}
sl@0	2341
sl@0	2342	TclTransferResult(slaveInterp, result, interp);
sl@0	2343
sl@0	2344	Tcl_Release((ClientData) slaveInterp);
sl@0	2345	return result;
sl@0	2346	}
sl@0	2347
sl@0	2348	/*
sl@0	2349	*----------------------------------------------------------------------
sl@0	2350	*
sl@0	2351	* SlaveMarkTrusted --
sl@0	2352	*
sl@0	2353	* Helper function to mark a slave interpreter as trusted (unsafe).
sl@0	2354	*
sl@0	2355	* Results:
sl@0	2356	* A standard Tcl result.
sl@0	2357	*
sl@0	2358	* Side effects:
sl@0	2359	* After this call the hard-wired security checks in the core no
sl@0	2360	* longer prevent the slave from performing certain operations.
sl@0	2361	*
sl@0	2362	*----------------------------------------------------------------------
sl@0	2363	*/
sl@0	2364
sl@0	2365	static int
sl@0	2366	SlaveMarkTrusted(interp, slaveInterp)
sl@0	2367	Tcl_Interp interp; / Interp for error return. */
sl@0	2368	Tcl_Interp slaveInterp; / The slave interpreter which will be
sl@0	2369	* marked trusted. */
sl@0	2370	{
sl@0	2371	if (Tcl_IsSafe(interp)) {
sl@0	2372	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2373	"permission denied: safe interpreter cannot mark trusted",
sl@0	2374	(char *) NULL);
sl@0	2375	return TCL_ERROR;
sl@0	2376	}
sl@0	2377	((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
sl@0	2378	return TCL_OK;
sl@0	2379	}
sl@0	2380
sl@0	2381	/*
sl@0	2382	*----------------------------------------------------------------------
sl@0	2383	*
sl@0	2384	* Tcl_IsSafe --
sl@0	2385	*
sl@0	2386	* Determines whether an interpreter is safe
sl@0	2387	*
sl@0	2388	* Results:
sl@0	2389	* 1 if it is safe, 0 if it is not.
sl@0	2390	*
sl@0	2391	* Side effects:
sl@0	2392	* None.
sl@0	2393	*
sl@0	2394	*----------------------------------------------------------------------
sl@0	2395	*/
sl@0	2396
sl@0	2397	EXPORT_C int
sl@0	2398	Tcl_IsSafe(interp)
sl@0	2399	Tcl_Interp interp; / Is this interpreter "safe" ? */
sl@0	2400	{
sl@0	2401	Interp *iPtr;
sl@0	2402
sl@0	2403	if (interp == (Tcl_Interp *) NULL) {
sl@0	2404	return 0;
sl@0	2405	}
sl@0	2406	iPtr = (Interp *) interp;
sl@0	2407
sl@0	2408	return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
sl@0	2409	}
sl@0	2410
sl@0	2411	/*
sl@0	2412	*----------------------------------------------------------------------
sl@0	2413	*
sl@0	2414	* Tcl_MakeSafe --
sl@0	2415	*
sl@0	2416	* Makes its argument interpreter contain only functionality that is
sl@0	2417	* defined to be part of Safe Tcl. Unsafe commands are hidden, the
sl@0	2418	* env array is unset, and the standard channels are removed.
sl@0	2419	*
sl@0	2420	* Results:
sl@0	2421	* None.
sl@0	2422	*
sl@0	2423	* Side effects:
sl@0	2424	* Hides commands in its argument interpreter, and removes settings
sl@0	2425	* and channels.
sl@0	2426	*
sl@0	2427	*----------------------------------------------------------------------
sl@0	2428	*/
sl@0	2429
sl@0	2430	EXPORT_C int
sl@0	2431	Tcl_MakeSafe(interp)
sl@0	2432	Tcl_Interp interp; / Interpreter to be made safe. */
sl@0	2433	{
sl@0	2434	Tcl_Channel chan; /* Channel to remove from
sl@0	2435	* safe interpreter. */
sl@0	2436	Interp iPtr = (Interp ) interp;
sl@0	2437
sl@0	2438	TclHideUnsafeCommands(interp);
sl@0	2439
sl@0	2440	iPtr->flags \|= SAFE_INTERP;
sl@0	2441
sl@0	2442	/*
sl@0	2443	* Unsetting variables : (which should not have been set
sl@0	2444	* in the first place, but...)
sl@0	2445	*/
sl@0	2446
sl@0	2447	/*
sl@0	2448	* No env array in a safe slave.
sl@0	2449	*/
sl@0	2450
sl@0	2451	Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
sl@0	2452
sl@0	2453	/*
sl@0	2454	* Remove unsafe parts of tcl_platform
sl@0	2455	*/
sl@0	2456
sl@0	2457	Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
sl@0	2458	Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
sl@0	2459	Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
sl@0	2460	Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
sl@0	2461
sl@0	2462	/*
sl@0	2463	* Unset path informations variables
sl@0	2464	* (the only one remaining is [info nameofexecutable])
sl@0	2465	*/
sl@0	2466
sl@0	2467	Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
sl@0	2468	Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
sl@0	2469	Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
sl@0	2470
sl@0	2471	/*
sl@0	2472	* Remove the standard channels from the interpreter; safe interpreters
sl@0	2473	* do not ordinarily have access to stdin, stdout and stderr.
sl@0	2474	*
sl@0	2475	* NOTE: These channels are not added to the interpreter by the
sl@0	2476	* Tcl_CreateInterp call, but may be added later, by another I/O
sl@0	2477	* operation. We want to ensure that the interpreter does not have
sl@0	2478	* these channels even if it is being made safe after being used for
sl@0	2479	* some time..
sl@0	2480	*/
sl@0	2481
sl@0	2482	chan = Tcl_GetStdChannel(TCL_STDIN);
sl@0	2483	if (chan != (Tcl_Channel) NULL) {
sl@0	2484	Tcl_UnregisterChannel(interp, chan);
sl@0	2485	}
sl@0	2486	chan = Tcl_GetStdChannel(TCL_STDOUT);
sl@0	2487	if (chan != (Tcl_Channel) NULL) {
sl@0	2488	Tcl_UnregisterChannel(interp, chan);
sl@0	2489	}
sl@0	2490	chan = Tcl_GetStdChannel(TCL_STDERR);
sl@0	2491	if (chan != (Tcl_Channel) NULL) {
sl@0	2492	Tcl_UnregisterChannel(interp, chan);
sl@0	2493	}
sl@0	2494
sl@0	2495	return TCL_OK;
sl@0	2496	}

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--