os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclInterp.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclInterp.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2496 @@
1.4 +/*
1.5 + * tclInterp.c --
1.6 + *
1.7 + * This file implements the "interp" command which allows creation
1.8 + * and manipulation of Tcl interpreters from within Tcl scripts.
1.9 + *
1.10 + * Copyright (c) 1995-1997 Sun Microsystems, Inc.
1.11 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.12 + *
1.13 + * See the file "license.terms" for information on usage and redistribution
1.14 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 + *
1.16 + * RCS: @(#) $Id: tclInterp.c,v 1.20.2.3 2006/11/28 22:20:02 andreas_kupries Exp $
1.17 + */
1.18 +
1.19 +#include "tclInt.h"
1.20 +#include "tclPort.h"
1.21 +#include <stdio.h>
1.22 +
1.23 +/*
1.24 + * Counter for how many aliases were created (global)
1.25 + */
1.26 +
1.27 +static int aliasCounter = 0;
1.28 +TCL_DECLARE_MUTEX(cntMutex)
1.29 +
1.30 +/*
1.31 + * struct Alias:
1.32 + *
1.33 + * Stores information about an alias. Is stored in the slave interpreter
1.34 + * and used by the source command to find the target command in the master
1.35 + * when the source command is invoked.
1.36 + */
1.37 +
1.38 +typedef struct Alias {
1.39 + Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
1.40 + Tcl_Interp *targetInterp; /* Interp in which target command will be
1.41 + * invoked. */
1.42 + Tcl_Command slaveCmd; /* Source command in slave interpreter,
1.43 + * bound to command that invokes the target
1.44 + * command in the target interpreter. */
1.45 + Tcl_HashEntry *aliasEntryPtr;
1.46 + /* Entry for the alias hash table in slave.
1.47 + * This is used by alias deletion to remove
1.48 + * the alias from the slave interpreter
1.49 + * alias table. */
1.50 + Tcl_HashEntry *targetEntryPtr;
1.51 + /* Entry for target command in master.
1.52 + * This is used in the master interpreter to
1.53 + * map back from the target command to aliases
1.54 + * redirecting to it. Random access to this
1.55 + * hash table is never required - we are using
1.56 + * a hash table only for convenience. */
1.57 + int objc; /* Count of Tcl_Obj in the prefix of the
1.58 + * target command to be invoked in the
1.59 + * target interpreter. Additional arguments
1.60 + * specified when calling the alias in the
1.61 + * slave interp will be appended to the prefix
1.62 + * before the command is invoked. */
1.63 + Tcl_Obj *objPtr; /* The first actual prefix object - the target
1.64 + * command name; this has to be at the end of the
1.65 + * structure, which will be extended to accomodate
1.66 + * the remaining objects in the prefix. */
1.67 +} Alias;
1.68 +
1.69 +/*
1.70 + *
1.71 + * struct Slave:
1.72 + *
1.73 + * Used by the "interp" command to record and find information about slave
1.74 + * interpreters. Maps from a command name in the master to information about
1.75 + * a slave interpreter, e.g. what aliases are defined in it.
1.76 + */
1.77 +
1.78 +typedef struct Slave {
1.79 + Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
1.80 + Tcl_HashEntry *slaveEntryPtr;
1.81 + /* Hash entry in masters slave table for
1.82 + * this slave interpreter. Used to find
1.83 + * this record, and used when deleting the
1.84 + * slave interpreter to delete it from the
1.85 + * master's table. */
1.86 + Tcl_Interp *slaveInterp; /* The slave interpreter. */
1.87 + Tcl_Command interpCmd; /* Interpreter object command. */
1.88 + Tcl_HashTable aliasTable; /* Table which maps from names of commands
1.89 + * in slave interpreter to struct Alias
1.90 + * defined below. */
1.91 +} Slave;
1.92 +
1.93 +/*
1.94 + * struct Target:
1.95 + *
1.96 + * Maps from master interpreter commands back to the source commands in slave
1.97 + * interpreters. This is needed because aliases can be created between sibling
1.98 + * interpreters and must be deleted when the target interpreter is deleted. In
1.99 + * case they would not be deleted the source interpreter would be left with a
1.100 + * "dangling pointer". One such record is stored in the Master record of the
1.101 + * master interpreter (in the targetTable hashtable, see below) with the
1.102 + * master for each alias which directs to a command in the master. These
1.103 + * records are used to remove the source command for an from a slave if/when
1.104 + * the master is deleted.
1.105 + */
1.106 +
1.107 +typedef struct Target {
1.108 + Tcl_Command slaveCmd; /* Command for alias in slave interp. */
1.109 + Tcl_Interp *slaveInterp; /* Slave Interpreter. */
1.110 +} Target;
1.111 +
1.112 +/*
1.113 + * struct Master:
1.114 + *
1.115 + * This record is used for two purposes: First, slaveTable (a hashtable)
1.116 + * maps from names of commands to slave interpreters. This hashtable is
1.117 + * used to store information about slave interpreters of this interpreter,
1.118 + * to map over all slaves, etc. The second purpose is to store information
1.119 + * about all aliases in slaves (or siblings) which direct to target commands
1.120 + * in this interpreter (using the targetTable hashtable).
1.121 + *
1.122 + * NB: the flags field in the interp structure, used with SAFE_INTERP
1.123 + * mask denotes whether the interpreter is safe or not. Safe
1.124 + * interpreters have restricted functionality, can only create safe slave
1.125 + * interpreters and can only load safe extensions.
1.126 + */
1.127 +
1.128 +typedef struct Master {
1.129 + Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
1.130 + * Maps from command names to Slave records. */
1.131 + Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
1.132 + * all Target records which denote aliases
1.133 + * from slaves or sibling interpreters that
1.134 + * direct to commands in this interpreter. This
1.135 + * table is used to remove dangling pointers
1.136 + * from the slave (or sibling) interpreters
1.137 + * when this interpreter is deleted. */
1.138 +} Master;
1.139 +
1.140 +/*
1.141 + * The following structure keeps track of all the Master and Slave information
1.142 + * on a per-interp basis.
1.143 + */
1.144 +
1.145 +typedef struct InterpInfo {
1.146 + Master master; /* Keeps track of all interps for which this
1.147 + * interp is the Master. */
1.148 + Slave slave; /* Information necessary for this interp to
1.149 + * function as a slave. */
1.150 +} InterpInfo;
1.151 +
1.152 +/*
1.153 + * Prototypes for local static procedures:
1.154 + */
1.155 +
1.156 +static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp,
1.157 + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
1.158 + Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
1.159 + Tcl_Obj *CONST objv[]));
1.160 +static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
1.161 + Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
1.162 +static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
1.163 + Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
1.164 +static int AliasList _ANSI_ARGS_((Tcl_Interp *interp,
1.165 + Tcl_Interp *slaveInterp));
1.166 +static int AliasObjCmd _ANSI_ARGS_((ClientData dummy,
1.167 + Tcl_Interp *currentInterp, int objc,
1.168 + Tcl_Obj *CONST objv[]));
1.169 +static void AliasObjCmdDeleteProc _ANSI_ARGS_((
1.170 + ClientData clientData));
1.171 +
1.172 +static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
1.173 + Tcl_Obj *pathPtr));
1.174 +static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
1.175 + Tcl_Obj *CONST objv[]));
1.176 +static void InterpInfoDeleteProc _ANSI_ARGS_((
1.177 + ClientData clientData, Tcl_Interp *interp));
1.178 +static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
1.179 + Tcl_Obj *pathPtr, int safe));
1.180 +static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
1.181 + Tcl_Interp *slaveInterp, int objc,
1.182 + Tcl_Obj *CONST objv[]));
1.183 +static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
1.184 + Tcl_Interp *slaveInterp, int objc,
1.185 + Tcl_Obj *CONST objv[]));
1.186 +static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
1.187 + Tcl_Interp *slaveInterp, int objc,
1.188 + Tcl_Obj *CONST objv[]));
1.189 +static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
1.190 + Tcl_Interp *slaveInterp));
1.191 +static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
1.192 + Tcl_Interp *slaveInterp, int global, int objc,
1.193 + Tcl_Obj *CONST objv[]));
1.194 +static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
1.195 + Tcl_Interp *slaveInterp));
1.196 +static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
1.197 + Tcl_Interp *interp, int objc,
1.198 + Tcl_Obj *CONST objv[]));
1.199 +static void SlaveObjCmdDeleteProc _ANSI_ARGS_((
1.200 + ClientData clientData));
1.201 +static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp,
1.202 + Tcl_Interp *slaveInterp, int objc,
1.203 + Tcl_Obj *CONST objv[]));
1.204 +
1.205 +
1.206 +/*
1.207 + *---------------------------------------------------------------------------
1.208 + *
1.209 + * TclInterpInit --
1.210 + *
1.211 + * Initializes the invoking interpreter for using the master, slave
1.212 + * and safe interp facilities. This is called from inside
1.213 + * Tcl_CreateInterp().
1.214 + *
1.215 + * Results:
1.216 + * Always returns TCL_OK for backwards compatibility.
1.217 + *
1.218 + * Side effects:
1.219 + * Adds the "interp" command to an interpreter and initializes the
1.220 + * interpInfoPtr field of the invoking interpreter.
1.221 + *
1.222 + *---------------------------------------------------------------------------
1.223 + */
1.224 +
1.225 +int
1.226 +TclInterpInit(interp)
1.227 + Tcl_Interp *interp; /* Interpreter to initialize. */
1.228 +{
1.229 + InterpInfo *interpInfoPtr;
1.230 + Master *masterPtr;
1.231 + Slave *slavePtr;
1.232 +
1.233 + interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
1.234 + ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;
1.235 +
1.236 + masterPtr = &interpInfoPtr->master;
1.237 + Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
1.238 + Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS);
1.239 +
1.240 + slavePtr = &interpInfoPtr->slave;
1.241 + slavePtr->masterInterp = NULL;
1.242 + slavePtr->slaveEntryPtr = NULL;
1.243 + slavePtr->slaveInterp = interp;
1.244 + slavePtr->interpCmd = NULL;
1.245 + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
1.246 +
1.247 + Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
1.248 +
1.249 + Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
1.250 + return TCL_OK;
1.251 +}
1.252 +
1.253 +/*
1.254 + *---------------------------------------------------------------------------
1.255 + *
1.256 + * InterpInfoDeleteProc --
1.257 + *
1.258 + * Invoked when an interpreter is being deleted. It releases all
1.259 + * storage used by the master/slave/safe interpreter facilities.
1.260 + *
1.261 + * Results:
1.262 + * None.
1.263 + *
1.264 + * Side effects:
1.265 + * Cleans up storage. Sets the interpInfoPtr field of the interp
1.266 + * to NULL.
1.267 + *
1.268 + *---------------------------------------------------------------------------
1.269 + */
1.270 +
1.271 +static void
1.272 +InterpInfoDeleteProc(clientData, interp)
1.273 + ClientData clientData; /* Ignored. */
1.274 + Tcl_Interp *interp; /* Interp being deleted. All commands for
1.275 + * slave interps should already be deleted. */
1.276 +{
1.277 + InterpInfo *interpInfoPtr;
1.278 + Slave *slavePtr;
1.279 + Master *masterPtr;
1.280 + Tcl_HashSearch hSearch;
1.281 + Tcl_HashEntry *hPtr;
1.282 + Target *targetPtr;
1.283 +
1.284 + interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
1.285 +
1.286 + /*
1.287 + * There shouldn't be any commands left.
1.288 + */
1.289 +
1.290 + masterPtr = &interpInfoPtr->master;
1.291 + if (masterPtr->slaveTable.numEntries != 0) {
1.292 + panic("InterpInfoDeleteProc: still exist commands");
1.293 + }
1.294 + Tcl_DeleteHashTable(&masterPtr->slaveTable);
1.295 +
1.296 + /*
1.297 + * Tell any interps that have aliases to this interp that they should
1.298 + * delete those aliases. If the other interp was already dead, it
1.299 + * would have removed the target record already.
1.300 + */
1.301 +
1.302 + hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch);
1.303 + while (hPtr != NULL) {
1.304 + targetPtr = (Target *) Tcl_GetHashValue(hPtr);
1.305 + Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
1.306 + targetPtr->slaveCmd);
1.307 + hPtr = Tcl_NextHashEntry(&hSearch);
1.308 + }
1.309 + Tcl_DeleteHashTable(&masterPtr->targetTable);
1.310 +
1.311 + slavePtr = &interpInfoPtr->slave;
1.312 + if (slavePtr->interpCmd != NULL) {
1.313 + /*
1.314 + * Tcl_DeleteInterp() was called on this interpreter, rather
1.315 + * "interp delete" or the equivalent deletion of the command in the
1.316 + * master. First ensure that the cleanup callback doesn't try to
1.317 + * delete the interp again.
1.318 + */
1.319 +
1.320 + slavePtr->slaveInterp = NULL;
1.321 + Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
1.322 + slavePtr->interpCmd);
1.323 + }
1.324 +
1.325 + /*
1.326 + * There shouldn't be any aliases left.
1.327 + */
1.328 +
1.329 + if (slavePtr->aliasTable.numEntries != 0) {
1.330 + panic("InterpInfoDeleteProc: still exist aliases");
1.331 + }
1.332 + Tcl_DeleteHashTable(&slavePtr->aliasTable);
1.333 +
1.334 + ckfree((char *) interpInfoPtr);
1.335 +}
1.336 +
1.337 +/*
1.338 + *----------------------------------------------------------------------
1.339 + *
1.340 + * Tcl_InterpObjCmd --
1.341 + *
1.342 + * This procedure is invoked to process the "interp" Tcl command.
1.343 + * See the user documentation for details on what it does.
1.344 + *
1.345 + * Results:
1.346 + * A standard Tcl result.
1.347 + *
1.348 + * Side effects:
1.349 + * See the user documentation.
1.350 + *
1.351 + *----------------------------------------------------------------------
1.352 + */
1.353 + /* ARGSUSED */
1.354 +int
1.355 +Tcl_InterpObjCmd(clientData, interp, objc, objv)
1.356 + ClientData clientData; /* Unused. */
1.357 + Tcl_Interp *interp; /* Current interpreter. */
1.358 + int objc; /* Number of arguments. */
1.359 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.360 +{
1.361 + int index;
1.362 + static CONST char *options[] = {
1.363 + "alias", "aliases", "create", "delete",
1.364 + "eval", "exists", "expose", "hide",
1.365 + "hidden", "issafe", "invokehidden", "marktrusted",
1.366 + "recursionlimit", "slaves", "share",
1.367 + "target", "transfer",
1.368 + NULL
1.369 + };
1.370 + enum option {
1.371 + OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
1.372 + OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
1.373 + OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED,
1.374 + OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE,
1.375 + OPT_TARGET, OPT_TRANSFER
1.376 + };
1.377 +
1.378 +
1.379 + if (objc < 2) {
1.380 + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
1.381 + return TCL_ERROR;
1.382 + }
1.383 + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
1.384 + &index) != TCL_OK) {
1.385 + return TCL_ERROR;
1.386 + }
1.387 + switch ((enum option) index) {
1.388 + case OPT_ALIAS: {
1.389 + Tcl_Interp *slaveInterp, *masterInterp;
1.390 +
1.391 + if (objc < 4) {
1.392 + aliasArgs:
1.393 + Tcl_WrongNumArgs(interp, 2, objv,
1.394 + "slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
1.395 + return TCL_ERROR;
1.396 + }
1.397 + slaveInterp = GetInterp(interp, objv[2]);
1.398 + if (slaveInterp == (Tcl_Interp *) NULL) {
1.399 + return TCL_ERROR;
1.400 + }
1.401 + if (objc == 4) {
1.402 + return AliasDescribe(interp, slaveInterp, objv[3]);
1.403 + }
1.404 + if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
1.405 + return AliasDelete(interp, slaveInterp, objv[3]);
1.406 + }
1.407 + if (objc > 5) {
1.408 + masterInterp = GetInterp(interp, objv[4]);
1.409 + if (masterInterp == (Tcl_Interp *) NULL) {
1.410 + return TCL_ERROR;
1.411 + }
1.412 + if (Tcl_GetString(objv[5])[0] == '\0') {
1.413 + if (objc == 6) {
1.414 + return AliasDelete(interp, slaveInterp, objv[3]);
1.415 + }
1.416 + } else {
1.417 + return AliasCreate(interp, slaveInterp, masterInterp,
1.418 + objv[3], objv[5], objc - 6, objv + 6);
1.419 + }
1.420 + }
1.421 + goto aliasArgs;
1.422 + }
1.423 + case OPT_ALIASES: {
1.424 + Tcl_Interp *slaveInterp;
1.425 +
1.426 + slaveInterp = GetInterp2(interp, objc, objv);
1.427 + if (slaveInterp == NULL) {
1.428 + return TCL_ERROR;
1.429 + }
1.430 + return AliasList(interp, slaveInterp);
1.431 + }
1.432 + case OPT_CREATE: {
1.433 + int i, last, safe;
1.434 + Tcl_Obj *slavePtr;
1.435 + char buf[16 + TCL_INTEGER_SPACE];
1.436 + static CONST char *options[] = {
1.437 + "-safe", "--", NULL
1.438 + };
1.439 + enum option {
1.440 + OPT_SAFE, OPT_LAST
1.441 + };
1.442 +
1.443 + safe = Tcl_IsSafe(interp);
1.444 +
1.445 + /*
1.446 + * Weird historical rules: "-safe" is accepted at the end, too.
1.447 + */
1.448 +
1.449 + slavePtr = NULL;
1.450 + last = 0;
1.451 + for (i = 2; i < objc; i++) {
1.452 + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
1.453 + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
1.454 + 0, &index) != TCL_OK) {
1.455 + return TCL_ERROR;
1.456 + }
1.457 + if (index == OPT_SAFE) {
1.458 + safe = 1;
1.459 + continue;
1.460 + }
1.461 + i++;
1.462 + last = 1;
1.463 + }
1.464 + if (slavePtr != NULL) {
1.465 + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
1.466 + return TCL_ERROR;
1.467 + }
1.468 + if (i < objc) {
1.469 + slavePtr = objv[i];
1.470 + }
1.471 + }
1.472 + buf[0] = '\0';
1.473 + if (slavePtr == NULL) {
1.474 + /*
1.475 + * Create an anonymous interpreter -- we choose its name and
1.476 + * the name of the command. We check that the command name
1.477 + * that we use for the interpreter does not collide with an
1.478 + * existing command in the master interpreter.
1.479 + */
1.480 +
1.481 + for (i = 0; ; i++) {
1.482 + Tcl_CmdInfo cmdInfo;
1.483 +
1.484 + sprintf(buf, "interp%d", i);
1.485 + if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
1.486 + break;
1.487 + }
1.488 + }
1.489 + slavePtr = Tcl_NewStringObj(buf, -1);
1.490 + }
1.491 + if (SlaveCreate(interp, slavePtr, safe) == NULL) {
1.492 + if (buf[0] != '\0') {
1.493 + Tcl_DecrRefCount(slavePtr);
1.494 + }
1.495 + return TCL_ERROR;
1.496 + }
1.497 + Tcl_SetObjResult(interp, slavePtr);
1.498 + return TCL_OK;
1.499 + }
1.500 + case OPT_DELETE: {
1.501 + int i;
1.502 + InterpInfo *iiPtr;
1.503 + Tcl_Interp *slaveInterp;
1.504 +
1.505 + for (i = 2; i < objc; i++) {
1.506 + slaveInterp = GetInterp(interp, objv[i]);
1.507 + if (slaveInterp == NULL) {
1.508 + return TCL_ERROR;
1.509 + } else if (slaveInterp == interp) {
1.510 + Tcl_ResetResult(interp);
1.511 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.512 + "cannot delete the current interpreter",
1.513 + (char *) NULL);
1.514 + return TCL_ERROR;
1.515 + }
1.516 + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
1.517 + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
1.518 + iiPtr->slave.interpCmd);
1.519 + }
1.520 + return TCL_OK;
1.521 + }
1.522 + case OPT_EVAL: {
1.523 + Tcl_Interp *slaveInterp;
1.524 +
1.525 + if (objc < 4) {
1.526 + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
1.527 + return TCL_ERROR;
1.528 + }
1.529 + slaveInterp = GetInterp(interp, objv[2]);
1.530 + if (slaveInterp == NULL) {
1.531 + return TCL_ERROR;
1.532 + }
1.533 + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
1.534 + }
1.535 + case OPT_EXISTS: {
1.536 + int exists;
1.537 + Tcl_Interp *slaveInterp;
1.538 +
1.539 + exists = 1;
1.540 + slaveInterp = GetInterp2(interp, objc, objv);
1.541 + if (slaveInterp == NULL) {
1.542 + if (objc > 3) {
1.543 + return TCL_ERROR;
1.544 + }
1.545 + Tcl_ResetResult(interp);
1.546 + exists = 0;
1.547 + }
1.548 + Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
1.549 + return TCL_OK;
1.550 + }
1.551 + case OPT_EXPOSE: {
1.552 + Tcl_Interp *slaveInterp;
1.553 +
1.554 + if ((objc < 4) || (objc > 5)) {
1.555 + Tcl_WrongNumArgs(interp, 2, objv,
1.556 + "path hiddenCmdName ?cmdName?");
1.557 + return TCL_ERROR;
1.558 + }
1.559 + slaveInterp = GetInterp(interp, objv[2]);
1.560 + if (slaveInterp == NULL) {
1.561 + return TCL_ERROR;
1.562 + }
1.563 + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
1.564 + }
1.565 + case OPT_HIDE: {
1.566 + Tcl_Interp *slaveInterp; /* A slave. */
1.567 +
1.568 + if ((objc < 4) || (objc > 5)) {
1.569 + Tcl_WrongNumArgs(interp, 2, objv,
1.570 + "path cmdName ?hiddenCmdName?");
1.571 + return TCL_ERROR;
1.572 + }
1.573 + slaveInterp = GetInterp(interp, objv[2]);
1.574 + if (slaveInterp == (Tcl_Interp *) NULL) {
1.575 + return TCL_ERROR;
1.576 + }
1.577 + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
1.578 + }
1.579 + case OPT_HIDDEN: {
1.580 + Tcl_Interp *slaveInterp; /* A slave. */
1.581 +
1.582 + slaveInterp = GetInterp2(interp, objc, objv);
1.583 + if (slaveInterp == NULL) {
1.584 + return TCL_ERROR;
1.585 + }
1.586 + return SlaveHidden(interp, slaveInterp);
1.587 + }
1.588 + case OPT_ISSAFE: {
1.589 + Tcl_Interp *slaveInterp;
1.590 +
1.591 + slaveInterp = GetInterp2(interp, objc, objv);
1.592 + if (slaveInterp == NULL) {
1.593 + return TCL_ERROR;
1.594 + }
1.595 + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
1.596 + return TCL_OK;
1.597 + }
1.598 + case OPT_INVOKEHID: {
1.599 + int i, index, global;
1.600 + Tcl_Interp *slaveInterp;
1.601 + static CONST char *hiddenOptions[] = {
1.602 + "-global", "--", NULL
1.603 + };
1.604 + enum hiddenOption {
1.605 + OPT_GLOBAL, OPT_LAST
1.606 + };
1.607 +
1.608 + global = 0;
1.609 + for (i = 3; i < objc; i++) {
1.610 + if (Tcl_GetString(objv[i])[0] != '-') {
1.611 + break;
1.612 + }
1.613 + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
1.614 + "option", 0, &index) != TCL_OK) {
1.615 + return TCL_ERROR;
1.616 + }
1.617 + if (index == OPT_GLOBAL) {
1.618 + global = 1;
1.619 + } else {
1.620 + i++;
1.621 + break;
1.622 + }
1.623 + }
1.624 + if (objc - i < 1) {
1.625 + Tcl_WrongNumArgs(interp, 2, objv,
1.626 + "path ?-global? ?--? cmd ?arg ..?");
1.627 + return TCL_ERROR;
1.628 + }
1.629 + slaveInterp = GetInterp(interp, objv[2]);
1.630 + if (slaveInterp == (Tcl_Interp *) NULL) {
1.631 + return TCL_ERROR;
1.632 + }
1.633 + return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
1.634 + objv + i);
1.635 + }
1.636 + case OPT_MARKTRUSTED: {
1.637 + Tcl_Interp *slaveInterp;
1.638 +
1.639 + if (objc != 3) {
1.640 + Tcl_WrongNumArgs(interp, 2, objv, "path");
1.641 + return TCL_ERROR;
1.642 + }
1.643 + slaveInterp = GetInterp(interp, objv[2]);
1.644 + if (slaveInterp == NULL) {
1.645 + return TCL_ERROR;
1.646 + }
1.647 + return SlaveMarkTrusted(interp, slaveInterp);
1.648 + }
1.649 + case OPT_RECLIMIT: {
1.650 + Tcl_Interp *slaveInterp;
1.651 +
1.652 + if (objc != 3 && objc != 4) {
1.653 + Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
1.654 + return TCL_ERROR;
1.655 + }
1.656 + slaveInterp = GetInterp(interp, objv[2]);
1.657 + if (slaveInterp == NULL) {
1.658 + return TCL_ERROR;
1.659 + }
1.660 + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
1.661 + }
1.662 + case OPT_SLAVES: {
1.663 + Tcl_Interp *slaveInterp;
1.664 + InterpInfo *iiPtr;
1.665 + Tcl_Obj *resultPtr;
1.666 + Tcl_HashEntry *hPtr;
1.667 + Tcl_HashSearch hashSearch;
1.668 + char *string;
1.669 +
1.670 + slaveInterp = GetInterp2(interp, objc, objv);
1.671 + if (slaveInterp == NULL) {
1.672 + return TCL_ERROR;
1.673 + }
1.674 + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
1.675 + resultPtr = Tcl_GetObjResult(interp);
1.676 + hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
1.677 + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
1.678 + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
1.679 + Tcl_ListObjAppendElement(NULL, resultPtr,
1.680 + Tcl_NewStringObj(string, -1));
1.681 + }
1.682 + return TCL_OK;
1.683 + }
1.684 + case OPT_SHARE: {
1.685 + Tcl_Interp *slaveInterp; /* A slave. */
1.686 + Tcl_Interp *masterInterp; /* Its master. */
1.687 + Tcl_Channel chan;
1.688 +
1.689 + if (objc != 5) {
1.690 + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
1.691 + return TCL_ERROR;
1.692 + }
1.693 + masterInterp = GetInterp(interp, objv[2]);
1.694 + if (masterInterp == NULL) {
1.695 + return TCL_ERROR;
1.696 + }
1.697 + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
1.698 + NULL);
1.699 + if (chan == NULL) {
1.700 + TclTransferResult(masterInterp, TCL_OK, interp);
1.701 + return TCL_ERROR;
1.702 + }
1.703 + slaveInterp = GetInterp(interp, objv[4]);
1.704 + if (slaveInterp == NULL) {
1.705 + return TCL_ERROR;
1.706 + }
1.707 + Tcl_RegisterChannel(slaveInterp, chan);
1.708 + return TCL_OK;
1.709 + }
1.710 + case OPT_TARGET: {
1.711 + Tcl_Interp *slaveInterp;
1.712 + InterpInfo *iiPtr;
1.713 + Tcl_HashEntry *hPtr;
1.714 + Alias *aliasPtr;
1.715 + char *aliasName;
1.716 +
1.717 + if (objc != 4) {
1.718 + Tcl_WrongNumArgs(interp, 2, objv, "path alias");
1.719 + return TCL_ERROR;
1.720 + }
1.721 +
1.722 + slaveInterp = GetInterp(interp, objv[2]);
1.723 + if (slaveInterp == NULL) {
1.724 + return TCL_ERROR;
1.725 + }
1.726 +
1.727 + aliasName = Tcl_GetString(objv[3]);
1.728 +
1.729 + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
1.730 + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
1.731 + if (hPtr == NULL) {
1.732 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.733 + "alias \"", aliasName, "\" in path \"",
1.734 + Tcl_GetString(objv[2]), "\" not found",
1.735 + (char *) NULL);
1.736 + return TCL_ERROR;
1.737 + }
1.738 + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1.739 + if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
1.740 + Tcl_ResetResult(interp);
1.741 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.742 + "target interpreter for alias \"", aliasName,
1.743 + "\" in path \"", Tcl_GetString(objv[2]),
1.744 + "\" is not my descendant", (char *) NULL);
1.745 + return TCL_ERROR;
1.746 + }
1.747 + return TCL_OK;
1.748 + }
1.749 + case OPT_TRANSFER: {
1.750 + Tcl_Interp *slaveInterp; /* A slave. */
1.751 + Tcl_Interp *masterInterp; /* Its master. */
1.752 + Tcl_Channel chan;
1.753 +
1.754 + if (objc != 5) {
1.755 + Tcl_WrongNumArgs(interp, 2, objv,
1.756 + "srcPath channelId destPath");
1.757 + return TCL_ERROR;
1.758 + }
1.759 + masterInterp = GetInterp(interp, objv[2]);
1.760 + if (masterInterp == NULL) {
1.761 + return TCL_ERROR;
1.762 + }
1.763 + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
1.764 + if (chan == NULL) {
1.765 + TclTransferResult(masterInterp, TCL_OK, interp);
1.766 + return TCL_ERROR;
1.767 + }
1.768 + slaveInterp = GetInterp(interp, objv[4]);
1.769 + if (slaveInterp == NULL) {
1.770 + return TCL_ERROR;
1.771 + }
1.772 + Tcl_RegisterChannel(slaveInterp, chan);
1.773 + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
1.774 + TclTransferResult(masterInterp, TCL_OK, interp);
1.775 + return TCL_ERROR;
1.776 + }
1.777 + return TCL_OK;
1.778 + }
1.779 + }
1.780 + return TCL_OK;
1.781 +}
1.782 +
1.783 +/*
1.784 + *---------------------------------------------------------------------------
1.785 + *
1.786 + * GetInterp2 --
1.787 + *
1.788 + * Helper function for Tcl_InterpObjCmd() to convert the interp name
1.789 + * potentially specified on the command line to an Tcl_Interp.
1.790 + *
1.791 + * Results:
1.792 + * The return value is the interp specified on the command line,
1.793 + * or the interp argument itself if no interp was specified on the
1.794 + * command line. If the interp could not be found or the wrong
1.795 + * number of arguments was specified on the command line, the return
1.796 + * value is NULL and an error message is left in the interp's result.
1.797 + *
1.798 + * Side effects:
1.799 + * None.
1.800 + *
1.801 + *---------------------------------------------------------------------------
1.802 + */
1.803 +
1.804 +static Tcl_Interp *
1.805 +GetInterp2(interp, objc, objv)
1.806 + Tcl_Interp *interp; /* Default interp if no interp was specified
1.807 + * on the command line. */
1.808 + int objc; /* Number of arguments. */
1.809 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.810 +{
1.811 + if (objc == 2) {
1.812 + return interp;
1.813 + } else if (objc == 3) {
1.814 + return GetInterp(interp, objv[2]);
1.815 + } else {
1.816 + Tcl_WrongNumArgs(interp, 2, objv, "?path?");
1.817 + return NULL;
1.818 + }
1.819 +}
1.820 +
1.821 +/*
1.822 + *----------------------------------------------------------------------
1.823 + *
1.824 + * Tcl_CreateAlias --
1.825 + *
1.826 + * Creates an alias between two interpreters.
1.827 + *
1.828 + * Results:
1.829 + * A standard Tcl result.
1.830 + *
1.831 + * Side effects:
1.832 + * Creates a new alias, manipulates the result field of slaveInterp.
1.833 + *
1.834 + *----------------------------------------------------------------------
1.835 + */
1.836 +
1.837 +EXPORT_C int
1.838 +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
1.839 + Tcl_Interp *slaveInterp; /* Interpreter for source command. */
1.840 + CONST char *slaveCmd; /* Command to install in slave. */
1.841 + Tcl_Interp *targetInterp; /* Interpreter for target command. */
1.842 + CONST char *targetCmd; /* Name of target command. */
1.843 + int argc; /* How many additional arguments? */
1.844 + CONST char * CONST *argv; /* These are the additional args. */
1.845 +{
1.846 + Tcl_Obj *slaveObjPtr, *targetObjPtr;
1.847 + Tcl_Obj **objv;
1.848 + int i;
1.849 + int result;
1.850 +
1.851 + objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
1.852 + for (i = 0; i < argc; i++) {
1.853 + objv[i] = Tcl_NewStringObj(argv[i], -1);
1.854 + Tcl_IncrRefCount(objv[i]);
1.855 + }
1.856 +
1.857 + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
1.858 + Tcl_IncrRefCount(slaveObjPtr);
1.859 +
1.860 + targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
1.861 + Tcl_IncrRefCount(targetObjPtr);
1.862 +
1.863 + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
1.864 + targetObjPtr, argc, objv);
1.865 +
1.866 + for (i = 0; i < argc; i++) {
1.867 + Tcl_DecrRefCount(objv[i]);
1.868 + }
1.869 + ckfree((char *) objv);
1.870 + Tcl_DecrRefCount(targetObjPtr);
1.871 + Tcl_DecrRefCount(slaveObjPtr);
1.872 +
1.873 + return result;
1.874 +}
1.875 +
1.876 +/*
1.877 + *----------------------------------------------------------------------
1.878 + *
1.879 + * Tcl_CreateAliasObj --
1.880 + *
1.881 + * Object version: Creates an alias between two interpreters.
1.882 + *
1.883 + * Results:
1.884 + * A standard Tcl result.
1.885 + *
1.886 + * Side effects:
1.887 + * Creates a new alias.
1.888 + *
1.889 + *----------------------------------------------------------------------
1.890 + */
1.891 +
1.892 +EXPORT_C int
1.893 +Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
1.894 + Tcl_Interp *slaveInterp; /* Interpreter for source command. */
1.895 + CONST char *slaveCmd; /* Command to install in slave. */
1.896 + Tcl_Interp *targetInterp; /* Interpreter for target command. */
1.897 + CONST char *targetCmd; /* Name of target command. */
1.898 + int objc; /* How many additional arguments? */
1.899 + Tcl_Obj *CONST objv[]; /* Argument vector. */
1.900 +{
1.901 + Tcl_Obj *slaveObjPtr, *targetObjPtr;
1.902 + int result;
1.903 +
1.904 + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
1.905 + Tcl_IncrRefCount(slaveObjPtr);
1.906 +
1.907 + targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
1.908 + Tcl_IncrRefCount(targetObjPtr);
1.909 +
1.910 + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
1.911 + targetObjPtr, objc, objv);
1.912 +
1.913 + Tcl_DecrRefCount(slaveObjPtr);
1.914 + Tcl_DecrRefCount(targetObjPtr);
1.915 + return result;
1.916 +}
1.917 +
1.918 +/*
1.919 + *----------------------------------------------------------------------
1.920 + *
1.921 + * Tcl_GetAlias --
1.922 + *
1.923 + * Gets information about an alias.
1.924 + *
1.925 + * Results:
1.926 + * A standard Tcl result.
1.927 + *
1.928 + * Side effects:
1.929 + * None.
1.930 + *
1.931 + *----------------------------------------------------------------------
1.932 + */
1.933 +
1.934 +EXPORT_C int
1.935 +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
1.936 + argvPtr)
1.937 + Tcl_Interp *interp; /* Interp to start search from. */
1.938 + CONST char *aliasName; /* Name of alias to find. */
1.939 + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
1.940 + CONST char **targetNamePtr; /* (Return) name of target command. */
1.941 + int *argcPtr; /* (Return) count of addnl args. */
1.942 + CONST char ***argvPtr; /* (Return) additional arguments. */
1.943 +{
1.944 + InterpInfo *iiPtr;
1.945 + Tcl_HashEntry *hPtr;
1.946 + Alias *aliasPtr;
1.947 + int i, objc;
1.948 + Tcl_Obj **objv;
1.949 +
1.950 + iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
1.951 + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
1.952 + if (hPtr == NULL) {
1.953 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.954 + "alias \"", aliasName, "\" not found", (char *) NULL);
1.955 + return TCL_ERROR;
1.956 + }
1.957 + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1.958 + objc = aliasPtr->objc;
1.959 + objv = &aliasPtr->objPtr;
1.960 +
1.961 + if (targetInterpPtr != NULL) {
1.962 + *targetInterpPtr = aliasPtr->targetInterp;
1.963 + }
1.964 + if (targetNamePtr != NULL) {
1.965 + *targetNamePtr = Tcl_GetString(objv[0]);
1.966 + }
1.967 + if (argcPtr != NULL) {
1.968 + *argcPtr = objc - 1;
1.969 + }
1.970 + if (argvPtr != NULL) {
1.971 + *argvPtr = (CONST char **)
1.972 + ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
1.973 + for (i = 1; i < objc; i++) {
1.974 + *argvPtr[i - 1] = Tcl_GetString(objv[i]);
1.975 + }
1.976 + }
1.977 + return TCL_OK;
1.978 +}
1.979 +
1.980 +/*
1.981 + *----------------------------------------------------------------------
1.982 + *
1.983 + * Tcl_GetAliasObj --
1.984 + *
1.985 + * Object version: Gets information about an alias.
1.986 + *
1.987 + * Results:
1.988 + * A standard Tcl result.
1.989 + *
1.990 + * Side effects:
1.991 + * None.
1.992 + *
1.993 + *----------------------------------------------------------------------
1.994 + */
1.995 +
1.996 +EXPORT_C int
1.997 +Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
1.998 + objvPtr)
1.999 + Tcl_Interp *interp; /* Interp to start search from. */
1.1000 + CONST char *aliasName; /* Name of alias to find. */
1.1001 + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
1.1002 + CONST char **targetNamePtr; /* (Return) name of target command. */
1.1003 + int *objcPtr; /* (Return) count of addnl args. */
1.1004 + Tcl_Obj ***objvPtr; /* (Return) additional args. */
1.1005 +{
1.1006 + InterpInfo *iiPtr;
1.1007 + Tcl_HashEntry *hPtr;
1.1008 + Alias *aliasPtr;
1.1009 + int objc;
1.1010 + Tcl_Obj **objv;
1.1011 +
1.1012 + iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
1.1013 + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
1.1014 + if (hPtr == (Tcl_HashEntry *) NULL) {
1.1015 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1016 + "alias \"", aliasName, "\" not found", (char *) NULL);
1.1017 + return TCL_ERROR;
1.1018 + }
1.1019 + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1.1020 + objc = aliasPtr->objc;
1.1021 + objv = &aliasPtr->objPtr;
1.1022 +
1.1023 + if (targetInterpPtr != (Tcl_Interp **) NULL) {
1.1024 + *targetInterpPtr = aliasPtr->targetInterp;
1.1025 + }
1.1026 + if (targetNamePtr != (CONST char **) NULL) {
1.1027 + *targetNamePtr = Tcl_GetString(objv[0]);
1.1028 + }
1.1029 + if (objcPtr != (int *) NULL) {
1.1030 + *objcPtr = objc - 1;
1.1031 + }
1.1032 + if (objvPtr != (Tcl_Obj ***) NULL) {
1.1033 + *objvPtr = objv + 1;
1.1034 + }
1.1035 + return TCL_OK;
1.1036 +}
1.1037 +
1.1038 +/*
1.1039 + *----------------------------------------------------------------------
1.1040 + *
1.1041 + * TclPreventAliasLoop --
1.1042 + *
1.1043 + * When defining an alias or renaming a command, prevent an alias
1.1044 + * loop from being formed.
1.1045 + *
1.1046 + * Results:
1.1047 + * A standard Tcl object result.
1.1048 + *
1.1049 + * Side effects:
1.1050 + * If TCL_ERROR is returned, the function also stores an error message
1.1051 + * in the interpreter's result object.
1.1052 + *
1.1053 + * NOTE:
1.1054 + * This function is public internal (instead of being static to
1.1055 + * this file) because it is also used from TclRenameCommand.
1.1056 + *
1.1057 + *----------------------------------------------------------------------
1.1058 + */
1.1059 +
1.1060 +int
1.1061 +TclPreventAliasLoop(interp, cmdInterp, cmd)
1.1062 + Tcl_Interp *interp; /* Interp in which to report errors. */
1.1063 + Tcl_Interp *cmdInterp; /* Interp in which the command is
1.1064 + * being defined. */
1.1065 + Tcl_Command cmd; /* Tcl command we are attempting
1.1066 + * to define. */
1.1067 +{
1.1068 + Command *cmdPtr = (Command *) cmd;
1.1069 + Alias *aliasPtr, *nextAliasPtr;
1.1070 + Tcl_Command aliasCmd;
1.1071 + Command *aliasCmdPtr;
1.1072 +
1.1073 + /*
1.1074 + * If we are not creating or renaming an alias, then it is
1.1075 + * always OK to create or rename the command.
1.1076 + */
1.1077 +
1.1078 + if (cmdPtr->objProc != AliasObjCmd) {
1.1079 + return TCL_OK;
1.1080 + }
1.1081 +
1.1082 + /*
1.1083 + * OK, we are dealing with an alias, so traverse the chain of aliases.
1.1084 + * If we encounter the alias we are defining (or renaming to) any in
1.1085 + * the chain then we have a loop.
1.1086 + */
1.1087 +
1.1088 + aliasPtr = (Alias *) cmdPtr->objClientData;
1.1089 + nextAliasPtr = aliasPtr;
1.1090 + while (1) {
1.1091 + Tcl_Obj *cmdNamePtr;
1.1092 +
1.1093 + /*
1.1094 + * If the target of the next alias in the chain is the same as
1.1095 + * the source alias, we have a loop.
1.1096 + */
1.1097 +
1.1098 + if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
1.1099 + /*
1.1100 + * The slave interpreter can be deleted while creating the alias.
1.1101 + * [Bug #641195]
1.1102 + */
1.1103 +
1.1104 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1105 + "cannot define or rename alias \"",
1.1106 + Tcl_GetString(aliasPtr->namePtr),
1.1107 + "\": interpreter deleted", (char *) NULL);
1.1108 + return TCL_ERROR;
1.1109 + }
1.1110 + cmdNamePtr = nextAliasPtr->objPtr;
1.1111 + aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
1.1112 + Tcl_GetString(cmdNamePtr),
1.1113 + Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
1.1114 + /*flags*/ 0);
1.1115 + if (aliasCmd == (Tcl_Command) NULL) {
1.1116 + return TCL_OK;
1.1117 + }
1.1118 + aliasCmdPtr = (Command *) aliasCmd;
1.1119 + if (aliasCmdPtr == cmdPtr) {
1.1120 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1121 + "cannot define or rename alias \"",
1.1122 + Tcl_GetString(aliasPtr->namePtr),
1.1123 + "\": would create a loop", (char *) NULL);
1.1124 + return TCL_ERROR;
1.1125 + }
1.1126 +
1.1127 + /*
1.1128 + * Otherwise, follow the chain one step further. See if the target
1.1129 + * command is an alias - if so, follow the loop to its target
1.1130 + * command. Otherwise we do not have a loop.
1.1131 + */
1.1132 +
1.1133 + if (aliasCmdPtr->objProc != AliasObjCmd) {
1.1134 + return TCL_OK;
1.1135 + }
1.1136 + nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
1.1137 + }
1.1138 +
1.1139 + /* NOTREACHED */
1.1140 +}
1.1141 +
1.1142 +/*
1.1143 + *----------------------------------------------------------------------
1.1144 + *
1.1145 + * AliasCreate --
1.1146 + *
1.1147 + * Helper function to do the work to actually create an alias.
1.1148 + *
1.1149 + * Results:
1.1150 + * A standard Tcl result.
1.1151 + *
1.1152 + * Side effects:
1.1153 + * An alias command is created and entered into the alias table
1.1154 + * for the slave interpreter.
1.1155 + *
1.1156 + *----------------------------------------------------------------------
1.1157 + */
1.1158 +
1.1159 +static int
1.1160 +AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
1.1161 + objc, objv)
1.1162 + Tcl_Interp *interp; /* Interp for error reporting. */
1.1163 + Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from
1.1164 + * which alias will be deleted. */
1.1165 + Tcl_Interp *masterInterp; /* Interp in which target command will be
1.1166 + * invoked. */
1.1167 + Tcl_Obj *namePtr; /* Name of alias cmd. */
1.1168 + Tcl_Obj *targetNamePtr; /* Name of target cmd. */
1.1169 + int objc; /* Additional arguments to store */
1.1170 + Tcl_Obj *CONST objv[]; /* with alias. */
1.1171 +{
1.1172 + Alias *aliasPtr;
1.1173 + Tcl_HashEntry *hPtr;
1.1174 + Target *targetPtr;
1.1175 + Slave *slavePtr;
1.1176 + Master *masterPtr;
1.1177 + Tcl_Obj **prefv;
1.1178 + int new, i;
1.1179 +
1.1180 + aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
1.1181 + + objc * sizeof(Tcl_Obj *)));
1.1182 + aliasPtr->namePtr = namePtr;
1.1183 + Tcl_IncrRefCount(aliasPtr->namePtr);
1.1184 + aliasPtr->targetInterp = masterInterp;
1.1185 +
1.1186 + aliasPtr->objc = objc + 1;
1.1187 + prefv = &aliasPtr->objPtr;
1.1188 +
1.1189 + *prefv = targetNamePtr;
1.1190 + Tcl_IncrRefCount(targetNamePtr);
1.1191 + for (i = 0; i < objc; i++) {
1.1192 + *(++prefv) = objv[i];
1.1193 + Tcl_IncrRefCount(objv[i]);
1.1194 + }
1.1195 +
1.1196 + Tcl_Preserve(slaveInterp);
1.1197 + Tcl_Preserve(masterInterp);
1.1198 +
1.1199 + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
1.1200 + Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
1.1201 + AliasObjCmdDeleteProc);
1.1202 +
1.1203 + if (TclPreventAliasLoop(interp, slaveInterp,
1.1204 + aliasPtr->slaveCmd) != TCL_OK) {
1.1205 + /*
1.1206 + * Found an alias loop! The last call to Tcl_CreateObjCommand made
1.1207 + * the alias point to itself. Delete the command and its alias
1.1208 + * record. Be careful to wipe out its client data first, so the
1.1209 + * command doesn't try to delete itself.
1.1210 + */
1.1211 +
1.1212 + Command *cmdPtr;
1.1213 +
1.1214 + Tcl_DecrRefCount(aliasPtr->namePtr);
1.1215 + Tcl_DecrRefCount(targetNamePtr);
1.1216 + for (i = 0; i < objc; i++) {
1.1217 + Tcl_DecrRefCount(objv[i]);
1.1218 + }
1.1219 +
1.1220 + cmdPtr = (Command *) aliasPtr->slaveCmd;
1.1221 + cmdPtr->clientData = NULL;
1.1222 + cmdPtr->deleteProc = NULL;
1.1223 + cmdPtr->deleteData = NULL;
1.1224 + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
1.1225 +
1.1226 + ckfree((char *) aliasPtr);
1.1227 +
1.1228 + /*
1.1229 + * The result was already set by TclPreventAliasLoop.
1.1230 + */
1.1231 +
1.1232 + Tcl_Release(slaveInterp);
1.1233 + Tcl_Release(masterInterp);
1.1234 + return TCL_ERROR;
1.1235 + }
1.1236 +
1.1237 + /*
1.1238 + * Make an entry in the alias table. If it already exists delete
1.1239 + * the alias command. Then retry.
1.1240 + */
1.1241 +
1.1242 + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1.1243 + while (1) {
1.1244 + Alias *oldAliasPtr;
1.1245 + char *string;
1.1246 +
1.1247 + string = Tcl_GetString(namePtr);
1.1248 + hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
1.1249 + if (new != 0) {
1.1250 + break;
1.1251 + }
1.1252 +
1.1253 + oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1.1254 + Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd);
1.1255 + }
1.1256 +
1.1257 + aliasPtr->aliasEntryPtr = hPtr;
1.1258 + Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
1.1259 +
1.1260 + /*
1.1261 + * Create the new command. We must do it after deleting any old command,
1.1262 + * because the alias may be pointing at a renamed alias, as in:
1.1263 + *
1.1264 + * interp alias {} foo {} bar # Create an alias "foo"
1.1265 + * rename foo zop # Now rename the alias
1.1266 + * interp alias {} foo {} zop # Now recreate "foo"...
1.1267 + */
1.1268 +
1.1269 + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
1.1270 + targetPtr->slaveCmd = aliasPtr->slaveCmd;
1.1271 + targetPtr->slaveInterp = slaveInterp;
1.1272 +
1.1273 + Tcl_MutexLock(&cntMutex);
1.1274 + masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master;
1.1275 + do {
1.1276 + hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable,
1.1277 + (char *) aliasCounter, &new);
1.1278 + aliasCounter++;
1.1279 + } while (new == 0);
1.1280 + Tcl_MutexUnlock(&cntMutex);
1.1281 +
1.1282 + Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
1.1283 + aliasPtr->targetEntryPtr = hPtr;
1.1284 +
1.1285 + Tcl_SetObjResult(interp, namePtr);
1.1286 +
1.1287 + Tcl_Release(slaveInterp);
1.1288 + Tcl_Release(masterInterp);
1.1289 + return TCL_OK;
1.1290 +}
1.1291 +
1.1292 +/*
1.1293 + *----------------------------------------------------------------------
1.1294 + *
1.1295 + * AliasDelete --
1.1296 + *
1.1297 + * Deletes the given alias from the slave interpreter given.
1.1298 + *
1.1299 + * Results:
1.1300 + * A standard Tcl result.
1.1301 + *
1.1302 + * Side effects:
1.1303 + * Deletes the alias from the slave interpreter.
1.1304 + *
1.1305 + *----------------------------------------------------------------------
1.1306 + */
1.1307 +
1.1308 +static int
1.1309 +AliasDelete(interp, slaveInterp, namePtr)
1.1310 + Tcl_Interp *interp; /* Interpreter for result & errors. */
1.1311 + Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
1.1312 + Tcl_Obj *namePtr; /* Name of alias to delete. */
1.1313 +{
1.1314 + Slave *slavePtr;
1.1315 + Alias *aliasPtr;
1.1316 + Tcl_HashEntry *hPtr;
1.1317 +
1.1318 + /*
1.1319 + * If the alias has been renamed in the slave, the master can still use
1.1320 + * the original name (with which it was created) to find the alias to
1.1321 + * delete it.
1.1322 + */
1.1323 +
1.1324 + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1.1325 + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
1.1326 + if (hPtr == NULL) {
1.1327 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"",
1.1328 + Tcl_GetString(namePtr), "\" not found", NULL);
1.1329 + return TCL_ERROR;
1.1330 + }
1.1331 + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1.1332 + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
1.1333 + return TCL_OK;
1.1334 +}
1.1335 +
1.1336 +/*
1.1337 + *----------------------------------------------------------------------
1.1338 + *
1.1339 + * AliasDescribe --
1.1340 + *
1.1341 + * Sets the interpreter's result object to a Tcl list describing
1.1342 + * the given alias in the given interpreter: its target command
1.1343 + * and the additional arguments to prepend to any invocation
1.1344 + * of the alias.
1.1345 + *
1.1346 + * Results:
1.1347 + * A standard Tcl result.
1.1348 + *
1.1349 + * Side effects:
1.1350 + * None.
1.1351 + *
1.1352 + *----------------------------------------------------------------------
1.1353 + */
1.1354 +
1.1355 +static int
1.1356 +AliasDescribe(interp, slaveInterp, namePtr)
1.1357 + Tcl_Interp *interp; /* Interpreter for result & errors. */
1.1358 + Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
1.1359 + Tcl_Obj *namePtr; /* Name of alias to describe. */
1.1360 +{
1.1361 + Slave *slavePtr;
1.1362 + Tcl_HashEntry *hPtr;
1.1363 + Alias *aliasPtr;
1.1364 + Tcl_Obj *prefixPtr;
1.1365 +
1.1366 + /*
1.1367 + * If the alias has been renamed in the slave, the master can still use
1.1368 + * the original name (with which it was created) to find the alias to
1.1369 + * describe it.
1.1370 + */
1.1371 +
1.1372 + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1.1373 + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
1.1374 + if (hPtr == NULL) {
1.1375 + return TCL_OK;
1.1376 + }
1.1377 + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1.1378 + prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
1.1379 + Tcl_SetObjResult(interp, prefixPtr);
1.1380 + return TCL_OK;
1.1381 +}
1.1382 +
1.1383 +/*
1.1384 + *----------------------------------------------------------------------
1.1385 + *
1.1386 + * AliasList --
1.1387 + *
1.1388 + * Computes a list of aliases defined in a slave interpreter.
1.1389 + *
1.1390 + * Results:
1.1391 + * A standard Tcl result.
1.1392 + *
1.1393 + * Side effects:
1.1394 + * None.
1.1395 + *
1.1396 + *----------------------------------------------------------------------
1.1397 + */
1.1398 +
1.1399 +static int
1.1400 +AliasList(interp, slaveInterp)
1.1401 + Tcl_Interp *interp; /* Interp for data return. */
1.1402 + Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */
1.1403 +{
1.1404 + Tcl_HashEntry *entryPtr;
1.1405 + Tcl_HashSearch hashSearch;
1.1406 + Tcl_Obj *resultPtr;
1.1407 + Alias *aliasPtr;
1.1408 + Slave *slavePtr;
1.1409 +
1.1410 + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1.1411 + resultPtr = Tcl_GetObjResult(interp);
1.1412 +
1.1413 + entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
1.1414 + for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
1.1415 + aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
1.1416 + Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
1.1417 + }
1.1418 + return TCL_OK;
1.1419 +}
1.1420 +
1.1421 +/*
1.1422 + *----------------------------------------------------------------------
1.1423 + *
1.1424 + * AliasObjCmd --
1.1425 + *
1.1426 + * This is the procedure that services invocations of aliases in a
1.1427 + * slave interpreter. One such command exists for each alias. When
1.1428 + * invoked, this procedure redirects the invocation to the target
1.1429 + * command in the master interpreter as designated by the Alias
1.1430 + * record associated with this command.
1.1431 + *
1.1432 + * Results:
1.1433 + * A standard Tcl result.
1.1434 + *
1.1435 + * Side effects:
1.1436 + * Causes forwarding of the invocation; all possible side effects
1.1437 + * may occur as a result of invoking the command to which the
1.1438 + * invocation is forwarded.
1.1439 + *
1.1440 + *----------------------------------------------------------------------
1.1441 + */
1.1442 +
1.1443 +static int
1.1444 +AliasObjCmd(clientData, interp, objc, objv)
1.1445 + ClientData clientData; /* Alias record. */
1.1446 + Tcl_Interp *interp; /* Current interpreter. */
1.1447 + int objc; /* Number of arguments. */
1.1448 + Tcl_Obj *CONST objv[]; /* Argument vector. */
1.1449 +{
1.1450 +#define ALIAS_CMDV_PREALLOC 10
1.1451 + Tcl_Interp *targetInterp;
1.1452 + Alias *aliasPtr;
1.1453 + int result, prefc, cmdc, i;
1.1454 + Tcl_Obj **prefv, **cmdv;
1.1455 + Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
1.1456 + aliasPtr = (Alias *) clientData;
1.1457 + targetInterp = aliasPtr->targetInterp;
1.1458 +
1.1459 + /*
1.1460 + * Append the arguments to the command prefix and invoke the command
1.1461 + * in the target interp's global namespace.
1.1462 + */
1.1463 +
1.1464 + prefc = aliasPtr->objc;
1.1465 + prefv = &aliasPtr->objPtr;
1.1466 + cmdc = prefc + objc - 1;
1.1467 + if (cmdc <= ALIAS_CMDV_PREALLOC) {
1.1468 + cmdv = cmdArr;
1.1469 + } else {
1.1470 + cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
1.1471 + }
1.1472 +
1.1473 + prefv = &aliasPtr->objPtr;
1.1474 + memcpy((VOID *) cmdv, (VOID *) prefv,
1.1475 + (size_t) (prefc * sizeof(Tcl_Obj *)));
1.1476 + memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
1.1477 + (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
1.1478 +
1.1479 + Tcl_ResetResult(targetInterp);
1.1480 +
1.1481 + for (i=0; i<cmdc; i++) {
1.1482 + Tcl_IncrRefCount(cmdv[i]);
1.1483 + }
1.1484 + if (targetInterp != interp) {
1.1485 + Tcl_Preserve((ClientData) targetInterp);
1.1486 + result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
1.1487 + TclTransferResult(targetInterp, result, interp);
1.1488 + Tcl_Release((ClientData) targetInterp);
1.1489 + } else {
1.1490 + result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
1.1491 + }
1.1492 + for (i=0; i<cmdc; i++) {
1.1493 + Tcl_DecrRefCount(cmdv[i]);
1.1494 + }
1.1495 +
1.1496 + if (cmdv != cmdArr) {
1.1497 + ckfree((char *) cmdv);
1.1498 + }
1.1499 + return result;
1.1500 +#undef ALIAS_CMDV_PREALLOC
1.1501 +}
1.1502 +
1.1503 +/*
1.1504 + *----------------------------------------------------------------------
1.1505 + *
1.1506 + * AliasObjCmdDeleteProc --
1.1507 + *
1.1508 + * Is invoked when an alias command is deleted in a slave. Cleans up
1.1509 + * all storage associated with this alias.
1.1510 + *
1.1511 + * Results:
1.1512 + * None.
1.1513 + *
1.1514 + * Side effects:
1.1515 + * Deletes the alias record and its entry in the alias table for
1.1516 + * the interpreter.
1.1517 + *
1.1518 + *----------------------------------------------------------------------
1.1519 + */
1.1520 +
1.1521 +static void
1.1522 +AliasObjCmdDeleteProc(clientData)
1.1523 + ClientData clientData; /* The alias record for this alias. */
1.1524 +{
1.1525 + Alias *aliasPtr;
1.1526 + Target *targetPtr;
1.1527 + int i;
1.1528 + Tcl_Obj **objv;
1.1529 +
1.1530 + aliasPtr = (Alias *) clientData;
1.1531 +
1.1532 + Tcl_DecrRefCount(aliasPtr->namePtr);
1.1533 + objv = &aliasPtr->objPtr;
1.1534 + for (i = 0; i < aliasPtr->objc; i++) {
1.1535 + Tcl_DecrRefCount(objv[i]);
1.1536 + }
1.1537 + Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
1.1538 +
1.1539 + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
1.1540 + ckfree((char *) targetPtr);
1.1541 + Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);
1.1542 +
1.1543 + ckfree((char *) aliasPtr);
1.1544 +}
1.1545 +
1.1546 +/*
1.1547 + *----------------------------------------------------------------------
1.1548 + *
1.1549 + * Tcl_CreateSlave --
1.1550 + *
1.1551 + * Creates a slave interpreter. The slavePath argument denotes the
1.1552 + * name of the new slave relative to the current interpreter; the
1.1553 + * slave is a direct descendant of the one-before-last component of
1.1554 + * the path, e.g. it is a descendant of the current interpreter if
1.1555 + * the slavePath argument contains only one component. Optionally makes
1.1556 + * the slave interpreter safe.
1.1557 + *
1.1558 + * Results:
1.1559 + * Returns the interpreter structure created, or NULL if an error
1.1560 + * occurred.
1.1561 + *
1.1562 + * Side effects:
1.1563 + * Creates a new interpreter and a new interpreter object command in
1.1564 + * the interpreter indicated by the slavePath argument.
1.1565 + *
1.1566 + *----------------------------------------------------------------------
1.1567 + */
1.1568 +
1.1569 +EXPORT_C Tcl_Interp *
1.1570 +Tcl_CreateSlave(interp, slavePath, isSafe)
1.1571 + Tcl_Interp *interp; /* Interpreter to start search at. */
1.1572 + CONST char *slavePath; /* Name of slave to create. */
1.1573 + int isSafe; /* Should new slave be "safe" ? */
1.1574 +{
1.1575 + Tcl_Obj *pathPtr;
1.1576 + Tcl_Interp *slaveInterp;
1.1577 +
1.1578 + pathPtr = Tcl_NewStringObj(slavePath, -1);
1.1579 + slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
1.1580 + Tcl_DecrRefCount(pathPtr);
1.1581 +
1.1582 + return slaveInterp;
1.1583 +}
1.1584 +
1.1585 +/*
1.1586 + *----------------------------------------------------------------------
1.1587 + *
1.1588 + * Tcl_GetSlave --
1.1589 + *
1.1590 + * Finds a slave interpreter by its path name.
1.1591 + *
1.1592 + * Results:
1.1593 + * Returns a Tcl_Interp * for the named interpreter or NULL if not
1.1594 + * found.
1.1595 + *
1.1596 + * Side effects:
1.1597 + * None.
1.1598 + *
1.1599 + *----------------------------------------------------------------------
1.1600 + */
1.1601 +
1.1602 +EXPORT_C Tcl_Interp *
1.1603 +Tcl_GetSlave(interp, slavePath)
1.1604 + Tcl_Interp *interp; /* Interpreter to start search from. */
1.1605 + CONST char *slavePath; /* Path of slave to find. */
1.1606 +{
1.1607 + Tcl_Obj *pathPtr;
1.1608 + Tcl_Interp *slaveInterp;
1.1609 +
1.1610 + pathPtr = Tcl_NewStringObj(slavePath, -1);
1.1611 + slaveInterp = GetInterp(interp, pathPtr);
1.1612 + Tcl_DecrRefCount(pathPtr);
1.1613 +
1.1614 + return slaveInterp;
1.1615 +}
1.1616 +
1.1617 +/*
1.1618 + *----------------------------------------------------------------------
1.1619 + *
1.1620 + * Tcl_GetMaster --
1.1621 + *
1.1622 + * Finds the master interpreter of a slave interpreter.
1.1623 + *
1.1624 + * Results:
1.1625 + * Returns a Tcl_Interp * for the master interpreter or NULL if none.
1.1626 + *
1.1627 + * Side effects:
1.1628 + * None.
1.1629 + *
1.1630 + *----------------------------------------------------------------------
1.1631 + */
1.1632 +
1.1633 +EXPORT_C Tcl_Interp *
1.1634 +Tcl_GetMaster(interp)
1.1635 + Tcl_Interp *interp; /* Get the master of this interpreter. */
1.1636 +{
1.1637 + Slave *slavePtr; /* Slave record of this interpreter. */
1.1638 +
1.1639 + if (interp == (Tcl_Interp *) NULL) {
1.1640 + return NULL;
1.1641 + }
1.1642 + slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
1.1643 + return slavePtr->masterInterp;
1.1644 +}
1.1645 +
1.1646 +/*
1.1647 + *----------------------------------------------------------------------
1.1648 + *
1.1649 + * Tcl_GetInterpPath --
1.1650 + *
1.1651 + * Sets the result of the asking interpreter to a proper Tcl list
1.1652 + * containing the names of interpreters between the asking and
1.1653 + * target interpreters. The target interpreter must be either the
1.1654 + * same as the asking interpreter or one of its slaves (including
1.1655 + * recursively).
1.1656 + *
1.1657 + * Results:
1.1658 + * TCL_OK if the target interpreter is the same as, or a descendant
1.1659 + * of, the asking interpreter; TCL_ERROR else. This way one can
1.1660 + * distinguish between the case where the asking and target interps
1.1661 + * are the same (an empty list is the result, and TCL_OK is returned)
1.1662 + * and when the target is not a descendant of the asking interpreter
1.1663 + * (in which case the Tcl result is an error message and the function
1.1664 + * returns TCL_ERROR).
1.1665 + *
1.1666 + * Side effects:
1.1667 + * None.
1.1668 + *
1.1669 + *----------------------------------------------------------------------
1.1670 + */
1.1671 +
1.1672 +EXPORT_C int
1.1673 +Tcl_GetInterpPath(askingInterp, targetInterp)
1.1674 + Tcl_Interp *askingInterp; /* Interpreter to start search from. */
1.1675 + Tcl_Interp *targetInterp; /* Interpreter to find. */
1.1676 +{
1.1677 + InterpInfo *iiPtr;
1.1678 +
1.1679 + if (targetInterp == askingInterp) {
1.1680 + return TCL_OK;
1.1681 + }
1.1682 + if (targetInterp == NULL) {
1.1683 + return TCL_ERROR;
1.1684 + }
1.1685 + iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
1.1686 + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
1.1687 + return TCL_ERROR;
1.1688 + }
1.1689 + Tcl_AppendElement(askingInterp,
1.1690 + Tcl_GetHashKey(&iiPtr->master.slaveTable,
1.1691 + iiPtr->slave.slaveEntryPtr));
1.1692 + return TCL_OK;
1.1693 +}
1.1694 +
1.1695 +/*
1.1696 + *----------------------------------------------------------------------
1.1697 + *
1.1698 + * GetInterp --
1.1699 + *
1.1700 + * Helper function to find a slave interpreter given a pathname.
1.1701 + *
1.1702 + * Results:
1.1703 + * Returns the slave interpreter known by that name in the calling
1.1704 + * interpreter, or NULL if no interpreter known by that name exists.
1.1705 + *
1.1706 + * Side effects:
1.1707 + * Assigns to the pointer variable passed in, if not NULL.
1.1708 + *
1.1709 + *----------------------------------------------------------------------
1.1710 + */
1.1711 +
1.1712 +static Tcl_Interp *
1.1713 +GetInterp(interp, pathPtr)
1.1714 + Tcl_Interp *interp; /* Interp. to start search from. */
1.1715 + Tcl_Obj *pathPtr; /* List object containing name of interp. to
1.1716 + * be found. */
1.1717 +{
1.1718 + Tcl_HashEntry *hPtr; /* Search element. */
1.1719 + Slave *slavePtr; /* Interim slave record. */
1.1720 + Tcl_Obj **objv;
1.1721 + int objc, i;
1.1722 + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
1.1723 + InterpInfo *masterInfoPtr;
1.1724 +
1.1725 + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
1.1726 + return NULL;
1.1727 + }
1.1728 +
1.1729 + searchInterp = interp;
1.1730 + for (i = 0; i < objc; i++) {
1.1731 + masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
1.1732 + hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
1.1733 + Tcl_GetString(objv[i]));
1.1734 + if (hPtr == NULL) {
1.1735 + searchInterp = NULL;
1.1736 + break;
1.1737 + }
1.1738 + slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
1.1739 + searchInterp = slavePtr->slaveInterp;
1.1740 + if (searchInterp == NULL) {
1.1741 + break;
1.1742 + }
1.1743 + }
1.1744 + if (searchInterp == NULL) {
1.1745 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1746 + "could not find interpreter \"",
1.1747 + Tcl_GetString(pathPtr), "\"", (char *) NULL);
1.1748 + }
1.1749 + return searchInterp;
1.1750 +}
1.1751 +
1.1752 +/*
1.1753 + *----------------------------------------------------------------------
1.1754 + *
1.1755 + * SlaveCreate --
1.1756 + *
1.1757 + * Helper function to do the actual work of creating a slave interp
1.1758 + * and new object command. Also optionally makes the new slave
1.1759 + * interpreter "safe".
1.1760 + *
1.1761 + * Results:
1.1762 + * Returns the new Tcl_Interp * if successful or NULL if not. If failed,
1.1763 + * the result of the invoking interpreter contains an error message.
1.1764 + *
1.1765 + * Side effects:
1.1766 + * Creates a new slave interpreter and a new object command.
1.1767 + *
1.1768 + *----------------------------------------------------------------------
1.1769 + */
1.1770 +
1.1771 +static Tcl_Interp *
1.1772 +SlaveCreate(interp, pathPtr, safe)
1.1773 + Tcl_Interp *interp; /* Interp. to start search from. */
1.1774 + Tcl_Obj *pathPtr; /* Path (name) of slave to create. */
1.1775 + int safe; /* Should we make it "safe"? */
1.1776 +{
1.1777 + Tcl_Interp *masterInterp, *slaveInterp;
1.1778 + Slave *slavePtr;
1.1779 + InterpInfo *masterInfoPtr;
1.1780 + Tcl_HashEntry *hPtr;
1.1781 + char *path;
1.1782 + int new, objc;
1.1783 + Tcl_Obj **objv;
1.1784 +
1.1785 + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
1.1786 + return NULL;
1.1787 + }
1.1788 + if (objc < 2) {
1.1789 + masterInterp = interp;
1.1790 + path = Tcl_GetString(pathPtr);
1.1791 + } else {
1.1792 + Tcl_Obj *objPtr;
1.1793 +
1.1794 + objPtr = Tcl_NewListObj(objc - 1, objv);
1.1795 + masterInterp = GetInterp(interp, objPtr);
1.1796 + Tcl_DecrRefCount(objPtr);
1.1797 + if (masterInterp == NULL) {
1.1798 + return NULL;
1.1799 + }
1.1800 + path = Tcl_GetString(objv[objc - 1]);
1.1801 + }
1.1802 + if (safe == 0) {
1.1803 + safe = Tcl_IsSafe(masterInterp);
1.1804 + }
1.1805 +
1.1806 + masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
1.1807 + hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
1.1808 + if (new == 0) {
1.1809 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1810 + "interpreter named \"", path,
1.1811 + "\" already exists, cannot create", (char *) NULL);
1.1812 + return NULL;
1.1813 + }
1.1814 +
1.1815 + slaveInterp = Tcl_CreateInterp();
1.1816 + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1.1817 + slavePtr->masterInterp = masterInterp;
1.1818 + slavePtr->slaveEntryPtr = hPtr;
1.1819 + slavePtr->slaveInterp = slaveInterp;
1.1820 + slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
1.1821 + SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
1.1822 + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
1.1823 + Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
1.1824 + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
1.1825 +
1.1826 + /*
1.1827 + * Inherit the recursion limit.
1.1828 + */
1.1829 + ((Interp *) slaveInterp)->maxNestingDepth =
1.1830 + ((Interp *) masterInterp)->maxNestingDepth ;
1.1831 +
1.1832 + if (safe) {
1.1833 + if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
1.1834 + goto error;
1.1835 + }
1.1836 + } else {
1.1837 + if (Tcl_Init(slaveInterp) == TCL_ERROR) {
1.1838 + goto error;
1.1839 + }
1.1840 + /*
1.1841 + * This will create the "memory" command in slave interpreters
1.1842 + * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing.
1.1843 + */
1.1844 + Tcl_InitMemory(slaveInterp);
1.1845 + }
1.1846 + return slaveInterp;
1.1847 +
1.1848 + error:
1.1849 + TclTransferResult(slaveInterp, TCL_ERROR, interp);
1.1850 + Tcl_DeleteInterp(slaveInterp);
1.1851 +
1.1852 + return NULL;
1.1853 +}
1.1854 +
1.1855 +/*
1.1856 + *----------------------------------------------------------------------
1.1857 + *
1.1858 + * SlaveObjCmd --
1.1859 + *
1.1860 + * Command to manipulate an interpreter, e.g. to send commands to it
1.1861 + * to be evaluated. One such command exists for each slave interpreter.
1.1862 + *
1.1863 + * Results:
1.1864 + * A standard Tcl result.
1.1865 + *
1.1866 + * Side effects:
1.1867 + * See user documentation for details.
1.1868 + *
1.1869 + *----------------------------------------------------------------------
1.1870 + */
1.1871 +
1.1872 +static int
1.1873 +SlaveObjCmd(clientData, interp, objc, objv)
1.1874 + ClientData clientData; /* Slave interpreter. */
1.1875 + Tcl_Interp *interp; /* Current interpreter. */
1.1876 + int objc; /* Number of arguments. */
1.1877 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1878 +{
1.1879 + Tcl_Interp *slaveInterp;
1.1880 + int index;
1.1881 + static CONST char *options[] = {
1.1882 + "alias", "aliases", "eval", "expose",
1.1883 + "hide", "hidden", "issafe", "invokehidden",
1.1884 + "marktrusted", "recursionlimit", NULL
1.1885 + };
1.1886 + enum options {
1.1887 + OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
1.1888 + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
1.1889 + OPT_MARKTRUSTED, OPT_RECLIMIT
1.1890 + };
1.1891 +
1.1892 + slaveInterp = (Tcl_Interp *) clientData;
1.1893 + if (slaveInterp == NULL) {
1.1894 + panic("SlaveObjCmd: interpreter has been deleted");
1.1895 + }
1.1896 +
1.1897 + if (objc < 2) {
1.1898 + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
1.1899 + return TCL_ERROR;
1.1900 + }
1.1901 + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
1.1902 + &index) != TCL_OK) {
1.1903 + return TCL_ERROR;
1.1904 + }
1.1905 +
1.1906 + switch ((enum options) index) {
1.1907 + case OPT_ALIAS: {
1.1908 + if (objc > 2) {
1.1909 + if (objc == 3) {
1.1910 + return AliasDescribe(interp, slaveInterp, objv[2]);
1.1911 + }
1.1912 + if (Tcl_GetString(objv[3])[0] == '\0') {
1.1913 + if (objc == 4) {
1.1914 + return AliasDelete(interp, slaveInterp, objv[2]);
1.1915 + }
1.1916 + } else {
1.1917 + return AliasCreate(interp, slaveInterp, interp, objv[2],
1.1918 + objv[3], objc - 4, objv + 4);
1.1919 + }
1.1920 + }
1.1921 + Tcl_WrongNumArgs(interp, 2, objv,
1.1922 + "aliasName ?targetName? ?args..?");
1.1923 + return TCL_ERROR;
1.1924 + }
1.1925 + case OPT_ALIASES: {
1.1926 + if (objc != 2) {
1.1927 + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
1.1928 + return TCL_ERROR;
1.1929 + }
1.1930 + return AliasList(interp, slaveInterp);
1.1931 + }
1.1932 + case OPT_EVAL: {
1.1933 + if (objc < 3) {
1.1934 + Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
1.1935 + return TCL_ERROR;
1.1936 + }
1.1937 + return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
1.1938 + }
1.1939 + case OPT_EXPOSE: {
1.1940 + if ((objc < 3) || (objc > 4)) {
1.1941 + Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
1.1942 + return TCL_ERROR;
1.1943 + }
1.1944 + return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
1.1945 + }
1.1946 + case OPT_HIDE: {
1.1947 + if ((objc < 3) || (objc > 4)) {
1.1948 + Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
1.1949 + return TCL_ERROR;
1.1950 + }
1.1951 + return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
1.1952 + }
1.1953 + case OPT_HIDDEN: {
1.1954 + if (objc != 2) {
1.1955 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1956 + return TCL_ERROR;
1.1957 + }
1.1958 + return SlaveHidden(interp, slaveInterp);
1.1959 + }
1.1960 + case OPT_ISSAFE: {
1.1961 + if (objc != 2) {
1.1962 + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
1.1963 + return TCL_ERROR;
1.1964 + }
1.1965 + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
1.1966 + return TCL_OK;
1.1967 + }
1.1968 + case OPT_INVOKEHIDDEN: {
1.1969 + int global, i, index;
1.1970 + static CONST char *hiddenOptions[] = {
1.1971 + "-global", "--", NULL
1.1972 + };
1.1973 + enum hiddenOption {
1.1974 + OPT_GLOBAL, OPT_LAST
1.1975 + };
1.1976 + global = 0;
1.1977 + for (i = 2; i < objc; i++) {
1.1978 + if (Tcl_GetString(objv[i])[0] != '-') {
1.1979 + break;
1.1980 + }
1.1981 + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
1.1982 + "option", 0, &index) != TCL_OK) {
1.1983 + return TCL_ERROR;
1.1984 + }
1.1985 + if (index == OPT_GLOBAL) {
1.1986 + global = 1;
1.1987 + } else {
1.1988 + i++;
1.1989 + break;
1.1990 + }
1.1991 + }
1.1992 + if (objc - i < 1) {
1.1993 + Tcl_WrongNumArgs(interp, 2, objv,
1.1994 + "?-global? ?--? cmd ?arg ..?");
1.1995 + return TCL_ERROR;
1.1996 + }
1.1997 + return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
1.1998 + objv + i);
1.1999 + }
1.2000 + case OPT_MARKTRUSTED: {
1.2001 + if (objc != 2) {
1.2002 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.2003 + return TCL_ERROR;
1.2004 + }
1.2005 + return SlaveMarkTrusted(interp, slaveInterp);
1.2006 + }
1.2007 + case OPT_RECLIMIT: {
1.2008 + if (objc != 2 && objc != 3) {
1.2009 + Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
1.2010 + return TCL_ERROR;
1.2011 + }
1.2012 + return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
1.2013 + }
1.2014 + }
1.2015 +
1.2016 + return TCL_ERROR;
1.2017 +}
1.2018 +
1.2019 +/*
1.2020 + *----------------------------------------------------------------------
1.2021 + *
1.2022 + * SlaveObjCmdDeleteProc --
1.2023 + *
1.2024 + * Invoked when an object command for a slave interpreter is deleted;
1.2025 + * cleans up all state associated with the slave interpreter and destroys
1.2026 + * the slave interpreter.
1.2027 + *
1.2028 + * Results:
1.2029 + * None.
1.2030 + *
1.2031 + * Side effects:
1.2032 + * Cleans up all state associated with the slave interpreter and
1.2033 + * destroys the slave interpreter.
1.2034 + *
1.2035 + *----------------------------------------------------------------------
1.2036 + */
1.2037 +
1.2038 +static void
1.2039 +SlaveObjCmdDeleteProc(clientData)
1.2040 + ClientData clientData; /* The SlaveRecord for the command. */
1.2041 +{
1.2042 + Slave *slavePtr; /* Interim storage for Slave record. */
1.2043 + Tcl_Interp *slaveInterp; /* And for a slave interp. */
1.2044 +
1.2045 + slaveInterp = (Tcl_Interp *) clientData;
1.2046 + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1.2047 +
1.2048 + /*
1.2049 + * Unlink the slave from its master interpreter.
1.2050 + */
1.2051 +
1.2052 + Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);
1.2053 +
1.2054 + /*
1.2055 + * Set to NULL so that when the InterpInfo is cleaned up in the slave
1.2056 + * it does not try to delete the command causing all sorts of grief.
1.2057 + * See SlaveRecordDeleteProc().
1.2058 + */
1.2059 +
1.2060 + slavePtr->interpCmd = NULL;
1.2061 +
1.2062 + if (slavePtr->slaveInterp != NULL) {
1.2063 + Tcl_DeleteInterp(slavePtr->slaveInterp);
1.2064 + }
1.2065 +}
1.2066 +
1.2067 +/*
1.2068 + *----------------------------------------------------------------------
1.2069 + *
1.2070 + * SlaveEval --
1.2071 + *
1.2072 + * Helper function to evaluate a command in a slave interpreter.
1.2073 + *
1.2074 + * Results:
1.2075 + * A standard Tcl result.
1.2076 + *
1.2077 + * Side effects:
1.2078 + * Whatever the command does.
1.2079 + *
1.2080 + *----------------------------------------------------------------------
1.2081 + */
1.2082 +
1.2083 +static int
1.2084 +SlaveEval(interp, slaveInterp, objc, objv)
1.2085 + Tcl_Interp *interp; /* Interp for error return. */
1.2086 + Tcl_Interp *slaveInterp; /* The slave interpreter in which command
1.2087 + * will be evaluated. */
1.2088 + int objc; /* Number of arguments. */
1.2089 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2090 +{
1.2091 + int result;
1.2092 + Tcl_Obj *objPtr;
1.2093 +
1.2094 + Tcl_Preserve((ClientData) slaveInterp);
1.2095 + Tcl_AllowExceptions(slaveInterp);
1.2096 +
1.2097 + if (objc == 1) {
1.2098 +#ifndef TCL_TIP280
1.2099 + result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
1.2100 +#else
1.2101 + /* TIP #280 : Make invoker available to eval'd script */
1.2102 + Interp* iPtr = (Interp*) interp;
1.2103 + result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0);
1.2104 +#endif
1.2105 + } else {
1.2106 + objPtr = Tcl_ConcatObj(objc, objv);
1.2107 + Tcl_IncrRefCount(objPtr);
1.2108 + result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
1.2109 + Tcl_DecrRefCount(objPtr);
1.2110 + }
1.2111 + TclTransferResult(slaveInterp, result, interp);
1.2112 +
1.2113 + Tcl_Release((ClientData) slaveInterp);
1.2114 + return result;
1.2115 +}
1.2116 +
1.2117 +/*
1.2118 + *----------------------------------------------------------------------
1.2119 + *
1.2120 + * SlaveExpose --
1.2121 + *
1.2122 + * Helper function to expose a command in a slave interpreter.
1.2123 + *
1.2124 + * Results:
1.2125 + * A standard Tcl result.
1.2126 + *
1.2127 + * Side effects:
1.2128 + * After this call scripts in the slave will be able to invoke
1.2129 + * the newly exposed command.
1.2130 + *
1.2131 + *----------------------------------------------------------------------
1.2132 + */
1.2133 +
1.2134 +static int
1.2135 +SlaveExpose(interp, slaveInterp, objc, objv)
1.2136 + Tcl_Interp *interp; /* Interp for error return. */
1.2137 + Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
1.2138 + int objc; /* Number of arguments. */
1.2139 + Tcl_Obj *CONST objv[]; /* Argument strings. */
1.2140 +{
1.2141 + char *name;
1.2142 +
1.2143 + if (Tcl_IsSafe(interp)) {
1.2144 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2145 + "permission denied: safe interpreter cannot expose commands",
1.2146 + (char *) NULL);
1.2147 + return TCL_ERROR;
1.2148 + }
1.2149 +
1.2150 + name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
1.2151 + if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
1.2152 + name) != TCL_OK) {
1.2153 + TclTransferResult(slaveInterp, TCL_ERROR, interp);
1.2154 + return TCL_ERROR;
1.2155 + }
1.2156 + return TCL_OK;
1.2157 +}
1.2158 +
1.2159 +/*
1.2160 + *----------------------------------------------------------------------
1.2161 + *
1.2162 + * SlaveRecursionLimit --
1.2163 + *
1.2164 + * Helper function to set/query the Recursion limit of an interp
1.2165 + *
1.2166 + * Results:
1.2167 + * A standard Tcl result.
1.2168 + *
1.2169 + * Side effects:
1.2170 + * When (objc == 1), slaveInterp will be set to a new recursion
1.2171 + * limit of objv[0].
1.2172 + *
1.2173 + *----------------------------------------------------------------------
1.2174 + */
1.2175 +
1.2176 +static int
1.2177 +SlaveRecursionLimit(interp, slaveInterp, objc, objv)
1.2178 + Tcl_Interp *interp; /* Interp for error return. */
1.2179 + Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */
1.2180 + int objc; /* Set or Query. */
1.2181 + Tcl_Obj *CONST objv[]; /* Argument strings. */
1.2182 +{
1.2183 + Interp *iPtr;
1.2184 + int limit;
1.2185 +
1.2186 + if (objc) {
1.2187 + if (Tcl_IsSafe(interp)) {
1.2188 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2189 + "permission denied: ",
1.2190 + "safe interpreters cannot change recursion limit",
1.2191 + (char *) NULL);
1.2192 + return TCL_ERROR;
1.2193 + }
1.2194 + if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
1.2195 + return TCL_ERROR;
1.2196 + }
1.2197 + if (limit <= 0) {
1.2198 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.2199 + "recursion limit must be > 0", -1));
1.2200 + return TCL_ERROR;
1.2201 + }
1.2202 + Tcl_SetRecursionLimit(slaveInterp, limit);
1.2203 + iPtr = (Interp *) slaveInterp;
1.2204 + if (interp == slaveInterp && iPtr->numLevels > limit) {
1.2205 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.2206 + "falling back due to new recursion limit", -1));
1.2207 + return TCL_ERROR;
1.2208 + }
1.2209 + Tcl_SetObjResult(interp, objv[0]);
1.2210 + return TCL_OK;
1.2211 + } else {
1.2212 + limit = Tcl_SetRecursionLimit(slaveInterp, 0);
1.2213 + Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
1.2214 + return TCL_OK;
1.2215 + }
1.2216 +}
1.2217 +
1.2218 +/*
1.2219 + *----------------------------------------------------------------------
1.2220 + *
1.2221 + * SlaveHide --
1.2222 + *
1.2223 + * Helper function to hide a command in a slave interpreter.
1.2224 + *
1.2225 + * Results:
1.2226 + * A standard Tcl result.
1.2227 + *
1.2228 + * Side effects:
1.2229 + * After this call scripts in the slave will no longer be able
1.2230 + * to invoke the named command.
1.2231 + *
1.2232 + *----------------------------------------------------------------------
1.2233 + */
1.2234 +
1.2235 +static int
1.2236 +SlaveHide(interp, slaveInterp, objc, objv)
1.2237 + Tcl_Interp *interp; /* Interp for error return. */
1.2238 + Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
1.2239 + int objc; /* Number of arguments. */
1.2240 + Tcl_Obj *CONST objv[]; /* Argument strings. */
1.2241 +{
1.2242 + char *name;
1.2243 +
1.2244 + if (Tcl_IsSafe(interp)) {
1.2245 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2246 + "permission denied: safe interpreter cannot hide commands",
1.2247 + (char *) NULL);
1.2248 + return TCL_ERROR;
1.2249 + }
1.2250 +
1.2251 + name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
1.2252 + if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
1.2253 + name) != TCL_OK) {
1.2254 + TclTransferResult(slaveInterp, TCL_ERROR, interp);
1.2255 + return TCL_ERROR;
1.2256 + }
1.2257 + return TCL_OK;
1.2258 +}
1.2259 +
1.2260 +/*
1.2261 + *----------------------------------------------------------------------
1.2262 + *
1.2263 + * SlaveHidden --
1.2264 + *
1.2265 + * Helper function to compute list of hidden commands in a slave
1.2266 + * interpreter.
1.2267 + *
1.2268 + * Results:
1.2269 + * A standard Tcl result.
1.2270 + *
1.2271 + * Side effects:
1.2272 + * None.
1.2273 + *
1.2274 + *----------------------------------------------------------------------
1.2275 + */
1.2276 +
1.2277 +static int
1.2278 +SlaveHidden(interp, slaveInterp)
1.2279 + Tcl_Interp *interp; /* Interp for data return. */
1.2280 + Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */
1.2281 +{
1.2282 + Tcl_Obj *listObjPtr; /* Local object pointer. */
1.2283 + Tcl_HashTable *hTblPtr; /* For local searches. */
1.2284 + Tcl_HashEntry *hPtr; /* For local searches. */
1.2285 + Tcl_HashSearch hSearch; /* For local searches. */
1.2286 +
1.2287 + listObjPtr = Tcl_GetObjResult(interp);
1.2288 + hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
1.2289 + if (hTblPtr != (Tcl_HashTable *) NULL) {
1.2290 + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
1.2291 + hPtr != (Tcl_HashEntry *) NULL;
1.2292 + hPtr = Tcl_NextHashEntry(&hSearch)) {
1.2293 +
1.2294 + Tcl_ListObjAppendElement(NULL, listObjPtr,
1.2295 + Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
1.2296 + }
1.2297 + }
1.2298 + return TCL_OK;
1.2299 +}
1.2300 +
1.2301 +/*
1.2302 + *----------------------------------------------------------------------
1.2303 + *
1.2304 + * SlaveInvokeHidden --
1.2305 + *
1.2306 + * Helper function to invoke a hidden command in a slave interpreter.
1.2307 + *
1.2308 + * Results:
1.2309 + * A standard Tcl result.
1.2310 + *
1.2311 + * Side effects:
1.2312 + * Whatever the hidden command does.
1.2313 + *
1.2314 + *----------------------------------------------------------------------
1.2315 + */
1.2316 +
1.2317 +static int
1.2318 +SlaveInvokeHidden(interp, slaveInterp, global, objc, objv)
1.2319 + Tcl_Interp *interp; /* Interp for error return. */
1.2320 + Tcl_Interp *slaveInterp; /* The slave interpreter in which command
1.2321 + * will be invoked. */
1.2322 + int global; /* Non-zero to invoke in global namespace. */
1.2323 + int objc; /* Number of arguments. */
1.2324 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2325 +{
1.2326 + int result;
1.2327 +
1.2328 + if (Tcl_IsSafe(interp)) {
1.2329 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.2330 + "not allowed to invoke hidden commands from safe interpreter",
1.2331 + -1);
1.2332 + return TCL_ERROR;
1.2333 + }
1.2334 +
1.2335 + Tcl_Preserve((ClientData) slaveInterp);
1.2336 + Tcl_AllowExceptions(slaveInterp);
1.2337 +
1.2338 + if (global) {
1.2339 + result = TclObjInvokeGlobal(slaveInterp, objc, objv,
1.2340 + TCL_INVOKE_HIDDEN);
1.2341 + } else {
1.2342 + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
1.2343 + }
1.2344 +
1.2345 + TclTransferResult(slaveInterp, result, interp);
1.2346 +
1.2347 + Tcl_Release((ClientData) slaveInterp);
1.2348 + return result;
1.2349 +}
1.2350 +
1.2351 +/*
1.2352 + *----------------------------------------------------------------------
1.2353 + *
1.2354 + * SlaveMarkTrusted --
1.2355 + *
1.2356 + * Helper function to mark a slave interpreter as trusted (unsafe).
1.2357 + *
1.2358 + * Results:
1.2359 + * A standard Tcl result.
1.2360 + *
1.2361 + * Side effects:
1.2362 + * After this call the hard-wired security checks in the core no
1.2363 + * longer prevent the slave from performing certain operations.
1.2364 + *
1.2365 + *----------------------------------------------------------------------
1.2366 + */
1.2367 +
1.2368 +static int
1.2369 +SlaveMarkTrusted(interp, slaveInterp)
1.2370 + Tcl_Interp *interp; /* Interp for error return. */
1.2371 + Tcl_Interp *slaveInterp; /* The slave interpreter which will be
1.2372 + * marked trusted. */
1.2373 +{
1.2374 + if (Tcl_IsSafe(interp)) {
1.2375 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2376 + "permission denied: safe interpreter cannot mark trusted",
1.2377 + (char *) NULL);
1.2378 + return TCL_ERROR;
1.2379 + }
1.2380 + ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
1.2381 + return TCL_OK;
1.2382 +}
1.2383 +
1.2384 +/*
1.2385 + *----------------------------------------------------------------------
1.2386 + *
1.2387 + * Tcl_IsSafe --
1.2388 + *
1.2389 + * Determines whether an interpreter is safe
1.2390 + *
1.2391 + * Results:
1.2392 + * 1 if it is safe, 0 if it is not.
1.2393 + *
1.2394 + * Side effects:
1.2395 + * None.
1.2396 + *
1.2397 + *----------------------------------------------------------------------
1.2398 + */
1.2399 +
1.2400 +EXPORT_C int
1.2401 +Tcl_IsSafe(interp)
1.2402 + Tcl_Interp *interp; /* Is this interpreter "safe" ? */
1.2403 +{
1.2404 + Interp *iPtr;
1.2405 +
1.2406 + if (interp == (Tcl_Interp *) NULL) {
1.2407 + return 0;
1.2408 + }
1.2409 + iPtr = (Interp *) interp;
1.2410 +
1.2411 + return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
1.2412 +}
1.2413 +
1.2414 +/*
1.2415 + *----------------------------------------------------------------------
1.2416 + *
1.2417 + * Tcl_MakeSafe --
1.2418 + *
1.2419 + * Makes its argument interpreter contain only functionality that is
1.2420 + * defined to be part of Safe Tcl. Unsafe commands are hidden, the
1.2421 + * env array is unset, and the standard channels are removed.
1.2422 + *
1.2423 + * Results:
1.2424 + * None.
1.2425 + *
1.2426 + * Side effects:
1.2427 + * Hides commands in its argument interpreter, and removes settings
1.2428 + * and channels.
1.2429 + *
1.2430 + *----------------------------------------------------------------------
1.2431 + */
1.2432 +
1.2433 +EXPORT_C int
1.2434 +Tcl_MakeSafe(interp)
1.2435 + Tcl_Interp *interp; /* Interpreter to be made safe. */
1.2436 +{
1.2437 + Tcl_Channel chan; /* Channel to remove from
1.2438 + * safe interpreter. */
1.2439 + Interp *iPtr = (Interp *) interp;
1.2440 +
1.2441 + TclHideUnsafeCommands(interp);
1.2442 +
1.2443 + iPtr->flags |= SAFE_INTERP;
1.2444 +
1.2445 + /*
1.2446 + * Unsetting variables : (which should not have been set
1.2447 + * in the first place, but...)
1.2448 + */
1.2449 +
1.2450 + /*
1.2451 + * No env array in a safe slave.
1.2452 + */
1.2453 +
1.2454 + Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
1.2455 +
1.2456 + /*
1.2457 + * Remove unsafe parts of tcl_platform
1.2458 + */
1.2459 +
1.2460 + Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
1.2461 + Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
1.2462 + Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
1.2463 + Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
1.2464 +
1.2465 + /*
1.2466 + * Unset path informations variables
1.2467 + * (the only one remaining is [info nameofexecutable])
1.2468 + */
1.2469 +
1.2470 + Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
1.2471 + Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
1.2472 + Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
1.2473 +
1.2474 + /*
1.2475 + * Remove the standard channels from the interpreter; safe interpreters
1.2476 + * do not ordinarily have access to stdin, stdout and stderr.
1.2477 + *
1.2478 + * NOTE: These channels are not added to the interpreter by the
1.2479 + * Tcl_CreateInterp call, but may be added later, by another I/O
1.2480 + * operation. We want to ensure that the interpreter does not have
1.2481 + * these channels even if it is being made safe after being used for
1.2482 + * some time..
1.2483 + */
1.2484 +
1.2485 + chan = Tcl_GetStdChannel(TCL_STDIN);
1.2486 + if (chan != (Tcl_Channel) NULL) {
1.2487 + Tcl_UnregisterChannel(interp, chan);
1.2488 + }
1.2489 + chan = Tcl_GetStdChannel(TCL_STDOUT);
1.2490 + if (chan != (Tcl_Channel) NULL) {
1.2491 + Tcl_UnregisterChannel(interp, chan);
1.2492 + }
1.2493 + chan = Tcl_GetStdChannel(TCL_STDERR);
1.2494 + if (chan != (Tcl_Channel) NULL) {
1.2495 + Tcl_UnregisterChannel(interp, chan);
1.2496 + }
1.2497 +
1.2498 + return TCL_OK;
1.2499 +}