OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclInterp.c] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclInterp.c --
3
 *
4
 *      This file implements the "interp" command which allows creation
5
 *      and manipulation of Tcl interpreters from within Tcl scripts.
6
 *
7
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
8
 *
9
 * See the file "license.terms" for information on usage and redistribution
10
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11
 *
12
 * RCS: @(#) $Id: tclInterp.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
13
 */
14
 
15
#include <stdio.h>
16
#include "tclInt.h"
17
#include "tclPort.h"
18
 
19
/*
20
 * Counter for how many aliases were created (global)
21
 */
22
 
23
static int aliasCounter = 0;
24
 
25
/*
26
 *
27
 * struct Slave:
28
 *
29
 * Used by the "interp" command to record and find information about slave
30
 * interpreters. Maps from a command name in the master to information about
31
 * a slave interpreter, e.g. what aliases are defined in it.
32
 */
33
 
34
typedef struct {
35
    Tcl_Interp *masterInterp;   /* Master interpreter for this slave. */
36
    Tcl_HashEntry *slaveEntry;  /* Hash entry in masters slave table for
37
                                 * this slave interpreter. Used to find
38
                                 * this record, and used when deleting the
39
                                 * slave interpreter to delete it from the
40
                                 * masters table. */
41
    Tcl_Interp  *slaveInterp;   /* The slave interpreter. */
42
    Tcl_Command interpCmd;      /* Interpreter object command. */
43
    Tcl_HashTable aliasTable;   /* Table which maps from names of commands
44
                                 * in slave interpreter to struct Alias
45
                                 * defined below. */
46
} Slave;
47
 
48
/*
49
 * struct Alias:
50
 *
51
 * Stores information about an alias. Is stored in the slave interpreter
52
 * and used by the source command to find the target command in the master
53
 * when the source command is invoked.
54
 */
55
 
56
typedef struct {
57
    char        *aliasName;     /* Name of alias command. */
58
    char        *targetName;    /* Name of target command in master interp. */
59
    Tcl_Interp  *targetInterp;  /* Master interpreter. */
60
    int         objc;           /* Count of additional args to pass. */
61
    Tcl_Obj     **objv;         /* Actual additional args to pass. */
62
    Tcl_HashEntry *aliasEntry;  /* Entry for the alias hash table in slave.
63
                                 * This is used by alias deletion to remove
64
                                 * the alias from the slave interpreter
65
                                 * alias table. */
66
    Tcl_HashEntry *targetEntry; /* Entry for target command in master.
67
                                 * This is used in the master interpreter to
68
                                 * map back from the target command to aliases
69
                                 * redirecting to it. Random access to this
70
                                 * hash table is never required - we are using
71
                                 * a hash table only for convenience. */
72
    Tcl_Command slaveCmd;       /* Source command in slave interpreter. */
73
} Alias;
74
 
75
/*
76
 * struct Target:
77
 *
78
 * Maps from master interpreter commands back to the source commands in slave
79
 * interpreters. This is needed because aliases can be created between sibling
80
 * interpreters and must be deleted when the target interpreter is deleted. In
81
 * case they would not be deleted the source interpreter would be left with a
82
 * "dangling pointer". One such record is stored in the Master record of the
83
 * master interpreter (in the targetTable hashtable, see below) with the
84
 * master for each alias which directs to a command in the master. These
85
 * records are used to remove the source command for an from a slave if/when
86
 * the master is deleted.
87
 */
88
 
89
typedef struct {
90
    Tcl_Command slaveCmd;       /* Command for alias in slave interp. */
91
    Tcl_Interp *slaveInterp;    /* Slave Interpreter. */
92
} Target;
93
 
94
/*
95
 * struct Master:
96
 *
97
 * This record is used for two purposes: First, slaveTable (a hashtable)
98
 * maps from names of commands to slave interpreters. This hashtable is
99
 * used to store information about slave interpreters of this interpreter,
100
 * to map over all slaves, etc. The second purpose is to store information
101
 * about all aliases in slaves (or siblings) which direct to target commands
102
 * in this interpreter (using the targetTable hashtable).
103
 *
104
 * NB: the flags field in the interp structure, used with SAFE_INTERP
105
 * mask denotes whether the interpreter is safe or not. Safe
106
 * interpreters have restricted functionality, can only create safe slave
107
 * interpreters and can only load safe extensions.
108
 */
109
 
110
typedef struct {
111
    Tcl_HashTable slaveTable;   /* Hash table for slave interpreters.
112
                                 * Maps from command names to Slave records. */
113
    Tcl_HashTable targetTable;  /* Hash table for Target Records. Contains
114
                                 * all Target records which denote aliases
115
                                 * from slaves or sibling interpreters that
116
                                 * direct to commands in this interpreter. This
117
                                 * table is used to remove dangling pointers
118
                                 * from the slave (or sibling) interpreters
119
                                 * when this interpreter is deleted. */
120
} Master;
121
 
122
/*
123
 * Prototypes for local static procedures:
124
 */
125
 
126
static int              AliasCmd _ANSI_ARGS_((ClientData dummy,
127
                            Tcl_Interp *currentInterp, int objc,
128
                            Tcl_Obj *CONST objv[]));
129
static void             AliasCmdDeleteProc _ANSI_ARGS_((
130
                            ClientData clientData));
131
static int              AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp,
132
                            Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
133
                            Master *masterPtr, char *aliasName,
134
                            char *targetName, int objc,
135
                            Tcl_Obj *CONST objv[]));
136
static int              CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
137
                            Master *masterPtr, int objc,
138
                            Tcl_Obj *CONST objv[]));
139
static Tcl_Interp       *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
140
                            Master *masterPtr, char *slavePath, int safe));
141
static int              DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp,
142
                            Tcl_Interp *slaveInterp, char *aliasName));
143
static int              DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp,
144
                            Tcl_Interp *slaveInterp, char *aliasName));
145
static int              DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
146
                            Master *masterPtr, int objc,
147
                            Tcl_Obj *CONST objv[]));
148
static int              DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
149
                            Master *masterPtr, char *path));
150
static Tcl_Interp       *GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
151
                            Master *masterPtr, char *path,
152
                            Master **masterPtrPtr));
153
static int              GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path,
154
                            char *aliasName));
155
static int              InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
156
                            Master *masterPtr, int objc,
157
                            Tcl_Obj *CONST objv[]));
158
static int              InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
159
                            Master *masterPtr, int objc,
160
                            Tcl_Obj *CONST objv[]));
161
static int              InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp,
162
                            Master *masterPtr, int objc,
163
                            Tcl_Obj *CONST objv[]));
164
static int              InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
165
                            Master *masterPtr, int objc,
166
                            Tcl_Obj *CONST objv[]));
167
static int              InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
168
                            Master *masterPtr, int objc,
169
                            Tcl_Obj *CONST objv[]));
170
static int              InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp,
171
                            Master *masterPtr, int objc,
172
                            Tcl_Obj *CONST objv[]));
173
static int              InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
174
                            Master *masterPtr, int objc,
175
                            Tcl_Obj *CONST objv[]));
176
static int              InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
177
                            Master *masterPtr, int objc,
178
                            Tcl_Obj *CONST objv[]));
179
static int              InterpInvokeHiddenHelper _ANSI_ARGS_((
180
                            Tcl_Interp *interp, Master *masterPtr, int objc,
181
                            Tcl_Obj *CONST objv[]));
182
static int              InterpMarkTrustedHelper _ANSI_ARGS_((
183
                            Tcl_Interp *interp, Master *masterPtr, int objc,
184
                            Tcl_Obj *CONST objv[]));
185
static int              InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp,
186
                            Master *masterPtr, int objc,
187
                            Tcl_Obj *CONST objv[]));
188
static int              InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp,
189
                            Master *masterPtr, int objc,
190
                            Tcl_Obj *CONST objv[]));
191
static int              InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp,
192
                            Master *masterPtr, int objc,
193
                            Tcl_Obj *CONST objv[]));
194
static int              InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp,
195
                            Master *masterPtr, int objc,
196
                            Tcl_Obj *CONST objv[]));
197
static int              MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp));
198
static void             MasterRecordDeleteProc _ANSI_ARGS_((
199
                            ClientData clientData, Tcl_Interp *interp));
200
static int              SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
201
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
202
                            int objc, Tcl_Obj *CONST objv[]));
203
static int              SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
204
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
205
                            int objc, Tcl_Obj *CONST objv[]));
206
static int              SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
207
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
208
                            int objc, Tcl_Obj *CONST objv[]));
209
static int              SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
210
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
211
                            int objc, Tcl_Obj *CONST objv[]));
212
static int              SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
213
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
214
                            int objc, Tcl_Obj *CONST objv[]));
215
static int              SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
216
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
217
                            int objc, Tcl_Obj *CONST objv[]));
218
static int              SlaveIsSafeHelper _ANSI_ARGS_((
219
                            Tcl_Interp *interp, Tcl_Interp *slaveInterp,
220
                            Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
221
static int              SlaveInvokeHiddenHelper _ANSI_ARGS_((
222
                            Tcl_Interp *interp, Tcl_Interp *slaveInterp,
223
                            Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
224
static int              SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp,
225
                            Tcl_Interp *slaveInterp, Slave *slavePtr,
226
                            int objc, Tcl_Obj *CONST objv[]));
227
static int              SlaveObjectCmd _ANSI_ARGS_((ClientData dummy,
228
                            Tcl_Interp *interp, int objc,
229
                            Tcl_Obj *CONST objv[]));
230
static void             SlaveObjectDeleteProc _ANSI_ARGS_((
231
                            ClientData clientData));
232
static void             SlaveRecordDeleteProc _ANSI_ARGS_((
233
                            ClientData clientData, Tcl_Interp *interp));
234
 
235
/*
236
 *----------------------------------------------------------------------
237
 *
238
 * TclPreventAliasLoop --
239
 *
240
 *      When defining an alias or renaming a command, prevent an alias
241
 *      loop from being formed.
242
 *
243
 * Results:
244
 *      A standard Tcl object result.
245
 *
246
 * Side effects:
247
 *      If TCL_ERROR is returned, the function also stores an error message
248
 *      in the interpreter's result object.
249
 *
250
 * NOTE:
251
 *      This function is public internal (instead of being static to
252
 *      this file) because it is also used from TclRenameCommand.
253
 *
254
 *----------------------------------------------------------------------
255
 */
256
 
257
int
258
TclPreventAliasLoop(interp, cmdInterp, cmd)
259
    Tcl_Interp *interp;                 /* Interp in which to report errors. */
260
    Tcl_Interp *cmdInterp;              /* Interp in which the command is
261
                                         * being defined. */
262
    Tcl_Command cmd;                    /* Tcl command we are attempting
263
                                         * to define. */
264
{
265
    Command *cmdPtr = (Command *) cmd;
266
    Alias *aliasPtr, *nextAliasPtr;
267
    Tcl_Command aliasCmd;
268
    Command *aliasCmdPtr;
269
 
270
    /*
271
     * If we are not creating or renaming an alias, then it is
272
     * always OK to create or rename the command.
273
     */
274
 
275
    if (cmdPtr->objProc != AliasCmd) {
276
        return TCL_OK;
277
    }
278
 
279
    /*
280
     * OK, we are dealing with an alias, so traverse the chain of aliases.
281
     * If we encounter the alias we are defining (or renaming to) any in
282
     * the chain then we have a loop.
283
     */
284
 
285
    aliasPtr = (Alias *) cmdPtr->objClientData;
286
    nextAliasPtr = aliasPtr;
287
    while (1) {
288
 
289
        /*
290
         * If the target of the next alias in the chain is the same as
291
         * the source alias, we have a loop.
292
         */
293
 
294
        aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
295
                nextAliasPtr->targetName,
296
                Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
297
                /*flags*/ 0);
298
        if (aliasCmd == (Tcl_Command) NULL) {
299
            return TCL_OK;
300
        }
301
        aliasCmdPtr = (Command *) aliasCmd;
302
        if (aliasCmdPtr == cmdPtr) {
303
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
304
                "cannot define or rename alias \"", aliasPtr->aliasName,
305
                "\": would create a loop", (char *) NULL);
306
            return TCL_ERROR;
307
        }
308
 
309
        /*
310
         * Otherwise, follow the chain one step further. See if the target
311
         * command is an alias - if so, follow the loop to its target
312
         * command. Otherwise we do not have a loop.
313
         */
314
 
315
        if (aliasCmdPtr->objProc != AliasCmd) {
316
            return TCL_OK;
317
        }
318
        nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
319
    }
320
 
321
    /* NOTREACHED */
322
}
323
 
324
/*
325
 *----------------------------------------------------------------------
326
 *
327
 * MarkTrusted --
328
 *
329
 *      Mark an interpreter as unsafe (i.e. remove the "safe" mark).
330
 *
331
 * Results:
332
 *      A standard Tcl result.
333
 *
334
 * Side effects:
335
 *      Removes the "safe" mark from an interpreter.
336
 *
337
 *----------------------------------------------------------------------
338
 */
339
 
340
static int
341
MarkTrusted(interp)
342
    Tcl_Interp *interp;         /* Interpreter to be marked unsafe. */
343
{
344
    Interp *iPtr = (Interp *) interp;
345
 
346
    iPtr->flags &= ~SAFE_INTERP;
347
    return TCL_OK;
348
}
349
 
350
/*
351
 *----------------------------------------------------------------------
352
 *
353
 * Tcl_MakeSafe --
354
 *
355
 *      Makes its argument interpreter contain only functionality that is
356
 *      defined to be part of Safe Tcl. Unsafe commands are hidden, the
357
 *      env array is unset, and the standard channels are removed.
358
 *
359
 * Results:
360
 *      None.
361
 *
362
 * Side effects:
363
 *      Hides commands in its argument interpreter, and removes settings
364
 *      and channels.
365
 *
366
 *----------------------------------------------------------------------
367
 */
368
 
369
int
370
Tcl_MakeSafe(interp)
371
    Tcl_Interp *interp;         /* Interpreter to be made safe. */
372
{
373
    Tcl_Channel chan;                           /* Channel to remove from
374
                                                 * safe interpreter. */
375
    Interp *iPtr = (Interp *) interp;
376
 
377
    TclHideUnsafeCommands(interp);
378
 
379
    iPtr->flags |= SAFE_INTERP;
380
 
381
    /*
382
     *  Unsetting variables : (which should not have been set
383
     *  in the first place, but...)
384
     */
385
 
386
    /*
387
     * No env array in a safe slave.
388
     */
389
 
390
    Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
391
 
392
    /*
393
     * Remove unsafe parts of tcl_platform
394
     */
395
 
396
    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
397
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
398
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
399
 
400
    /*
401
     * Unset path informations variables
402
     * (the only one remaining is [info nameofexecutable])
403
     */
404
 
405
    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
406
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
407
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
408
 
409
    /*
410
     * Remove the standard channels from the interpreter; safe interpreters
411
     * do not ordinarily have access to stdin, stdout and stderr.
412
     *
413
     * NOTE: These channels are not added to the interpreter by the
414
     * Tcl_CreateInterp call, but may be added later, by another I/O
415
     * operation. We want to ensure that the interpreter does not have
416
     * these channels even if it is being made safe after being used for
417
     * some time..
418
     */
419
 
420
    chan = Tcl_GetStdChannel(TCL_STDIN);
421
    if (chan != (Tcl_Channel) NULL) {
422
        Tcl_UnregisterChannel(interp, chan);
423
    }
424
    chan = Tcl_GetStdChannel(TCL_STDOUT);
425
    if (chan != (Tcl_Channel) NULL) {
426
        Tcl_UnregisterChannel(interp, chan);
427
    }
428
    chan = Tcl_GetStdChannel(TCL_STDERR);
429
    if (chan != (Tcl_Channel) NULL) {
430
        Tcl_UnregisterChannel(interp, chan);
431
    }
432
 
433
    return TCL_OK;
434
}
435
 
436
/*
437
 *----------------------------------------------------------------------
438
 *
439
 * GetInterp --
440
 *
441
 *      Helper function to find a slave interpreter given a pathname.
442
 *
443
 * Results:
444
 *      Returns the slave interpreter known by that name in the calling
445
 *      interpreter, or NULL if no interpreter known by that name exists.
446
 *
447
 * Side effects:
448
 *      Assigns to the pointer variable passed in, if not NULL.
449
 *
450
 *----------------------------------------------------------------------
451
 */
452
 
453
static Tcl_Interp *
454
GetInterp(interp, masterPtr, path, masterPtrPtr)
455
    Tcl_Interp *interp;         /* Interp. to start search from. */
456
    Master *masterPtr;          /* Its master record. */
457
    char *path;                 /* The path (name) of interp. to be found. */
458
    Master **masterPtrPtr;      /* (Return) its master record. */
459
{
460
    Tcl_HashEntry *hPtr;        /* Search element. */
461
    Slave *slavePtr;            /* Interim slave record. */
462
    char **argv;                /* Split-up path (name) for interp to find. */
463
    int argc, i;                /* Loop indices. */
464
    Tcl_Interp *searchInterp;   /* Interim storage for interp. to find. */
465
 
466
    if (masterPtrPtr != (Master **) NULL) {
467
        *masterPtrPtr = masterPtr;
468
    }
469
 
470
    if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) {
471
        return (Tcl_Interp *) NULL;
472
    }
473
 
474
    for (searchInterp = interp, i = 0; i < argc; i++) {
475
 
476
        hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]);
477
        if (hPtr == (Tcl_HashEntry *) NULL) {
478
            ckfree((char *) argv);
479
            return (Tcl_Interp *) NULL;
480
        }
481
        slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
482
        searchInterp = slavePtr->slaveInterp;
483
        if (searchInterp == (Tcl_Interp *) NULL) {
484
            ckfree((char *) argv);
485
            return (Tcl_Interp *) NULL;
486
        }
487
        masterPtr = (Master *) Tcl_GetAssocData(searchInterp,
488
                "tclMasterRecord", NULL);
489
        if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr;
490
        if (masterPtr == (Master *) NULL) {
491
            ckfree((char *) argv);
492
            return (Tcl_Interp *) NULL;
493
        }
494
    }
495
    ckfree((char *) argv);
496
    return searchInterp;
497
}
498
 
499
/*
500
 *----------------------------------------------------------------------
501
 *
502
 * CreateSlave --
503
 *
504
 *      Helper function to do the actual work of creating a slave interp
505
 *      and new object command. Also optionally makes the new slave
506
 *      interpreter "safe".
507
 *
508
 * Results:
509
 *      Returns the new Tcl_Interp * if successful or NULL if not. If failed,
510
 *      the result of the invoking interpreter contains an error message.
511
 *
512
 * Side effects:
513
 *      Creates a new slave interpreter and a new object command.
514
 *
515
 *----------------------------------------------------------------------
516
 */
517
 
518
static Tcl_Interp *
519
CreateSlave(interp, masterPtr, slavePath, safe)
520
    Tcl_Interp *interp;                 /* Interp. to start search from. */
521
    Master *masterPtr;                  /* Master record. */
522
    char *slavePath;                    /* Path (name) of slave to create. */
523
    int safe;                           /* Should we make it "safe"? */
524
{
525
    Tcl_Interp *slaveInterp;            /* Ptr to slave interpreter. */
526
    Tcl_Interp *masterInterp;           /* Ptr to master interp for slave. */
527
    Slave *slavePtr;                    /* Slave record. */
528
    Tcl_HashEntry *hPtr;                /* Entry into interp hashtable. */
529
    int new;                            /* Indicates whether new entry. */
530
    int argc;                           /* Count of elements in slavePath. */
531
    char **argv;                        /* Elements in slavePath. */
532
    char *masterPath;                   /* Path to its master. */
533
 
534
    if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) {
535
        return (Tcl_Interp *) NULL;
536
    }
537
 
538
    if (argc < 2) {
539
        masterInterp = interp;
540
        if (argc == 1) {
541
            slavePath = argv[0];
542
        }
543
    } else {
544
        masterPath = Tcl_Merge(argc-1, argv);
545
        masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
546
        if (masterInterp == (Tcl_Interp *) NULL) {
547
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
548
                    "interpreter named \"", masterPath,
549
                    "\" not found", (char *) NULL);
550
            ckfree((char *) argv);
551
            ckfree((char *) masterPath);
552
            return (Tcl_Interp *) NULL;
553
        }
554
        ckfree((char *) masterPath);
555
        slavePath = argv[argc-1];
556
        if (!safe) {
557
            safe = Tcl_IsSafe(masterInterp);
558
        }
559
    }
560
    hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
561
    if (new == 0) {
562
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
563
                "interpreter named \"", slavePath,
564
                "\" already exists, cannot create", (char *) NULL);
565
        ckfree((char *) argv);
566
        return (Tcl_Interp *) NULL;
567
    }
568
    slaveInterp = Tcl_CreateInterp();
569
    if (slaveInterp == (Tcl_Interp *) NULL) {
570
        panic("CreateSlave: out of memory while creating a new interpreter");
571
    }
572
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
573
    slavePtr->masterInterp = masterInterp;
574
    slavePtr->slaveEntry = hPtr;
575
    slavePtr->slaveInterp = slaveInterp;
576
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath,
577
            SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc);
578
    Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
579
    (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
580
            SlaveRecordDeleteProc, (ClientData) slavePtr);
581
    Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
582
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
583
 
584
    /*
585
     * Inherit the recursion limit.
586
     */
587
    ((Interp *)slaveInterp)->maxNestingDepth =
588
        ((Interp *)masterInterp)->maxNestingDepth ;
589
 
590
    if (safe) {
591
        if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
592
            goto error;
593
        }
594
    } else {
595
        if (Tcl_Init(slaveInterp) == TCL_ERROR) {
596
            goto error;
597
        }
598
    }
599
 
600
    ckfree((char *) argv);
601
    return slaveInterp;
602
 
603
error:
604
 
605
    Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *)
606
            NULL, TCL_GLOBAL_ONLY));
607
    Tcl_SetVar2(interp, "errorCode", (char *) NULL,
608
            Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL,
609
                    TCL_GLOBAL_ONLY),
610
            TCL_GLOBAL_ONLY);
611
 
612
    Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
613
    Tcl_ResetResult(slaveInterp);
614
 
615
    (void) Tcl_DeleteCommand(masterInterp, slavePath);
616
 
617
    ckfree((char *) argv);
618
    return (Tcl_Interp *) NULL;
619
}
620
 
621
/*
622
 *----------------------------------------------------------------------
623
 *
624
 * CreateInterpObject -
625
 *
626
 *      Helper function to do the actual work of creating a new interpreter
627
 *      and an object command.
628
 *
629
 * Results:
630
 *      A Tcl result.
631
 *
632
 * Side effects:
633
 *      See user documentation for details.
634
 *
635
 *----------------------------------------------------------------------
636
 */
637
 
638
static int
639
CreateInterpObject(interp, masterPtr, objc, objv)
640
    Tcl_Interp *interp;                 /* Invoking interpreter. */
641
    Master *masterPtr;                  /* Master record for same. */
642
    int objc;                           /* Number of arguments. */
643
    Tcl_Obj *CONST objv[];              /* with alias. */
644
{
645
    int safe;                           /* Create a safe interpreter? */
646
    int moreFlags;                      /* Expecting more flag args? */
647
    char *string;                       /* Local pointer to object string. */
648
    char *slavePath;                    /* Name of slave. */
649
    char localSlaveName[200];           /* Local area for creating names. */
650
    int i;                              /* Loop counter. */
651
    int len;                            /* Length of option argument. */
652
    static int interpCounter = 0;        /* Unique id for created names. */
653
 
654
    moreFlags = 1;
655
    slavePath = NULL;
656
    safe = Tcl_IsSafe(interp);
657
 
658
    if ((objc < 2) || (objc > 5)) {
659
        Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
660
        return TCL_ERROR;
661
    }
662
    for (i = 2; i < objc; i++) {
663
        string = Tcl_GetStringFromObj(objv[i], &len);
664
        if ((string[0] == '-') && (moreFlags != 0)) {
665
            if ((string[1] == 's') &&
666
                (strncmp(string, "-safe", (size_t) len) == 0) &&
667
                (len > 1)){
668
                safe = 1;
669
            } else if ((strncmp(string, "--", (size_t) len) == 0) &&
670
                       (len > 1)) {
671
                moreFlags = 0;
672
            } else {
673
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
674
                        "bad option \"", string, "\": should be -safe",
675
                        (char *) NULL);
676
                return TCL_ERROR;
677
            }
678
        } else {
679
            slavePath = string;
680
        }
681
    }
682
    if (slavePath == (char *) NULL) {
683
 
684
        /*
685
         * Create an anonymous interpreter -- we choose its name and
686
         * the name of the command. We check that the command name that
687
         * we use for the interpreter does not collide with an existing
688
         * command in the master interpreter.
689
         */
690
 
691
        while (1) {
692
            Tcl_CmdInfo cmdInfo;
693
 
694
            sprintf(localSlaveName, "interp%d", interpCounter);
695
            interpCounter++;
696
            if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
697
                break;
698
            }
699
        }
700
        slavePath = localSlaveName;
701
    }
702
    if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
703
        Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1));
704
        return TCL_OK;
705
    } else {
706
        /*
707
         * CreateSlave already set the result if there was an error,
708
         * so we do not do it here.
709
         */
710
        return TCL_ERROR;
711
    }
712
}
713
 
714
/*
715
 *----------------------------------------------------------------------
716
 *
717
 * DeleteOneInterpObject --
718
 *
719
 *      Helper function for DeleteInterpObject. It deals with deleting one
720
 *      interpreter at a time.
721
 *
722
 * Results:
723
 *      A standard Tcl result.
724
 *
725
 * Side effects:
726
 *      Deletes an interpreter and its interpreter object command.
727
 *
728
 *----------------------------------------------------------------------
729
 */
730
 
731
static int
732
DeleteOneInterpObject(interp, masterPtr, path)
733
    Tcl_Interp *interp;                 /* Interpreter for reporting errors. */
734
    Master *masterPtr;                  /* Interim storage for master record.*/
735
    char *path;                         /* Path of interpreter to delete. */
736
{
737
    Slave *slavePtr;                    /* Interim storage for slave record. */
738
    Tcl_Interp *masterInterp;           /* Master of interp. to delete. */
739
    Tcl_HashEntry *hPtr;                /* Search element. */
740
    int localArgc;                      /* Local copy of count of elements in
741
                                         * path (name) of interp. to delete. */
742
    char **localArgv;                   /* Local copy of path. */
743
    char *slaveName;                    /* Last component in path. */
744
    char *masterPath;                   /* One-before-last component in path.*/
745
 
746
    if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) {
747
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
748
                "bad interpreter path \"", path, "\"", (char *) NULL);
749
        return TCL_ERROR;
750
    }
751
    if (localArgc < 2) {
752
        masterInterp = interp;
753
        if (localArgc == 0) {
754
            slaveName = "";
755
        } else {
756
            slaveName = localArgv[0];
757
        }
758
    } else {
759
        masterPath = Tcl_Merge(localArgc-1, localArgv);
760
        masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
761
        if (masterInterp == (Tcl_Interp *) NULL) {
762
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
763
                    "interpreter named \"", masterPath, "\" not found",
764
                    (char *) NULL);
765
            ckfree((char *) localArgv);
766
            ckfree((char *) masterPath);
767
            return TCL_ERROR;
768
        }
769
        ckfree((char *) masterPath);
770
        slaveName = localArgv[localArgc-1];
771
    }
772
    hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName);
773
    if (hPtr == (Tcl_HashEntry *) NULL) {
774
        ckfree((char *) localArgv);
775
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
776
                "interpreter named \"", path, "\" not found", (char *) NULL);
777
        return TCL_ERROR;
778
    }
779
    slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
780
    if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) {
781
        ckfree((char *) localArgv);
782
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
783
                "interpreter named \"", path, "\" not found", (char *) NULL);
784
        return TCL_ERROR;
785
    }
786
    ckfree((char *) localArgv);
787
 
788
    return TCL_OK;
789
}
790
 
791
/*
792
 *----------------------------------------------------------------------
793
 *
794
 * DeleteInterpObject --
795
 *
796
 *      Helper function to do the work of deleting zero or more
797
 *      interpreters and their interpreter object commands.
798
 *
799
 * Results:
800
 *      A standard Tcl result.
801
 *
802
 * Side effects:
803
 *      Deletes interpreters and their interpreter object command.
804
 *
805
 *----------------------------------------------------------------------
806
 */
807
 
808
static int
809
DeleteInterpObject(interp, masterPtr, objc, objv)
810
    Tcl_Interp *interp;                 /* Interpreter start search from. */
811
    Master *masterPtr;                  /* Interim storage for master record.*/
812
    int objc;                           /* Number of arguments in vector. */
813
    Tcl_Obj *CONST objv[];              /* with alias. */
814
{
815
    int i;
816
    int len;
817
 
818
    for (i = 2; i < objc; i++) {
819
        if (DeleteOneInterpObject(interp, masterPtr,
820
                Tcl_GetStringFromObj(objv[i], &len))
821
                != TCL_OK) {
822
            return TCL_ERROR;
823
        }
824
    }
825
    return TCL_OK;
826
}
827
 
828
/*
829
 *----------------------------------------------------------------------
830
 *
831
 * AliasCreationHelper --
832
 *
833
 *      Helper function to do the work to actually create an alias or
834
 *      delete an alias.
835
 *
836
 * Results:
837
 *      A standard Tcl result.
838
 *
839
 * Side effects:
840
 *      An alias command is created and entered into the alias table
841
 *      for the slave interpreter.
842
 *
843
 *----------------------------------------------------------------------
844
 */
845
 
846
static int
847
AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
848
     aliasName, targetName, objc, objv)
849
    Tcl_Interp *curInterp;              /* Interp that invoked this proc. */
850
    Tcl_Interp *slaveInterp;            /* Interp where alias cmd will live
851
                                         * or from which alias will be
852
                                         * deleted. */
853
    Tcl_Interp *masterInterp;           /* Interp where target cmd will be. */
854
    Master *masterPtr;                  /* Master record for target interp. */
855
    char *aliasName;                    /* Name of alias cmd. */
856
    char *targetName;                   /* Name of target cmd. */
857
    int objc;                           /* Additional arguments to store */
858
    Tcl_Obj *CONST objv[];              /* with alias. */
859
{
860
    Alias *aliasPtr;                    /* Storage for alias data. */
861
    Alias *tmpAliasPtr;                 /* Temp storage for alias to delete. */
862
    Tcl_HashEntry *hPtr;                /* Entry into interp hashtable. */
863
    int i;                              /* Loop index. */
864
    int new;                            /* Is it a new hash entry? */
865
    Target *targetPtr;                  /* Maps from target command in master
866
                                         * to source command in slave. */
867
    Slave *slavePtr;                    /* Maps from source command in slave
868
                                         * to target command in master. */
869
 
870
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
871
 
872
    /*
873
     * Slave record should be always present because it is created when
874
     * the interpreter is created.
875
     */
876
 
877
    if (slavePtr == (Slave *) NULL) {
878
        panic("AliasCreationHelper: could not find slave record");
879
    }
880
 
881
    if ((targetName == (char *) NULL) || (targetName[0] == '\0')) {
882
        if (objc != 0) {
883
            Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp),
884
                    "malformed command: should be",
885
                    " \"alias ",  aliasName, " {}\"", (char *) NULL);
886
            return TCL_ERROR;
887
        }
888
 
889
        return DeleteAlias(curInterp, slaveInterp, aliasName);
890
    }
891
 
892
    aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
893
    aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1);
894
    aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1);
895
    strcpy(aliasPtr->aliasName, aliasName);
896
    strcpy(aliasPtr->targetName, targetName);
897
    aliasPtr->targetInterp = masterInterp;
898
 
899
    aliasPtr->objv = NULL;
900
    aliasPtr->objc = objc;
901
 
902
    if (aliasPtr->objc > 0) {
903
        aliasPtr->objv =
904
            (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) *
905
                    aliasPtr->objc);
906
        for (i = 0; i < objc; i++) {
907
            aliasPtr->objv[i] = objv[i];
908
            Tcl_IncrRefCount(objv[i]);
909
        }
910
    }
911
 
912
    aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName,
913
            AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc);
914
 
915
    if (TclPreventAliasLoop(curInterp, slaveInterp,
916
            aliasPtr->slaveCmd) != TCL_OK) {
917
 
918
        /*
919
         *  Found an alias loop!  The last call to Tcl_CreateObjCommand
920
         *  made the alias point to itself.  Delete the command and
921
         *  its alias record.  Be careful to wipe out its client data
922
         *  first, so the command doesn't try to delete itself.
923
         */
924
 
925
        Command *cmdPtr = (Command*) aliasPtr->slaveCmd;
926
        cmdPtr->clientData = NULL;
927
        cmdPtr->deleteProc = NULL;
928
        cmdPtr->deleteData = NULL;
929
        Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
930
 
931
        for (i = 0; i < objc; i++) {
932
            Tcl_DecrRefCount(aliasPtr->objv[i]);
933
        }
934
        if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) {
935
            ckfree((char *) aliasPtr->objv);
936
        }
937
        ckfree(aliasPtr->aliasName);
938
        ckfree(aliasPtr->targetName);
939
        ckfree((char *) aliasPtr);
940
 
941
        /*
942
         * The result was already set by TclPreventAliasLoop.
943
         */
944
 
945
        return TCL_ERROR;
946
    }
947
 
948
    /*
949
     * Make an entry in the alias table. If it already exists delete
950
     * the alias command. Then retry.
951
     */
952
 
953
    do {
954
        hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new);
955
        if (!new) {
956
            tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
957
            (void) Tcl_DeleteCommandFromToken(slaveInterp,
958
                    tmpAliasPtr->slaveCmd);
959
 
960
            /*
961
             * The hash entry should be deleted by the Tcl_DeleteCommand
962
             * above, in its command deletion callback (most likely this
963
             * will be AliasCmdDeleteProc, which does the deletion).
964
             */
965
        }
966
    } while (new == 0);
967
    aliasPtr->aliasEntry = hPtr;
968
    Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
969
 
970
    /*
971
     * Create the new command. We must do it after deleting any old command,
972
     * because the alias may be pointing at a renamed alias, as in:
973
     *
974
     * interp alias {} foo {} bar               # Create an alias "foo"
975
     * rename foo zop                           # Now rename the alias
976
     * interp alias {} foo {} zop               # Now recreate "foo"...
977
     */
978
 
979
    targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
980
    targetPtr->slaveCmd = aliasPtr->slaveCmd;
981
    targetPtr->slaveInterp = slaveInterp;
982
 
983
    do {
984
        hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable),
985
                (char *) aliasCounter, &new);
986
        aliasCounter++;
987
    } while (new == 0);
988
 
989
    Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
990
 
991
    aliasPtr->targetEntry = hPtr;
992
 
993
    /*
994
     * Make sure we clear out the object result when setting the string
995
     * result.
996
     */
997
 
998
    Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1));
999
 
1000
    return TCL_OK;
1001
}
1002
 
1003
/*
1004
 *----------------------------------------------------------------------
1005
 *
1006
 * InterpAliasesHelper --
1007
 *
1008
 *      Computes a list of aliases defined in an interpreter.
1009
 *
1010
 * Results:
1011
 *      A standard Tcl result.
1012
 *
1013
 * Side effects:
1014
 *      None.
1015
 *
1016
 *----------------------------------------------------------------------
1017
 */
1018
 
1019
static int
1020
InterpAliasesHelper(interp, masterPtr, objc, objv)
1021
    Tcl_Interp *interp;                 /* Invoking interpreter. */
1022
    Master *masterPtr;                  /* Master record for current interp. */
1023
    int objc;                           /* How many arguments? */
1024
    Tcl_Obj *CONST objv[];              /* Actual arguments. */
1025
{
1026
    Tcl_Interp *slaveInterp;            /* A slave. */
1027
    Slave *slavePtr;                    /* Record for slave interp. */
1028
    Tcl_HashEntry *hPtr;                /* Search variable. */
1029
    Tcl_HashSearch hSearch;             /* Iteration variable. */
1030
    int len;                            /* Dummy length variable. */
1031
    Tcl_Obj *listObjPtr, *elemObjPtr;   /* Local object pointers. */
1032
 
1033
    if ((objc != 2) && (objc != 3)) {
1034
        Tcl_WrongNumArgs(interp, 2, objv, "?path?");
1035
        return TCL_ERROR;
1036
    }
1037
    if (objc == 3) {
1038
        slaveInterp = GetInterp(interp, masterPtr,
1039
                Tcl_GetStringFromObj(objv[2], &len), NULL);
1040
        if (slaveInterp == (Tcl_Interp *) NULL) {
1041
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1042
                    "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1043
                    "\" not found", (char *) NULL);
1044
            return TCL_ERROR;
1045
        }
1046
    } else {
1047
        slaveInterp = interp;
1048
    }
1049
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
1050
            "tclSlaveRecord", NULL);
1051
    if (slavePtr == (Slave *) NULL) {
1052
        return TCL_OK;
1053
    }
1054
 
1055
    /*
1056
     * Build a list to return the aliases:
1057
     */
1058
 
1059
    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1060
    for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch);
1061
         hPtr != NULL;
1062
         hPtr = Tcl_NextHashEntry(&hSearch)) {
1063
 
1064
        elemObjPtr = Tcl_NewStringObj(
1065
            Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1);
1066
        Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr);
1067
    }
1068
    Tcl_SetObjResult(interp, listObjPtr);
1069
 
1070
    return TCL_OK;
1071
}
1072
 
1073
/*
1074
 *----------------------------------------------------------------------
1075
 *
1076
 * InterpAliasHelper -
1077
 *
1078
 *      Handles the different forms of the "interp alias" command:
1079
 *      - interp alias slavePath aliasName
1080
 *              Describes an alias.
1081
 *      - interp alias slavePath aliasName {}
1082
 *              Deletes an alias.
1083
 *      - interp alias slavePath srcCmd masterPath targetCmd args...
1084
 *              Creates an alias.
1085
 *
1086
 * Results:
1087
 *      A Tcl result.
1088
 *
1089
 * Side effects:
1090
 *      See user documentation for details.
1091
 *
1092
 *----------------------------------------------------------------------
1093
 */
1094
 
1095
static int
1096
InterpAliasHelper(interp, masterPtr, objc, objv)
1097
    Tcl_Interp *interp;                 /* Current interpreter. */
1098
    Master *masterPtr;                  /* Master record for current interp. */
1099
    int objc;                           /* Number of arguments. */
1100
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1101
{
1102
    Tcl_Interp *slaveInterp,            /* Interpreters used when */
1103
        *masterInterp;                  /* creating an alias btn siblings. */
1104
    Master *masterMasterPtr;            /* Master record for master interp. */
1105
    int len;
1106
 
1107
    if (objc < 4) {
1108
        Tcl_WrongNumArgs(interp, 2, objv,
1109
                "slavePath slaveCmd masterPath masterCmd ?args ..?");
1110
        return TCL_ERROR;
1111
    }
1112
    slaveInterp = GetInterp(interp, masterPtr,
1113
            Tcl_GetStringFromObj(objv[2], &len), NULL);
1114
    if (slaveInterp == (Tcl_Interp *) NULL) {
1115
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1116
                "could not find interpreter \"",
1117
                Tcl_GetStringFromObj(objv[2], &len), "\"",
1118
                (char *) NULL);
1119
        return TCL_ERROR;
1120
    }
1121
    if (objc == 4) {
1122
        return DescribeAlias(interp, slaveInterp,
1123
                Tcl_GetStringFromObj(objv[3], &len));
1124
    }
1125
    if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) {
1126
        return DeleteAlias(interp, slaveInterp,
1127
                Tcl_GetStringFromObj(objv[3], &len));
1128
    }
1129
    if (objc < 6) {
1130
        Tcl_WrongNumArgs(interp, 2, objv,
1131
                "slavePath slaveCmd masterPath masterCmd ?args ..?");
1132
        return TCL_ERROR;
1133
    }
1134
    masterInterp = GetInterp(interp, masterPtr,
1135
            Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr);
1136
    if (masterInterp == (Tcl_Interp *) NULL) {
1137
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1138
                "could not find interpreter \"",
1139
                Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL);
1140
        return TCL_ERROR;
1141
    }
1142
    return AliasCreationHelper(interp, slaveInterp, masterInterp,
1143
            masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len),
1144
            Tcl_GetStringFromObj(objv[5], &len),
1145
            objc-6, objv+6);
1146
}
1147
 
1148
/*
1149
 *----------------------------------------------------------------------
1150
 *
1151
 * InterpExistsHelper --
1152
 *
1153
 *      Computes whether a named interpreter exists or not.
1154
 *
1155
 * Results:
1156
 *      A standard Tcl result.
1157
 *
1158
 * Side effects:
1159
 *      None.
1160
 *
1161
 *----------------------------------------------------------------------
1162
 */
1163
 
1164
static int
1165
InterpExistsHelper(interp, masterPtr, objc, objv)
1166
    Tcl_Interp *interp;                 /* Current interpreter. */
1167
    Master *masterPtr;                  /* Master record for current interp. */
1168
    int objc;                           /* Number of arguments. */
1169
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1170
{
1171
    Tcl_Obj *objPtr;
1172
    int len;
1173
 
1174
    if (objc > 3) {
1175
        Tcl_WrongNumArgs(interp, 2, objv, "?path?");
1176
        return TCL_ERROR;
1177
    }
1178
    if (objc == 3) {
1179
        if (GetInterp(interp, masterPtr,
1180
                Tcl_GetStringFromObj(objv[2], &len), NULL) ==
1181
                (Tcl_Interp *) NULL) {
1182
            objPtr = Tcl_NewIntObj(0);
1183
        } else {
1184
            objPtr = Tcl_NewIntObj(1);
1185
        }
1186
    } else {
1187
        objPtr = Tcl_NewIntObj(1);
1188
    }
1189
    Tcl_SetObjResult(interp, objPtr);
1190
 
1191
    return TCL_OK;
1192
}
1193
 
1194
/*
1195
 *----------------------------------------------------------------------
1196
 *
1197
 * InterpEvalHelper --
1198
 *
1199
 *      Helper function to handle all the details of evaluating a
1200
 *      command in another interpreter.
1201
 *
1202
 * Results:
1203
 *      A standard Tcl result.
1204
 *
1205
 * Side effects:
1206
 *      Whatever the command itself does.
1207
 *
1208
 *----------------------------------------------------------------------
1209
 */
1210
 
1211
static int
1212
InterpEvalHelper(interp, masterPtr, objc, objv)
1213
    Tcl_Interp *interp;                 /* Current interpreter. */
1214
    Master *masterPtr;                  /* Master record for current interp. */
1215
    int objc;                           /* Number of arguments. */
1216
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1217
{
1218
    Tcl_Interp *slaveInterp;            /* A slave. */
1219
    Interp *iPtr;                       /* Internal data type for slave. */
1220
    int len;                            /* Dummy length variable. */
1221
    int result;
1222
    Tcl_Obj *namePtr, *objPtr;          /* Local object pointer. */
1223
    char *string;
1224
 
1225
    if (objc < 4) {
1226
        Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
1227
        return TCL_ERROR;
1228
    }
1229
    slaveInterp = GetInterp(interp, masterPtr,
1230
            Tcl_GetStringFromObj(objv[2], &len), NULL);
1231
    if (slaveInterp == (Tcl_Interp *) NULL) {
1232
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1233
                "interpreter named \"", Tcl_GetStringFromObj(objv[2], &len),
1234
                "\" not found", (char *) NULL);
1235
        return TCL_ERROR;
1236
    }
1237
    objPtr = Tcl_ConcatObj(objc-3, objv+3);
1238
    Tcl_IncrRefCount(objPtr);
1239
 
1240
    Tcl_Preserve((ClientData) slaveInterp);
1241
    result = Tcl_EvalObj(slaveInterp, objPtr);
1242
 
1243
    Tcl_DecrRefCount(objPtr);
1244
 
1245
    /*
1246
     * Now make the result and any error information accessible. We
1247
     * have to be careful because the slave interpreter and the current
1248
     * interpreter can be the same - do not destroy the result.. This
1249
     * can happen if an interpreter contains an alias which is directed
1250
     * at a target command in the same interpreter.
1251
     */
1252
 
1253
    if (interp != slaveInterp) {
1254
        if (result == TCL_ERROR) {
1255
 
1256
            /*
1257
             * An error occurred, so transfer error information from
1258
             * the target interpreter back to our interpreter.
1259
             */
1260
 
1261
            iPtr = (Interp *) slaveInterp;
1262
            if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
1263
                Tcl_AddErrorInfo(slaveInterp, "");
1264
            }
1265
            iPtr->flags &= (~(ERR_ALREADY_LOGGED));
1266
 
1267
            Tcl_ResetResult(interp);
1268
            namePtr = Tcl_NewStringObj("errorInfo", -1);
1269
            objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
1270
                    (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
1271
            string = Tcl_GetStringFromObj(objPtr, &len);
1272
            Tcl_AddObjErrorInfo(interp, string, len);
1273
            Tcl_SetVar2(interp, "errorCode", (char *) NULL,
1274
                    Tcl_GetVar2(slaveInterp, "errorCode", (char *)
1275
                            NULL, TCL_GLOBAL_ONLY),
1276
                    TCL_GLOBAL_ONLY);
1277
            Tcl_DecrRefCount(namePtr);
1278
        }
1279
 
1280
        /*
1281
         * Move the result object from one interpreter to the
1282
         * other.
1283
         */
1284
 
1285
        Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
1286
        Tcl_ResetResult(slaveInterp);
1287
 
1288
    }
1289
    Tcl_Release((ClientData) slaveInterp);
1290
    return result;
1291
}
1292
 
1293
/*
1294
 *----------------------------------------------------------------------
1295
 *
1296
 * InterpExposeHelper --
1297
 *
1298
 *      Helper function to handle the details of exposing a command in
1299
 *      another interpreter.
1300
 *
1301
 * Results:
1302
 *      Standard Tcl result.
1303
 *
1304
 * Side effects:
1305
 *      Exposes a command. From now on the command can be called by scripts
1306
 *      in the interpreter in which it was exposed.
1307
 *
1308
 *----------------------------------------------------------------------
1309
 */
1310
 
1311
static int
1312
InterpExposeHelper(interp, masterPtr, objc, objv)
1313
    Tcl_Interp *interp;                 /* Current interpreter. */
1314
    Master *masterPtr;                  /* Master record for current interp. */
1315
    int objc;                           /* Number of arguments. */
1316
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1317
{
1318
    Tcl_Interp *slaveInterp;            /* A slave. */
1319
    int len;                            /* Dummy length variable. */
1320
 
1321
    if ((objc != 4) && (objc != 5)) {
1322
        Tcl_WrongNumArgs(interp, 2, objv,
1323
                "path hiddenCmdName ?cmdName?");
1324
        return TCL_ERROR;
1325
    }
1326
    if (Tcl_IsSafe(interp)) {
1327
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1328
                "permission denied: safe interpreter cannot expose commands",
1329
                (char *) NULL);
1330
        return TCL_ERROR;
1331
    }
1332
    slaveInterp = GetInterp(interp, masterPtr,
1333
            Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
1334
    if (slaveInterp == (Tcl_Interp *) NULL) {
1335
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1336
                "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1337
                "\" not found", (char *) NULL);
1338
        return TCL_ERROR;
1339
    }
1340
    if (Tcl_ExposeCommand(slaveInterp,
1341
            Tcl_GetStringFromObj(objv[3], &len),
1342
                (objc == 5 ?
1343
                        Tcl_GetStringFromObj(objv[4], &len) :
1344
                        Tcl_GetStringFromObj(objv[3], &len)))
1345
            == TCL_ERROR) {
1346
        if (interp != slaveInterp) {
1347
            Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
1348
            Tcl_ResetResult(slaveInterp);
1349
        }
1350
        return TCL_ERROR;
1351
    }
1352
    return TCL_OK;
1353
}
1354
 
1355
/*
1356
 *----------------------------------------------------------------------
1357
 *
1358
 * InterpHideHelper --
1359
 *
1360
 *      Helper function that handles the details of hiding a command in
1361
 *      another interpreter.
1362
 *
1363
 * Results:
1364
 *      A standard Tcl result.
1365
 *
1366
 * Side effects:
1367
 *      Hides a command. From now on the command cannot be called by
1368
 *      scripts in that interpreter.
1369
 *
1370
 *----------------------------------------------------------------------
1371
 */
1372
 
1373
static int
1374
InterpHideHelper(interp, masterPtr, objc, objv)
1375
    Tcl_Interp *interp;                 /* Current interpreter. */
1376
    Master *masterPtr;                  /* Master record for interp. */
1377
    int objc;                           /* Number of arguments. */
1378
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1379
{
1380
    Tcl_Interp *slaveInterp;            /* A slave. */
1381
    int len;                            /* Dummy length variable. */
1382
 
1383
    if ((objc != 4) && (objc != 5)) {
1384
        Tcl_WrongNumArgs(interp, 2, objv,
1385
                "path cmdName ?hiddenCmdName?");
1386
        return TCL_ERROR;
1387
    }
1388
    if (Tcl_IsSafe(interp)) {
1389
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1390
                "permission denied: safe interpreter cannot hide commands",
1391
                (char *) NULL);
1392
        return TCL_ERROR;
1393
    }
1394
    slaveInterp = GetInterp(interp, masterPtr,
1395
            Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
1396
    if (slaveInterp == (Tcl_Interp *) NULL) {
1397
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1398
                "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1399
                "\" not found", (char *) NULL);
1400
        return TCL_ERROR;
1401
    }
1402
    if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len),
1403
            (objc == 5 ?
1404
                    Tcl_GetStringFromObj(objv[4], &len) :
1405
                    Tcl_GetStringFromObj(objv[3], &len)))
1406
            == TCL_ERROR) {
1407
        if (interp != slaveInterp) {
1408
            Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
1409
            Tcl_ResetResult(slaveInterp);
1410
        }
1411
        return TCL_ERROR;
1412
    }
1413
    return TCL_OK;
1414
}
1415
 
1416
/*
1417
 *----------------------------------------------------------------------
1418
 *
1419
 * InterpHiddenHelper --
1420
 *
1421
 *      Computes the list of hidden commands in a named interpreter.
1422
 *
1423
 * Results:
1424
 *      A standard Tcl result.
1425
 *
1426
 * Side effects:
1427
 *      None.
1428
 *
1429
 *----------------------------------------------------------------------
1430
 */
1431
 
1432
static int
1433
InterpHiddenHelper(interp, masterPtr, objc, objv)
1434
    Tcl_Interp *interp;                 /* Current interpreter. */
1435
    Master *masterPtr;                  /* Master record for interp. */
1436
    int objc;                           /* Number of arguments. */
1437
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1438
{
1439
    Tcl_Interp *slaveInterp;            /* A slave. */
1440
    int len;
1441
    Tcl_HashTable *hTblPtr;             /* Hidden command table. */
1442
    Tcl_HashEntry *hPtr;                /* Search variable. */
1443
    Tcl_HashSearch hSearch;             /* Iteration variable. */
1444
    Tcl_Obj *listObjPtr;                /* Local object pointer. */
1445
 
1446
    if (objc > 3) {
1447
        Tcl_WrongNumArgs(interp, 2, objv, "?path?");
1448
        return TCL_ERROR;
1449
    }
1450
    if (objc == 3) {
1451
        slaveInterp = GetInterp(interp, masterPtr,
1452
                Tcl_GetStringFromObj(objv[2], &len),
1453
                &masterPtr);
1454
        if (slaveInterp == (Tcl_Interp *) NULL) {
1455
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1456
                    "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1457
                    "\" not found", (char *) NULL);
1458
            return TCL_ERROR;
1459
        }
1460
    } else {
1461
        slaveInterp = interp;
1462
    }
1463
 
1464
    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1465
    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
1466
            "tclHiddenCmds", NULL);
1467
    if (hTblPtr != (Tcl_HashTable *) NULL) {
1468
        for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
1469
             hPtr != (Tcl_HashEntry *) NULL;
1470
             hPtr = Tcl_NextHashEntry(&hSearch)) {
1471
 
1472
            Tcl_ListObjAppendElement(interp, listObjPtr,
1473
                    Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
1474
        }
1475
    }
1476
    Tcl_SetObjResult(interp, listObjPtr);
1477
 
1478
    return TCL_OK;
1479
}
1480
 
1481
/*
1482
 *----------------------------------------------------------------------
1483
 *
1484
 * InterpInvokeHiddenHelper --
1485
 *
1486
 *      Helper routine to handle the details of invoking a hidden
1487
 *      command in another interpreter.
1488
 *
1489
 * Results:
1490
 *      A standard Tcl result.
1491
 *
1492
 * Side effects:
1493
 *      Whatever the hidden command does.
1494
 *
1495
 *----------------------------------------------------------------------
1496
 */
1497
 
1498
static int
1499
InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
1500
    Tcl_Interp *interp;                 /* Current interpreter. */
1501
    Master *masterPtr;                  /* Master record for interp. */
1502
    int objc;                           /* Number of arguments. */
1503
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1504
{
1505
    int doGlobal = 0;
1506
    int len;
1507
    int result;
1508
    Tcl_Obj *namePtr, *objPtr;
1509
    Tcl_Interp *slaveInterp;
1510
    Interp *iPtr;
1511
    char *string;
1512
 
1513
    if (objc < 4) {
1514
        Tcl_WrongNumArgs(interp, 2, objv,
1515
                "path ?-global? cmd ?arg ..?");
1516
        return TCL_ERROR;
1517
    }
1518
    if (Tcl_IsSafe(interp)) {
1519
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1520
                "not allowed to invoke hidden commands from safe interpreter",
1521
                (char *) NULL);
1522
        return TCL_ERROR;
1523
    }
1524
    if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) {
1525
        doGlobal = 1;
1526
        if (objc < 5) {
1527
            Tcl_WrongNumArgs(interp, 2, objv,
1528
                    "path ?-global? cmd ?arg ..?");
1529
            return TCL_ERROR;
1530
        }
1531
    }
1532
    slaveInterp = GetInterp(interp, masterPtr,
1533
            Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
1534
    if (slaveInterp == (Tcl_Interp *) NULL) {
1535
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1536
                "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1537
                "\" not found", (char *) NULL);
1538
        return TCL_ERROR;
1539
    }
1540
    Tcl_Preserve((ClientData) slaveInterp);
1541
    if (doGlobal) {
1542
        result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4,
1543
                TCL_INVOKE_HIDDEN);
1544
    } else {
1545
        result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN);
1546
    }
1547
 
1548
    /*
1549
     * Now make the result and any error information accessible. We
1550
     * have to be careful because the slave interpreter and the current
1551
     * interpreter can be the same - do not destroy the result.. This
1552
     * can happen if an interpreter contains an alias which is directed
1553
     * at a target command in the same interpreter.
1554
     */
1555
 
1556
    if (interp != slaveInterp) {
1557
        if (result == TCL_ERROR) {
1558
 
1559
            /*
1560
             * An error occurred, so transfer error information from
1561
             * the target interpreter back to our interpreter.
1562
             */
1563
 
1564
            iPtr = (Interp *) slaveInterp;
1565
            if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
1566
                Tcl_AddErrorInfo(slaveInterp, "");
1567
            }
1568
            iPtr->flags &= (~(ERR_ALREADY_LOGGED));
1569
 
1570
            Tcl_ResetResult(interp);
1571
            namePtr = Tcl_NewStringObj("errorInfo", -1);
1572
            objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
1573
                    (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
1574
            Tcl_DecrRefCount(namePtr);
1575
            string = Tcl_GetStringFromObj(objPtr, &len);
1576
            Tcl_AddObjErrorInfo(interp, string, len);
1577
            Tcl_SetVar2(interp, "errorCode", (char *) NULL,
1578
                    Tcl_GetVar2(slaveInterp, "errorCode", (char *)
1579
                            NULL, TCL_GLOBAL_ONLY),
1580
                    TCL_GLOBAL_ONLY);
1581
        }
1582
 
1583
        /*
1584
         * Move the result object from the slave to the master.
1585
         */
1586
 
1587
        Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
1588
        Tcl_ResetResult(slaveInterp);
1589
    }
1590
    Tcl_Release((ClientData) slaveInterp);
1591
    return result;
1592
}
1593
 
1594
/*
1595
 *----------------------------------------------------------------------
1596
 *
1597
 * InterpMarkTrustedHelper --
1598
 *
1599
 *      Helper function to handle the details of marking another
1600
 *      interpreter as trusted (unsafe).
1601
 *
1602
 * Results:
1603
 *      A standard Tcl result.
1604
 *
1605
 * Side effects:
1606
 *      Henceforth the hard-wired checks for safety will not prevent
1607
 *      this interpreter from performing certain operations.
1608
 *
1609
 *----------------------------------------------------------------------
1610
 */
1611
 
1612
static int
1613
InterpMarkTrustedHelper(interp, masterPtr, objc, objv)
1614
    Tcl_Interp *interp;                 /* Current interpreter. */
1615
    Master *masterPtr;                  /* Master record for interp. */
1616
    int objc;                           /* Number of arguments. */
1617
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1618
{
1619
    Tcl_Interp *slaveInterp;            /* A slave. */
1620
    int len;                            /* Dummy length variable. */
1621
 
1622
    if (objc != 3) {
1623
        Tcl_WrongNumArgs(interp, 2, objv, "path");
1624
        return TCL_ERROR;
1625
    }
1626
    if (Tcl_IsSafe(interp)) {
1627
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1628
                "\"", Tcl_GetStringFromObj(objv[0], &len),
1629
                " marktrusted\" can only",
1630
                " be invoked from a trusted interpreter",
1631
                (char *) NULL);
1632
        return TCL_ERROR;
1633
    }
1634
 
1635
    slaveInterp = GetInterp(interp, masterPtr,
1636
            Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
1637
    if (slaveInterp == (Tcl_Interp *) NULL) {
1638
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1639
                "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1640
                "\" not found", (char *) NULL);
1641
        return TCL_ERROR;
1642
    }
1643
    return MarkTrusted(slaveInterp);
1644
}
1645
 
1646
/*
1647
 *----------------------------------------------------------------------
1648
 *
1649
 * InterpIsSafeHelper --
1650
 *
1651
 *      Computes whether a named interpreter is safe.
1652
 *
1653
 * Results:
1654
 *      A standard Tcl result.
1655
 *
1656
 * Side effects:
1657
 *      None.
1658
 *
1659
 *----------------------------------------------------------------------
1660
 */
1661
 
1662
static int
1663
InterpIsSafeHelper(interp, masterPtr, objc, objv)
1664
    Tcl_Interp *interp;                 /* Current interpreter. */
1665
    Master *masterPtr;                  /* Master record for interp. */
1666
    int objc;                           /* Number of arguments. */
1667
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1668
{
1669
    Tcl_Interp *slaveInterp;            /* A slave. */
1670
    int len;                            /* Dummy length variable. */
1671
    Tcl_Obj *objPtr;                    /* Local object pointer. */
1672
 
1673
    if (objc > 3) {
1674
        Tcl_WrongNumArgs(interp, 2, objv, "?path?");
1675
        return TCL_ERROR;
1676
    }
1677
    if (objc == 3) {
1678
        slaveInterp = GetInterp(interp, masterPtr,
1679
                Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
1680
        if (slaveInterp == (Tcl_Interp *) NULL) {
1681
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1682
                    "interpreter \"",
1683
                    Tcl_GetStringFromObj(objv[2], &len), "\" not found",
1684
                    (char *) NULL);
1685
            return TCL_ERROR;
1686
        }
1687
        objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
1688
    } else {
1689
        objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp));
1690
    }
1691
    Tcl_SetObjResult(interp, objPtr);
1692
    return TCL_OK;
1693
}
1694
 
1695
/*
1696
 *----------------------------------------------------------------------
1697
 *
1698
 * InterpSlavesHelper --
1699
 *
1700
 *      Computes a list of slave interpreters of a named interpreter.
1701
 *
1702
 * Results:
1703
 *      A standard Tcl result.
1704
 *
1705
 * Side effects:
1706
 *      None.
1707
 *
1708
 *----------------------------------------------------------------------
1709
 */
1710
 
1711
static int
1712
InterpSlavesHelper(interp, masterPtr, objc, objv)
1713
    Tcl_Interp *interp;                 /* Current interpreter. */
1714
    Master *masterPtr;                  /* Master record for interp. */
1715
    int objc;                           /* Number of arguments. */
1716
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1717
{
1718
    int len;
1719
    Tcl_HashEntry *hPtr;                /* Search variable. */
1720
    Tcl_HashSearch hSearch;             /* Iteration variable. */
1721
    Tcl_Obj *listObjPtr;                /* Local object pointers. */
1722
 
1723
    if ((objc != 2) && (objc != 3)) {
1724
        Tcl_WrongNumArgs(interp, 2, objv, "?path?");
1725
        return TCL_ERROR;
1726
    }
1727
    if (objc == 3) {
1728
        if (GetInterp(interp, masterPtr,
1729
                Tcl_GetStringFromObj(objv[2], &len), &masterPtr) ==
1730
                (Tcl_Interp *) NULL) {
1731
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1732
                    "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1733
                    "\" not found", (char *) NULL);
1734
            return TCL_ERROR;
1735
        }
1736
    }
1737
 
1738
    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1739
    for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
1740
         hPtr != NULL;
1741
         hPtr = Tcl_NextHashEntry(&hSearch)) {
1742
 
1743
        Tcl_ListObjAppendElement(interp, listObjPtr,
1744
                Tcl_NewStringObj(
1745
                    Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1));
1746
    }
1747
    Tcl_SetObjResult(interp, listObjPtr);
1748
    return TCL_OK;
1749
}
1750
 
1751
/*
1752
 *----------------------------------------------------------------------
1753
 *
1754
 * InterpShareHelper --
1755
 *
1756
 *      Helper function to handle the details of sharing a channel between
1757
 *      interpreters.
1758
 *
1759
 * Results:
1760
 *      A standard Tcl result.
1761
 *
1762
 * Side effects:
1763
 *      After this call the named channel will be shared between the
1764
 *      interpreters named in the arguments.
1765
 *
1766
 *----------------------------------------------------------------------
1767
 */
1768
 
1769
static int
1770
InterpShareHelper(interp, masterPtr, objc, objv)
1771
    Tcl_Interp *interp;                 /* Current interpreter. */
1772
    Master *masterPtr;                  /* Master record for interp. */
1773
    int objc;                           /* Number of arguments. */
1774
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1775
{
1776
    Tcl_Interp *slaveInterp;            /* A slave. */
1777
    Tcl_Interp *masterInterp;           /* Its master. */
1778
    int len;
1779
    Tcl_Channel chan;
1780
 
1781
    if (objc != 5) {
1782
        Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
1783
        return TCL_ERROR;
1784
    }
1785
    masterInterp = GetInterp(interp, masterPtr,
1786
            Tcl_GetStringFromObj(objv[2], &len), NULL);
1787
    if (masterInterp == (Tcl_Interp *) NULL) {
1788
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1789
                "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1790
                "\" not found", (char *) NULL);
1791
        return TCL_ERROR;
1792
    }
1793
    slaveInterp = GetInterp(interp, masterPtr,
1794
            Tcl_GetStringFromObj(objv[4], &len), NULL);
1795
    if (slaveInterp == (Tcl_Interp *) NULL) {
1796
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1797
                "interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
1798
                "\" not found", (char *) NULL);
1799
        return TCL_ERROR;
1800
    }
1801
    chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len),
1802
            NULL);
1803
    if (chan == (Tcl_Channel) NULL) {
1804
        if (interp != masterInterp) {
1805
            Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
1806
            Tcl_ResetResult(masterInterp);
1807
        }
1808
        return TCL_ERROR;
1809
    }
1810
    Tcl_RegisterChannel(slaveInterp, chan);
1811
    return TCL_OK;
1812
}
1813
 
1814
/*
1815
 *----------------------------------------------------------------------
1816
 *
1817
 * InterpTargetHelper --
1818
 *
1819
 *      Helper function to compute the target of an alias.
1820
 *
1821
 * Results:
1822
 *      A standard Tcl result.
1823
 *
1824
 * Side effects:
1825
 *      None.
1826
 *
1827
 *----------------------------------------------------------------------
1828
 */
1829
 
1830
static int
1831
InterpTargetHelper(interp, masterPtr, objc, objv)
1832
    Tcl_Interp *interp;                 /* Current interpreter. */
1833
    Master *masterPtr;                  /* Master record for interp. */
1834
    int objc;                           /* Number of arguments. */
1835
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1836
{
1837
    int len;
1838
 
1839
    if (objc != 4) {
1840
        Tcl_WrongNumArgs(interp, 2, objv, "path alias");
1841
        return TCL_ERROR;
1842
    }
1843
    return GetTarget(interp,
1844
            Tcl_GetStringFromObj(objv[2], &len),
1845
            Tcl_GetStringFromObj(objv[3], &len));
1846
}
1847
 
1848
/*
1849
 *----------------------------------------------------------------------
1850
 *
1851
 * InterpTransferHelper --
1852
 *
1853
 *      Helper function to handle the details of transferring ownership
1854
 *      of a channel between interpreters.
1855
 *
1856
 * Results:
1857
 *      A standard Tcl result.
1858
 *
1859
 * Side effects:
1860
 *      After the call, the named channel will be registered in the target
1861
 *      interpreter and no longer available for use in the source interpreter.
1862
 *
1863
 *----------------------------------------------------------------------
1864
 */
1865
 
1866
static int
1867
InterpTransferHelper(interp, masterPtr, objc, objv)
1868
    Tcl_Interp *interp;                 /* Current interpreter. */
1869
    Master *masterPtr;                  /* Master record for interp. */
1870
    int objc;                           /* Number of arguments. */
1871
    Tcl_Obj *CONST objv[];              /* Argument objects. */
1872
{
1873
    Tcl_Interp *slaveInterp;            /* A slave. */
1874
    Tcl_Interp *masterInterp;           /* Its master. */
1875
    int len;
1876
    Tcl_Channel chan;
1877
 
1878
    if (objc != 5) {
1879
        Tcl_WrongNumArgs(interp, 2, objv,
1880
                "srcPath channelId destPath");
1881
        return TCL_ERROR;
1882
    }
1883
    masterInterp = GetInterp(interp, masterPtr,
1884
            Tcl_GetStringFromObj(objv[2], &len), NULL);
1885
    if (masterInterp == (Tcl_Interp *) NULL) {
1886
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1887
                "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
1888
                "\" not found", (char *) NULL);
1889
        return TCL_ERROR;
1890
    }
1891
    slaveInterp = GetInterp(interp, masterPtr,
1892
            Tcl_GetStringFromObj(objv[4], &len), NULL);
1893
    if (slaveInterp == (Tcl_Interp *) NULL) {
1894
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1895
                "interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
1896
                "\" not found", (char *) NULL);
1897
        return TCL_ERROR;
1898
    }
1899
    chan = Tcl_GetChannel(masterInterp,
1900
            Tcl_GetStringFromObj(objv[3], &len), NULL);
1901
    if (chan == (Tcl_Channel) NULL) {
1902
        if (interp != masterInterp) {
1903
 
1904
            /*
1905
             * After fixing objresult, this code will change to:
1906
             * Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
1907
             */
1908
 
1909
            Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
1910
            Tcl_ResetResult(masterInterp);
1911
        }
1912
        return TCL_ERROR;
1913
    }
1914
    Tcl_RegisterChannel(slaveInterp, chan);
1915
    if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
1916
        if (interp != masterInterp) {
1917
            Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
1918
            Tcl_ResetResult(masterInterp);
1919
        }
1920
        return TCL_ERROR;
1921
    }
1922
    return TCL_OK;
1923
}
1924
 
1925
/*
1926
 *----------------------------------------------------------------------
1927
 *
1928
 * DescribeAlias --
1929
 *
1930
 *      Sets the interpreter's result object to a Tcl list describing
1931
 *      the given alias in the given interpreter: its target command
1932
 *      and the additional arguments to prepend to any invocation
1933
 *      of the alias.
1934
 *
1935
 * Results:
1936
 *      A standard Tcl result.
1937
 *
1938
 * Side effects:
1939
 *      None.
1940
 *
1941
 *----------------------------------------------------------------------
1942
 */
1943
 
1944
static int
1945
DescribeAlias(interp, slaveInterp, aliasName)
1946
    Tcl_Interp *interp;                 /* Interpreter for result & errors. */
1947
    Tcl_Interp *slaveInterp;            /* Interpreter defining alias. */
1948
    char *aliasName;                    /* Name of alias to describe. */
1949
{
1950
    Slave *slavePtr;                    /* Slave interp slave record. */
1951
    Tcl_HashEntry *hPtr;                /* Search variable. */
1952
    Alias *aliasPtr;                    /* Structure describing alias. */
1953
    int i;                              /* Loop variable. */
1954
    Tcl_Obj *listObjPtr;                /* Local object pointer. */
1955
 
1956
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
1957
            NULL);
1958
 
1959
    /*
1960
     * The slave record should always be present because it is created
1961
     * by Tcl_CreateInterp.
1962
     */
1963
 
1964
    if (slavePtr == (Slave *) NULL) {
1965
        panic("DescribeAlias: could not find slave record");
1966
    }
1967
    hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
1968
    if (hPtr == (Tcl_HashEntry *) NULL) {
1969
        return TCL_OK;
1970
    }
1971
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1972
 
1973
    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1974
    Tcl_ListObjAppendElement(interp, listObjPtr,
1975
            Tcl_NewStringObj(aliasPtr->targetName, -1));
1976
    for (i = 0; i < aliasPtr->objc; i++) {
1977
        Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]);
1978
    }
1979
    Tcl_SetObjResult(interp, listObjPtr);
1980
    return TCL_OK;
1981
}
1982
 
1983
/*
1984
 *----------------------------------------------------------------------
1985
 *
1986
 * DeleteAlias --
1987
 *
1988
 *      Deletes the given alias from the slave interpreter given.
1989
 *
1990
 * Results:
1991
 *      A standard Tcl result.
1992
 *
1993
 * Side effects:
1994
 *      Deletes the alias from the slave interpreter.
1995
 *
1996
 *----------------------------------------------------------------------
1997
 */
1998
 
1999
static int
2000
DeleteAlias(interp, slaveInterp, aliasName)
2001
    Tcl_Interp *interp;         /* Interpreter for result and errors. */
2002
    Tcl_Interp *slaveInterp;    /* Interpreter defining alias. */
2003
    char *aliasName;            /* Name of alias to delete. */
2004
{
2005
    Slave *slavePtr;            /* Slave record for slave interpreter. */
2006
    Alias *aliasPtr;            /* Points at alias structure to delete. */
2007
    Tcl_HashEntry *hPtr;        /* Search variable. */
2008
    char *tmpPtr, *namePtr;     /* Local pointers to name of command to
2009
                                 * be deleted. */
2010
 
2011
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
2012
            NULL);
2013
    if (slavePtr == (Slave *) NULL) {
2014
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2015
                "alias \"", aliasName, "\" not found", (char *) NULL);
2016
        return TCL_ERROR;
2017
    }
2018
 
2019
    /*
2020
     * Get the alias from the alias table, then delete the command. The
2021
     * deleteProc on the alias command will take care of removing the entry
2022
     * from the alias table.
2023
     */
2024
 
2025
    hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
2026
    if (hPtr == (Tcl_HashEntry *) NULL) {
2027
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2028
                "alias \"", aliasName, "\" not found", (char *) NULL);
2029
        return TCL_ERROR;
2030
    }
2031
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
2032
 
2033
    /*
2034
     * Get a copy of the real name of the command -- it might have
2035
     * been renamed, and we want to delete the renamed command, not
2036
     * the current command (if any) by the name of the original alias.
2037
     * We need the local copy because the name may get smashed when the
2038
     * command to delete is exposed, if it was hidden.
2039
     */
2040
 
2041
    tmpPtr = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd);
2042
    namePtr = (char *) ckalloc((unsigned) strlen(tmpPtr) + 1);
2043
    strcpy(namePtr, tmpPtr);
2044
 
2045
    /*
2046
     * NOTE: The deleteProc for this command will delete the
2047
     * alias from the hash table. The deleteProc will also
2048
     * delete the target information from the master interpreter
2049
     * target table.
2050
     */
2051
 
2052
    if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) {
2053
        if (Tcl_ExposeCommand(slaveInterp, namePtr, namePtr) != TCL_OK) {
2054
            panic("DeleteAlias: did not find alias to be deleted");
2055
        }
2056
        if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) {
2057
            panic("DeleteAlias: did not find alias to be deleted");
2058
        }
2059
    }
2060
    ckfree(namePtr);
2061
 
2062
    return TCL_OK;
2063
}
2064
 
2065
/*
2066
 *----------------------------------------------------------------------
2067
 *
2068
 * Tcl_GetInterpPath --
2069
 *
2070
 *      Sets the result of the asking interpreter to a proper Tcl list
2071
 *      containing the names of interpreters between the asking and
2072
 *      target interpreters. The target interpreter must be either the
2073
 *      same as the asking interpreter or one of its slaves (including
2074
 *      recursively).
2075
 *
2076
 * Results:
2077
 *      TCL_OK if the target interpreter is the same as, or a descendant
2078
 *      of, the asking interpreter; TCL_ERROR else. This way one can
2079
 *      distinguish between the case where the asking and target interps
2080
 *      are the same (an empty list is the result, and TCL_OK is returned)
2081
 *      and when the target is not a descendant of the asking interpreter
2082
 *      (in which case the Tcl result is an error message and the function
2083
 *      returns TCL_ERROR).
2084
 *
2085
 * Side effects:
2086
 *      None.
2087
 *
2088
 *----------------------------------------------------------------------
2089
 */
2090
 
2091
int
2092
Tcl_GetInterpPath(askingInterp, targetInterp)
2093
    Tcl_Interp *askingInterp;   /* Interpreter to start search from. */
2094
    Tcl_Interp *targetInterp;   /* Interpreter to find. */
2095
{
2096
    Master *masterPtr;          /* Interim storage for Master record. */
2097
    Slave *slavePtr;            /* Interim storage for Slave record. */
2098
 
2099
    if (targetInterp == askingInterp) {
2100
        return TCL_OK;
2101
    }
2102
    if (targetInterp == (Tcl_Interp *) NULL) {
2103
        return TCL_ERROR;
2104
    }
2105
    slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord",
2106
            NULL);
2107
    if (slavePtr == (Slave *) NULL) {
2108
        return TCL_ERROR;
2109
    }
2110
    if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) {
2111
 
2112
        /*
2113
         * The result of askingInterp was set by recursive call.
2114
         */
2115
 
2116
        return TCL_ERROR;
2117
    }
2118
    masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp,
2119
            "tclMasterRecord", NULL);
2120
    if (masterPtr == (Master *) NULL) {
2121
        panic("Tcl_GetInterpPath: could not find master record");
2122
    }
2123
    Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable),
2124
            slavePtr->slaveEntry));
2125
    return TCL_OK;
2126
}
2127
 
2128
/*
2129
 *----------------------------------------------------------------------
2130
 *
2131
 * GetTarget --
2132
 *
2133
 *      Sets the result of the invoking interpreter to a path name for
2134
 *      the target interpreter of an alias in one of the slaves.
2135
 *
2136
 * Results:
2137
 *      TCL_OK if the target interpreter of the alias is a slave of the
2138
 *      invoking interpreter, TCL_ERROR else.
2139
 *
2140
 * Side effects:
2141
 *      Sets the result of the invoking interpreter.
2142
 *
2143
 *----------------------------------------------------------------------
2144
 */
2145
 
2146
static int
2147
GetTarget(askingInterp, path, aliasName)
2148
    Tcl_Interp *askingInterp;   /* Interpreter to start search from. */
2149
    char *path;                 /* The path of the interp to find. */
2150
    char *aliasName;            /* The target of this allias. */
2151
{
2152
    Tcl_Interp *slaveInterp;    /* Interim storage for slave. */
2153
    Slave *slaveSlavePtr;       /* Its Slave record. */
2154
    Master *masterPtr;          /* Interim storage for Master record. */
2155
    Tcl_HashEntry *hPtr;        /* Search element. */
2156
    Alias *aliasPtr;            /* Data describing the alias. */
2157
 
2158
    Tcl_ResetResult(askingInterp);
2159
    masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord",
2160
            NULL);
2161
    if (masterPtr == (Master *) NULL) {
2162
        panic("GetTarget: could not find master record");
2163
    }
2164
    slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL);
2165
    if (slaveInterp == (Tcl_Interp *) NULL) {
2166
        Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
2167
                "could not find interpreter \"", path, "\"", (char *) NULL);
2168
        return TCL_ERROR;
2169
    }
2170
    slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
2171
            NULL);
2172
    if (slaveSlavePtr == (Slave *) NULL) {
2173
        panic("GetTarget: could not find slave record");
2174
    }
2175
    hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName);
2176
    if (hPtr == (Tcl_HashEntry *) NULL) {
2177
        Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
2178
                "alias \"", aliasName, "\" in path \"", path, "\" not found",
2179
                (char *) NULL);
2180
        return TCL_ERROR;
2181
    }
2182
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
2183
    if (aliasPtr == (Alias *) NULL) {
2184
        panic("GetTarget: could not find alias record");
2185
    }
2186
 
2187
    if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) {
2188
        Tcl_ResetResult(askingInterp);
2189
        Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
2190
                "target interpreter for alias \"",
2191
                aliasName, "\" in path \"", path, "\" is not my descendant",
2192
                (char *) NULL);
2193
        return TCL_ERROR;
2194
    }
2195
 
2196
    return TCL_OK;
2197
}
2198
 
2199
/*
2200
 *----------------------------------------------------------------------
2201
 *
2202
 * Tcl_InterpCmd --
2203
 *
2204
 *      This procedure is invoked to process the "interp" Tcl command.
2205
 *      See the user documentation for details on what it does.
2206
 *
2207
 * Results:
2208
 *      A standard Tcl result.
2209
 *
2210
 * Side effects:
2211
 *      See the user documentation.
2212
 *
2213
 *----------------------------------------------------------------------
2214
 */
2215
        /* ARGSUSED */
2216
int
2217
Tcl_InterpObjCmd(clientData, interp, objc, objv)
2218
    ClientData clientData;              /* Unused. */
2219
    Tcl_Interp *interp;                 /* Current interpreter. */
2220
    int objc;                           /* Number of arguments. */
2221
    Tcl_Obj *CONST objv[];              /* Argument objects. */
2222
{
2223
    Master *masterPtr;                  /* Master record for current interp. */
2224
    int result;                         /* Local result variable. */
2225
 
2226
    /*
2227
     * These are all the different subcommands for this command:
2228
     */
2229
 
2230
    static char *subCmds[] = {
2231
        "alias", "aliases", "create", "delete", "eval", "exists",
2232
        "expose", "hide", "hidden", "issafe", "invokehidden",
2233
        "marktrusted", "slaves", "share", "target", "transfer",
2234
        (char *) NULL};
2235
    enum ISubCmdIdx {
2236
        IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx,
2237
        IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx,
2238
        IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx,
2239
        ITargetIdx, ITransferIdx
2240
    } index;
2241
 
2242
    if (objc < 2) {
2243
        Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
2244
        return TCL_ERROR;
2245
    }
2246
 
2247
    masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
2248
    if (masterPtr == (Master *) NULL) {
2249
        panic("Tcl_InterpCmd: could not find master record");
2250
    }
2251
 
2252
    result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
2253
            0, (int *) &index);
2254
    if (result != TCL_OK) {
2255
        return result;
2256
    }
2257
 
2258
    switch (index) {
2259
        case IAliasIdx:
2260
            return InterpAliasHelper(interp, masterPtr, objc, objv);
2261
        case IAliasesIdx:
2262
            return InterpAliasesHelper(interp, masterPtr, objc, objv);
2263
        case ICreateIdx:
2264
            return CreateInterpObject(interp, masterPtr, objc, objv);
2265
        case IDeleteIdx:
2266
            return DeleteInterpObject(interp, masterPtr, objc, objv);
2267
        case IEvalIdx:
2268
            return InterpEvalHelper(interp, masterPtr, objc, objv);
2269
        case IExistsIdx:
2270
            return InterpExistsHelper(interp, masterPtr, objc, objv);
2271
        case IExposeIdx:
2272
            return InterpExposeHelper(interp, masterPtr, objc, objv);
2273
        case IHideIdx:
2274
            return InterpHideHelper(interp, masterPtr, objc, objv);
2275
        case IHiddenIdx:
2276
            return InterpHiddenHelper(interp, masterPtr, objc, objv);
2277
        case IIsSafeIdx:
2278
            return InterpIsSafeHelper(interp, masterPtr, objc, objv);
2279
        case IInvokeHiddenIdx:
2280
            return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv);
2281
        case IMarkTrustedIdx:
2282
            return InterpMarkTrustedHelper(interp, masterPtr, objc, objv);
2283
        case ISlavesIdx:
2284
            return InterpSlavesHelper(interp, masterPtr, objc, objv);
2285
        case IShareIdx:
2286
            return InterpShareHelper(interp, masterPtr, objc, objv);
2287
        case ITargetIdx:
2288
            return InterpTargetHelper(interp, masterPtr, objc, objv);
2289
        case ITransferIdx:
2290
            return InterpTransferHelper(interp, masterPtr, objc, objv);
2291
    }
2292
 
2293
    return TCL_ERROR;
2294
}
2295
 
2296
/*
2297
 *----------------------------------------------------------------------
2298
 *
2299
 * SlaveAliasHelper --
2300
 *
2301
 *      Helper function to construct or query an alias for a slave
2302
 *      interpreter.
2303
 *
2304
 * Results:
2305
 *      A standard Tcl result.
2306
 *
2307
 * Side effects:
2308
 *      Potentially creates a new alias.
2309
 *
2310
 *----------------------------------------------------------------------
2311
 */
2312
 
2313
static int
2314
SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv)
2315
    Tcl_Interp  *interp;                /* Current interpreter. */
2316
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2317
    Slave *slavePtr;                    /* Its slave record. */
2318
    int objc;                           /* Count of arguments. */
2319
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2320
{
2321
    Master *masterPtr;
2322
    int len;
2323
 
2324
    switch (objc-2) {
2325
        case 0:
2326
            Tcl_WrongNumArgs(interp, 2, objv,
2327
                    "aliasName ?targetName? ?args..?");
2328
            return TCL_ERROR;
2329
 
2330
        case 1:
2331
 
2332
            /*
2333
             * Return the name of the command in the current
2334
             * interpreter for which the argument is an alias in the
2335
             * slave interpreter, and the list of saved arguments
2336
             */
2337
 
2338
            return DescribeAlias(interp, slaveInterp,
2339
                    Tcl_GetStringFromObj(objv[2], &len));
2340
 
2341
        default:
2342
            masterPtr = (Master *) Tcl_GetAssocData(interp,
2343
                    "tclMasterRecord", NULL);
2344
            if (masterPtr == (Master *) NULL) {
2345
                panic("SlaveObjectCmd: could not find master record");
2346
            }
2347
            return AliasCreationHelper(interp, slaveInterp, interp,
2348
                    masterPtr,
2349
                    Tcl_GetStringFromObj(objv[2], &len),
2350
                    Tcl_GetStringFromObj(objv[3], &len),
2351
                    objc-4, objv+4);
2352
    }
2353
}
2354
 
2355
/*
2356
 *----------------------------------------------------------------------
2357
 *
2358
 * SlaveAliasesHelper --
2359
 *
2360
 *      Computes a list of aliases defined in a slave interpreter.
2361
 *
2362
 * Results:
2363
 *      A standard Tcl result.
2364
 *
2365
 * Side effects:
2366
 *      None.
2367
 *
2368
 *----------------------------------------------------------------------
2369
 */
2370
 
2371
static int
2372
SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv)
2373
    Tcl_Interp  *interp;                /* Current interpreter. */
2374
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2375
    Slave *slavePtr;                    /* Its slave record. */
2376
    int objc;                           /* Count of arguments. */
2377
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2378
{
2379
    Tcl_HashEntry *hPtr;                /* For local searches. */
2380
    Tcl_HashSearch hSearch;             /* For local searches. */
2381
    Tcl_Obj *listObjPtr;                /* Local object pointer. */
2382
    Alias *aliasPtr;                    /* Alias information. */
2383
 
2384
    /*
2385
     * Return the names of all the aliases created in the
2386
     * slave interpreter.
2387
     */
2388
 
2389
    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
2390
    for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable),
2391
            &hSearch);
2392
         hPtr != (Tcl_HashEntry *) NULL;
2393
         hPtr = Tcl_NextHashEntry(&hSearch)) {
2394
        aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
2395
        Tcl_ListObjAppendElement(interp, listObjPtr,
2396
                Tcl_NewStringObj(aliasPtr->aliasName, -1));
2397
    }
2398
    Tcl_SetObjResult(interp, listObjPtr);
2399
    return TCL_OK;
2400
}
2401
 
2402
/*
2403
 *----------------------------------------------------------------------
2404
 *
2405
 * SlaveEvalHelper --
2406
 *
2407
 *      Helper function to evaluate a command in a slave interpreter.
2408
 *
2409
 * Results:
2410
 *      A standard Tcl result.
2411
 *
2412
 * Side effects:
2413
 *      Whatever the command does.
2414
 *
2415
 *----------------------------------------------------------------------
2416
 */
2417
 
2418
static int
2419
SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
2420
    Tcl_Interp  *interp;                /* Current interpreter. */
2421
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2422
    Slave *slavePtr;                    /* Its slave record. */
2423
    int objc;                           /* Count of arguments. */
2424
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2425
{
2426
    Interp *iPtr;                       /* Internal data type for slave. */
2427
    Tcl_Obj *objPtr;                    /* Local object pointer. */
2428
    Tcl_Obj *namePtr;                   /* Local object pointer. */
2429
    int len;
2430
    char *string;
2431
    int result;
2432
 
2433
    if (objc < 3) {
2434
        Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
2435
        return TCL_ERROR;
2436
    }
2437
 
2438
    objPtr = Tcl_ConcatObj(objc-2, objv+2);
2439
    Tcl_IncrRefCount(objPtr);
2440
 
2441
    Tcl_Preserve((ClientData) slaveInterp);
2442
    result = Tcl_EvalObj(slaveInterp, objPtr);
2443
 
2444
    Tcl_DecrRefCount(objPtr);
2445
 
2446
    /*
2447
     * Make the result and any error information accessible. We have
2448
     * to be careful because the slave interpreter and the current
2449
     * interpreter can be the same - do not destroy the result.. This
2450
     * can happen if an interpreter contains an alias which is directed
2451
     * at a target command in the same interpreter.
2452
     */
2453
 
2454
    if (interp != slaveInterp) {
2455
        if (result == TCL_ERROR) {
2456
 
2457
            /*
2458
             * An error occurred, so transfer error information from the
2459
             * destination interpreter back to our interpreter.
2460
             */
2461
 
2462
            iPtr = (Interp *) slaveInterp;
2463
            if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
2464
                Tcl_AddErrorInfo(slaveInterp, "");
2465
            }
2466
            iPtr->flags &= (~(ERR_ALREADY_LOGGED));
2467
 
2468
            Tcl_ResetResult(interp);
2469
            namePtr = Tcl_NewStringObj("errorInfo", -1);
2470
            objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
2471
                    (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
2472
            string = Tcl_GetStringFromObj(objPtr, &len);
2473
            Tcl_AddObjErrorInfo(interp, string, len);
2474
            Tcl_SetVar2(interp, "errorCode", (char *) NULL,
2475
                    Tcl_GetVar2(slaveInterp, "errorCode", (char *)
2476
                            NULL, TCL_GLOBAL_ONLY),
2477
                    TCL_GLOBAL_ONLY);
2478
            Tcl_DecrRefCount(namePtr);
2479
        }
2480
 
2481
        /*
2482
         * Move the result object from one interpreter to the
2483
         * other.
2484
         */
2485
 
2486
        Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
2487
        Tcl_ResetResult(slaveInterp);
2488
    }
2489
    Tcl_Release((ClientData) slaveInterp);
2490
    return result;
2491
}
2492
 
2493
/*
2494
 *----------------------------------------------------------------------
2495
 *
2496
 * SlaveExposeHelper --
2497
 *
2498
 *      Helper function to expose a command in a slave interpreter.
2499
 *
2500
 * Results:
2501
 *      A standard Tcl result.
2502
 *
2503
 * Side effects:
2504
 *      After this call scripts in the slave will be able to invoke
2505
 *      the newly exposed command.
2506
 *
2507
 *----------------------------------------------------------------------
2508
 */
2509
 
2510
static int
2511
SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
2512
    Tcl_Interp  *interp;                /* Current interpreter. */
2513
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2514
    Slave *slavePtr;                    /* Its slave record. */
2515
    int objc;                           /* Count of arguments. */
2516
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2517
{
2518
    int len;
2519
 
2520
    if ((objc != 3) && (objc != 4)) {
2521
        Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
2522
        return TCL_ERROR;
2523
    }
2524
    if (Tcl_IsSafe(interp)) {
2525
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2526
                "permission denied: safe interpreter cannot expose commands",
2527
                (char *) NULL);
2528
        return TCL_ERROR;
2529
    }
2530
    if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
2531
            (objc == 4 ?
2532
                    Tcl_GetStringFromObj(objv[3], &len) :
2533
                    Tcl_GetStringFromObj(objv[2], &len)))
2534
            == TCL_ERROR) {
2535
        Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
2536
        Tcl_ResetResult(slaveInterp);
2537
        return TCL_ERROR;
2538
    }
2539
    return TCL_OK;
2540
}
2541
 
2542
/*
2543
 *----------------------------------------------------------------------
2544
 *
2545
 * SlaveHideHelper --
2546
 *
2547
 *      Helper function to hide a command in a slave interpreter.
2548
 *
2549
 * Results:
2550
 *      A standard Tcl result.
2551
 *
2552
 * Side effects:
2553
 *      After this call scripts in the slave will no longer be able
2554
 *      to invoke the named command.
2555
 *
2556
 *----------------------------------------------------------------------
2557
 */
2558
 
2559
static int
2560
SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
2561
    Tcl_Interp  *interp;                /* Current interpreter. */
2562
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2563
    Slave *slavePtr;                    /* Its slave record. */
2564
    int objc;                           /* Count of arguments. */
2565
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2566
{
2567
    int len;
2568
 
2569
    if ((objc != 3) && (objc != 4)) {
2570
        Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
2571
        return TCL_ERROR;
2572
    }
2573
    if (Tcl_IsSafe(interp)) {
2574
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2575
                "permission denied: safe interpreter cannot hide commands",
2576
                (char *) NULL);
2577
        return TCL_ERROR;
2578
    }
2579
    if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
2580
            (objc == 4 ?
2581
                    Tcl_GetStringFromObj(objv[3], &len) :
2582
                    Tcl_GetStringFromObj(objv[2], &len)))
2583
            == TCL_ERROR) {
2584
        Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
2585
        Tcl_ResetResult(slaveInterp);
2586
        return TCL_ERROR;
2587
    }
2588
    return TCL_OK;
2589
}
2590
 
2591
/*
2592
 *----------------------------------------------------------------------
2593
 *
2594
 * SlaveHiddenHelper --
2595
 *
2596
 *      Helper function to compute list of hidden commands in a slave
2597
 *      interpreter.
2598
 *
2599
 * Results:
2600
 *      A standard Tcl result.
2601
 *
2602
 * Side effects:
2603
 *      None.
2604
 *
2605
 *----------------------------------------------------------------------
2606
 */
2607
 
2608
static int
2609
SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
2610
    Tcl_Interp  *interp;                /* Current interpreter. */
2611
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2612
    Slave *slavePtr;                    /* Its slave record. */
2613
    int objc;                           /* Count of arguments. */
2614
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2615
{
2616
    Tcl_Obj *listObjPtr;                /* Local object pointer. */
2617
    Tcl_HashTable *hTblPtr;             /* For local searches. */
2618
    Tcl_HashEntry *hPtr;                /* For local searches. */
2619
    Tcl_HashSearch hSearch;             /* For local searches. */
2620
 
2621
    if (objc != 2) {
2622
        Tcl_WrongNumArgs(interp, 2, objv, NULL);
2623
        return TCL_ERROR;
2624
    }
2625
 
2626
    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
2627
    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
2628
            "tclHiddenCmds", NULL);
2629
    if (hTblPtr != (Tcl_HashTable *) NULL) {
2630
        for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
2631
             hPtr != (Tcl_HashEntry *) NULL;
2632
             hPtr = Tcl_NextHashEntry(&hSearch)) {
2633
            Tcl_ListObjAppendElement(interp, listObjPtr,
2634
                    Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
2635
        }
2636
    }
2637
    Tcl_SetObjResult(interp, listObjPtr);
2638
    return TCL_OK;
2639
}
2640
 
2641
/*
2642
 *----------------------------------------------------------------------
2643
 *
2644
 * SlaveIsSafeHelper --
2645
 *
2646
 *      Helper function to compute whether a slave interpreter is safe.
2647
 *
2648
 * Results:
2649
 *      A standard Tcl result.
2650
 *
2651
 * Side effects:
2652
 *      None.
2653
 *
2654
 *----------------------------------------------------------------------
2655
 */
2656
 
2657
static int
2658
SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
2659
    Tcl_Interp  *interp;                /* Current interpreter. */
2660
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2661
    Slave *slavePtr;                    /* Its slave record. */
2662
    int objc;                           /* Count of arguments. */
2663
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2664
{
2665
    Tcl_Obj *resultPtr;                 /* Local object pointer. */
2666
 
2667
    if (objc > 2) {
2668
        Tcl_WrongNumArgs(interp, 2, objv, NULL);
2669
        return TCL_ERROR;
2670
    }
2671
    resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
2672
 
2673
    Tcl_SetObjResult(interp, resultPtr);
2674
    return TCL_OK;
2675
}
2676
 
2677
/*
2678
 *----------------------------------------------------------------------
2679
 *
2680
 * SlaveInvokeHiddenHelper --
2681
 *
2682
 *      Helper function to invoke a hidden command in a slave interpreter.
2683
 *
2684
 * Results:
2685
 *      A standard Tcl result.
2686
 *
2687
 * Side effects:
2688
 *      Whatever the hidden command does.
2689
 *
2690
 *----------------------------------------------------------------------
2691
 */
2692
 
2693
static int
2694
SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
2695
    Tcl_Interp  *interp;                /* Current interpreter. */
2696
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2697
    Slave *slavePtr;                    /* Its slave record. */
2698
    int objc;                           /* Count of arguments. */
2699
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2700
{
2701
    Interp *iPtr;
2702
    Master *masterPtr;
2703
    int doGlobal = 0;
2704
    int result;
2705
    int len;
2706
    char *string;
2707
    Tcl_Obj *namePtr, *objPtr;
2708
 
2709
    if (objc < 3) {
2710
        Tcl_WrongNumArgs(interp, 2, objv,
2711
                "?-global? cmd ?arg ..?");
2712
        return TCL_ERROR;
2713
    }
2714
    if (Tcl_IsSafe(interp)) {
2715
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2716
                "not allowed to invoke hidden commands from safe interpreter",
2717
                (char *) NULL);
2718
        return TCL_ERROR;
2719
    }
2720
    if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) {
2721
        doGlobal = 1;
2722
        if (objc < 4) {
2723
            Tcl_WrongNumArgs(interp, 2, objv,
2724
                    "path ?-global? cmd ?arg ..?");
2725
            return TCL_ERROR;
2726
        }
2727
    }
2728
    masterPtr = (Master *) Tcl_GetAssocData(slaveInterp,
2729
            "tclMasterRecord", NULL);
2730
    if (masterPtr == (Master *) NULL) {
2731
        panic("SlaveObjectCmd: could not find master record");
2732
    }
2733
    Tcl_Preserve((ClientData) slaveInterp);
2734
    if (doGlobal) {
2735
        result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3,
2736
                TCL_INVOKE_HIDDEN);
2737
    } else {
2738
        result = TclObjInvoke(slaveInterp, objc-2, objv+2,
2739
                TCL_INVOKE_HIDDEN);
2740
    }
2741
 
2742
    /*
2743
     * Now make the result and any error information accessible. We
2744
     * have to be careful because the slave interpreter and the current
2745
     * interpreter can be the same - do not destroy the result.. This
2746
     * can happen if an interpreter contains an alias which is directed
2747
     * at a target command in the same interpreter.
2748
     */
2749
 
2750
    if (interp != slaveInterp) {
2751
        if (result == TCL_ERROR) {
2752
 
2753
            /*
2754
             * An error occurred, so transfer error information from
2755
             * the target interpreter back to our interpreter.
2756
             */
2757
 
2758
            iPtr = (Interp *) slaveInterp;
2759
            if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
2760
                Tcl_AddErrorInfo(slaveInterp, "");
2761
            }
2762
            iPtr->flags &= (~(ERR_ALREADY_LOGGED));
2763
 
2764
            Tcl_ResetResult(interp);
2765
            namePtr = Tcl_NewStringObj("errorInfo", -1);
2766
            objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
2767
                    (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
2768
            string = Tcl_GetStringFromObj(objPtr, &len);
2769
            Tcl_AddObjErrorInfo(interp, string, len);
2770
            Tcl_SetVar2(interp, "errorCode", (char *) NULL,
2771
                    Tcl_GetVar2(slaveInterp, "errorCode", (char *)
2772
                            NULL, TCL_GLOBAL_ONLY),
2773
                    TCL_GLOBAL_ONLY);
2774
            Tcl_DecrRefCount(namePtr);
2775
        }
2776
 
2777
        /*
2778
         * Move the result object from the slave to the master.
2779
         */
2780
 
2781
        Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
2782
        Tcl_ResetResult(slaveInterp);
2783
    }
2784
    Tcl_Release((ClientData) slaveInterp);
2785
    return result;
2786
}
2787
 
2788
/*
2789
 *----------------------------------------------------------------------
2790
 *
2791
 * SlaveMarkTrustedHelper --
2792
 *
2793
 *      Helper function to mark a slave interpreter as trusted (unsafe).
2794
 *
2795
 * Results:
2796
 *      A standard Tcl result.
2797
 *
2798
 * Side effects:
2799
 *      After this call the hard-wired security checks in the core no
2800
 *      longer prevent the slave from performing certain operations.
2801
 *
2802
 *----------------------------------------------------------------------
2803
 */
2804
 
2805
static int
2806
SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv)
2807
    Tcl_Interp  *interp;                /* Current interpreter. */
2808
    Tcl_Interp  *slaveInterp;           /* The slave interpreter. */
2809
    Slave *slavePtr;                    /* Its slave record. */
2810
    int objc;                           /* Count of arguments. */
2811
    Tcl_Obj *CONST objv[];              /* Vector of arguments. */
2812
{
2813
    int len;
2814
 
2815
    if (objc != 2) {
2816
        Tcl_WrongNumArgs(interp, 2, objv, NULL);
2817
        return TCL_ERROR;
2818
    }
2819
    if (Tcl_IsSafe(interp)) {
2820
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2821
                "\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"",
2822
                " can only be invoked from a trusted interpreter",
2823
                (char *) NULL);
2824
        return TCL_ERROR;
2825
    }
2826
    return MarkTrusted(slaveInterp);
2827
}
2828
 
2829
/*
2830
 *----------------------------------------------------------------------
2831
 *
2832
 * SlaveObjectCmd --
2833
 *
2834
 *      Command to manipulate an interpreter, e.g. to send commands to it
2835
 *      to be evaluated. One such command exists for each slave interpreter.
2836
 *
2837
 * Results:
2838
 *      A standard Tcl result.
2839
 *
2840
 * Side effects:
2841
 *      See user documentation for details.
2842
 *
2843
 *----------------------------------------------------------------------
2844
 */
2845
 
2846
static int
2847
SlaveObjectCmd(clientData, interp, objc, objv)
2848
    ClientData clientData;              /* Slave interpreter. */
2849
    Tcl_Interp *interp;                 /* Current interpreter. */
2850
    int objc;                           /* Number of arguments. */
2851
    Tcl_Obj *CONST objv[];              /* The argument vector. */
2852
{
2853
    Slave *slavePtr;                    /* Slave record. */
2854
    Tcl_Interp *slaveInterp;            /* Slave interpreter. */
2855
    int result;                         /* Loop counter, status return. */
2856
    int len;                            /* Length of command name. */
2857
 
2858
    /*
2859
     * These are all the different subcommands for this command:
2860
     */
2861
 
2862
    static char *subCmds[] = {
2863
        "alias", "aliases",
2864
        "eval", "expose",
2865
        "hide", "hidden",
2866
        "issafe", "invokehidden",
2867
        "marktrusted",
2868
        (char *) NULL};
2869
    enum ISubCmdIdx {
2870
        IAliasIdx, IAliasesIdx,
2871
        IEvalIdx, IExposeIdx,
2872
        IHideIdx, IHiddenIdx,
2873
        IIsSafeIdx, IInvokeHiddenIdx,
2874
        IMarkTrustedIdx
2875
    } index;
2876
 
2877
    if (objc < 2) {
2878
        Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
2879
        return TCL_ERROR;
2880
    }
2881
 
2882
    slaveInterp = (Tcl_Interp *) clientData;
2883
    if (slaveInterp == (Tcl_Interp *) NULL) {
2884
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2885
                "interpreter ", Tcl_GetStringFromObj(objv[0], &len),
2886
                " has been deleted", (char *) NULL);
2887
        return TCL_ERROR;
2888
    }
2889
 
2890
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
2891
            "tclSlaveRecord", NULL);
2892
    if (slavePtr == (Slave *) NULL) {
2893
        panic("SlaveObjectCmd: could not find slave record");
2894
    }
2895
 
2896
    result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
2897
            0, (int *) &index);
2898
    if (result != TCL_OK) {
2899
        return result;
2900
    }
2901
 
2902
    switch (index) {
2903
        case IAliasIdx:
2904
            return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv);
2905
        case IAliasesIdx:
2906
            return SlaveAliasesHelper(interp, slaveInterp, slavePtr,
2907
                    objc, objv);
2908
        case IEvalIdx:
2909
            return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv);
2910
        case IExposeIdx:
2911
            return SlaveExposeHelper(interp, slaveInterp, slavePtr,
2912
                    objc, objv);
2913
        case IHideIdx:
2914
            return SlaveHideHelper(interp, slaveInterp, slavePtr,
2915
                    objc, objv);
2916
        case IHiddenIdx:
2917
            return SlaveHiddenHelper(interp, slaveInterp, slavePtr,
2918
                    objc, objv);
2919
        case IIsSafeIdx:
2920
            return SlaveIsSafeHelper(interp, slaveInterp, slavePtr,
2921
                    objc, objv);
2922
        case IInvokeHiddenIdx:
2923
            return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr,
2924
                    objc, objv);
2925
        case IMarkTrustedIdx:
2926
            return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr,
2927
                    objc, objv);
2928
    }
2929
 
2930
    return TCL_ERROR;
2931
}
2932
 
2933
/*
2934
 *----------------------------------------------------------------------
2935
 *
2936
 * SlaveObjectDeleteProc --
2937
 *
2938
 *      Invoked when an object command for a slave interpreter is deleted;
2939
 *      cleans up all state associated with the slave interpreter and destroys
2940
 *      the slave interpreter.
2941
 *
2942
 * Results:
2943
 *      None.
2944
 *
2945
 * Side effects:
2946
 *      Cleans up all state associated with the slave interpreter and
2947
 *      destroys the slave interpreter.
2948
 *
2949
 *----------------------------------------------------------------------
2950
 */
2951
 
2952
static void
2953
SlaveObjectDeleteProc(clientData)
2954
    ClientData clientData;              /* The SlaveRecord for the command. */
2955
{
2956
    Slave *slavePtr;                    /* Interim storage for Slave record. */
2957
    Tcl_Interp *slaveInterp;            /* And for a slave interp. */
2958
 
2959
    slaveInterp = (Tcl_Interp *) clientData;
2960
    slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL);
2961
    if (slavePtr == (Slave *) NULL) {
2962
        panic("SlaveObjectDeleteProc: could not find slave record");
2963
    }
2964
 
2965
    /*
2966
     * Delete the entry in the slave table in the master interpreter now.
2967
     * This is to avoid an infinite loop in the Master hash table cleanup in
2968
     * the master interpreter. This can happen if this slave is being deleted
2969
     * because the master is being deleted and the slave deletion is deferred
2970
     * because it is still active.
2971
     */
2972
 
2973
    Tcl_DeleteHashEntry(slavePtr->slaveEntry);
2974
 
2975
    /*
2976
     * Set to NULL so that when the slave record is cleaned up in the slave
2977
     * it does not try to delete the command causing all sorts of grief.
2978
     * See SlaveRecordDeleteProc().
2979
     */
2980
 
2981
    slavePtr->interpCmd = NULL;
2982
 
2983
    /*
2984
     * Destroy the interpreter - this will cause all the deleteProcs for
2985
     * all commands (including aliases) to run.
2986
     *
2987
     * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!!
2988
     */
2989
 
2990
    Tcl_DeleteInterp(slavePtr->slaveInterp);
2991
}
2992
 
2993
/*
2994
 *----------------------------------------------------------------------
2995
 *
2996
 * AliasCmd --
2997
 *
2998
 *      This is the procedure that services invocations of aliases in a
2999
 *      slave interpreter. One such command exists for each alias. When
3000
 *      invoked, this procedure redirects the invocation to the target
3001
 *      command in the master interpreter as designated by the Alias
3002
 *      record associated with this command.
3003
 *
3004
 * Results:
3005
 *      A standard Tcl result.
3006
 *
3007
 * Side effects:
3008
 *      Causes forwarding of the invocation; all possible side effects
3009
 *      may occur as a result of invoking the command to which the
3010
 *      invocation is forwarded.
3011
 *
3012
 *----------------------------------------------------------------------
3013
 */
3014
 
3015
static int
3016
AliasCmd(clientData, interp, objc, objv)
3017
    ClientData clientData;              /* Alias record. */
3018
    Tcl_Interp *interp;                 /* Current interpreter. */
3019
    int objc;                           /* Number of arguments. */
3020
    Tcl_Obj *CONST objv[];              /* Argument vector. */
3021
{
3022
    Tcl_Interp *targetInterp;           /* Target for alias exec. */
3023
    Interp *iPtr;                       /* Internal type of target. */
3024
    Alias *aliasPtr;                    /* Describes the alias. */
3025
    Tcl_Command cmd;                    /* The target command. */
3026
    Command *cmdPtr;                    /* Points to target command. */
3027
    Tcl_Namespace *targetNsPtr;         /* Target command's namespace. */
3028
    int result;                         /* Result of execution. */
3029
    int i, j, addObjc;                  /* Loop counters. */
3030
    int localObjc;                      /* Local argument count. */
3031
    Tcl_Obj **localObjv;                /* Local argument vector. */
3032
    Tcl_Obj *namePtr, *objPtr;          /* Local object pointers. */
3033
    char *string;                       /* Local object string rep. */
3034
    int len;                            /* Dummy length arg. */
3035
 
3036
    aliasPtr = (Alias *) clientData;
3037
    targetInterp = aliasPtr->targetInterp;
3038
 
3039
    /*
3040
     * Look for the target command in the global namespace of the target
3041
     * interpreter.
3042
     */
3043
 
3044
    cmdPtr = NULL;
3045
    targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp);
3046
    cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName,
3047
            targetNsPtr, /*flags*/ 0);
3048
    if (cmd != (Tcl_Command) NULL) {
3049
        cmdPtr = (Command *) cmd;
3050
    }
3051
 
3052
    iPtr = (Interp *) targetInterp;
3053
 
3054
    /*
3055
     * If the command does not exist, invoke "unknown" in the master.
3056
     */
3057
 
3058
    if (cmdPtr == NULL) {
3059
        addObjc = aliasPtr->objc;
3060
        localObjc = addObjc + objc + 1;
3061
        localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *)
3062
                * localObjc);
3063
 
3064
        localObjv[0] = Tcl_NewStringObj("unknown", -1);
3065
        localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1);
3066
        Tcl_IncrRefCount(localObjv[0]);
3067
        Tcl_IncrRefCount(localObjv[1]);
3068
 
3069
        for (i = 0, j = 2; i < addObjc; i++, j++) {
3070
            localObjv[j] = aliasPtr->objv[i];
3071
        }
3072
        for (i = 1; i < objc; i++, j++) {
3073
            localObjv[j] = objv[i];
3074
        }
3075
        Tcl_Preserve((ClientData) targetInterp);
3076
        result = TclObjInvoke(targetInterp, localObjc, localObjv, 0);
3077
 
3078
        Tcl_DecrRefCount(localObjv[0]);
3079
        Tcl_DecrRefCount(localObjv[1]);
3080
 
3081
        ckfree((char *) localObjv);
3082
 
3083
        if (targetInterp != interp) {
3084
            if (result == TCL_ERROR) {
3085
 
3086
                /*
3087
                 * An error occurred, so transfer error information from
3088
                 * the target interpreter back to our interpreter.
3089
                 */
3090
 
3091
                if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
3092
                    Tcl_AddErrorInfo((Tcl_Interp *) iPtr, "");
3093
                }
3094
                iPtr->flags &= (~(ERR_ALREADY_LOGGED));
3095
 
3096
                Tcl_ResetResult(interp);
3097
                namePtr = Tcl_NewStringObj("errorInfo", -1);
3098
                objPtr = Tcl_ObjGetVar2(targetInterp, namePtr,
3099
                        (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
3100
                string = Tcl_GetStringFromObj(objPtr, &len);
3101
                Tcl_AddObjErrorInfo(interp, string, len);
3102
                Tcl_SetVar2(interp, "errorCode", (char *) NULL,
3103
                        Tcl_GetVar2(targetInterp, "errorCode", (char *)
3104
                                NULL, TCL_GLOBAL_ONLY),
3105
                        TCL_GLOBAL_ONLY);
3106
                Tcl_DecrRefCount(namePtr);
3107
            }
3108
 
3109
            /*
3110
             * Transfer the result from the target interpreter to the
3111
             * calling interpreter.
3112
             */
3113
 
3114
            Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
3115
            Tcl_ResetResult(targetInterp);
3116
        }
3117
 
3118
        Tcl_Release((ClientData) targetInterp);
3119
        return result;
3120
    }
3121
 
3122
    /*
3123
     * Otherwise invoke the regular target command.
3124
     */
3125
 
3126
    if (aliasPtr->objc <= 0) {
3127
        localObjv = (Tcl_Obj **) objv;
3128
        localObjc = objc;
3129
    } else {
3130
        addObjc = aliasPtr->objc;
3131
        localObjc = objc + addObjc;
3132
        localObjv =
3133
            (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc);
3134
        localObjv[0] = objv[0];
3135
        for (i = 0, j = 1; i < addObjc; i++, j++) {
3136
            localObjv[j] = aliasPtr->objv[i];
3137
        }
3138
        for (i = 1; i < objc; i++, j++) {
3139
            localObjv[j] = objv[i];
3140
        }
3141
    }
3142
 
3143
    iPtr->numLevels++;
3144
    Tcl_Preserve((ClientData) targetInterp);
3145
 
3146
    /*
3147
     * Reset the interpreter to its clean state; we do not know what state
3148
     * it is in now..
3149
     */
3150
 
3151
    Tcl_ResetResult(targetInterp);
3152
    result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp,
3153
            localObjc, localObjv);
3154
 
3155
    iPtr->numLevels--;
3156
 
3157
    /*
3158
     * Check if we are at the bottom of the stack for the target interpreter.
3159
     * If so, check for special return codes.
3160
     */
3161
 
3162
    if (iPtr->numLevels == 0) {
3163
        if (result == TCL_RETURN) {
3164
            result = TclUpdateReturnInfo(iPtr);
3165
        }
3166
        if ((result != TCL_OK) && (result != TCL_ERROR)) {
3167
            Tcl_ResetResult(targetInterp);
3168
            if (result == TCL_BREAK) {
3169
                Tcl_SetObjResult(targetInterp,
3170
                        Tcl_NewStringObj("invoked \"break\" outside of a loop",
3171
                                -1));
3172
            } else if (result == TCL_CONTINUE) {
3173
                Tcl_SetObjResult(targetInterp,
3174
                        Tcl_NewStringObj(
3175
                            "invoked \"continue\" outside of a loop",
3176
                            -1));
3177
            } else {
3178
                char buf[128];
3179
 
3180
                sprintf(buf, "command returned bad code: %d", result);
3181
                Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
3182
            }
3183
            result = TCL_ERROR;
3184
        }
3185
    }
3186
 
3187
    /*
3188
     * Clean up any locally allocated argument vector structure.
3189
     */
3190
 
3191
    if (localObjv != objv) {
3192
        ckfree((char *) localObjv);
3193
    }
3194
 
3195
    /*
3196
     * Move the result from the target interpreter to the invoking
3197
     * interpreter if they are different.
3198
     *
3199
     * Note: We cannot use aliasPtr any more because the alias may have
3200
     * been deleted.
3201
     */
3202
 
3203
    if (interp != targetInterp) {
3204
        if (result == TCL_ERROR) {
3205
 
3206
            /*
3207
             * An error occurred, so transfer the error information from
3208
             * the target interpreter back to our interpreter.
3209
             */
3210
 
3211
            if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
3212
                Tcl_AddErrorInfo(targetInterp, "");
3213
            }
3214
            iPtr->flags &= (~(ERR_ALREADY_LOGGED));
3215
 
3216
            Tcl_ResetResult(interp);
3217
            namePtr = Tcl_NewStringObj("errorInfo", -1);
3218
            objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL,
3219
                    TCL_GLOBAL_ONLY);
3220
            string = Tcl_GetStringFromObj(objPtr, &len);
3221
            Tcl_AddObjErrorInfo(interp, string, len);
3222
            Tcl_SetVar2(interp, "errorCode", (char *) NULL,
3223
                    Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL,
3224
                            TCL_GLOBAL_ONLY),
3225
                    TCL_GLOBAL_ONLY);
3226
            Tcl_DecrRefCount(namePtr);
3227
        }
3228
 
3229
        /*
3230
         * Move the result object from one interpreter to the
3231
         * other.
3232
         */
3233
 
3234
        Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
3235
        Tcl_ResetResult(targetInterp);
3236
    }
3237
    Tcl_Release((ClientData) targetInterp);
3238
    return result;
3239
}
3240
 
3241
/*
3242
 *----------------------------------------------------------------------
3243
 *
3244
 * AliasCmdDeleteProc --
3245
 *
3246
 *      Is invoked when an alias command is deleted in a slave. Cleans up
3247
 *      all storage associated with this alias.
3248
 *
3249
 * Results:
3250
 *      None.
3251
 *
3252
 * Side effects:
3253
 *      Deletes the alias record and its entry in the alias table for
3254
 *      the interpreter.
3255
 *
3256
 *----------------------------------------------------------------------
3257
 */
3258
 
3259
static void
3260
AliasCmdDeleteProc(clientData)
3261
    ClientData clientData;              /* The alias record for this alias. */
3262
{
3263
    Alias *aliasPtr;                    /* Alias record for alias to delete. */
3264
    Target *targetPtr;                  /* Record for target of this alias. */
3265
    int i;                              /* Loop counter. */
3266
 
3267
    aliasPtr = (Alias *) clientData;
3268
 
3269
    targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry);
3270
    ckfree((char *) targetPtr);
3271
    Tcl_DeleteHashEntry(aliasPtr->targetEntry);
3272
 
3273
    ckfree((char *) aliasPtr->targetName);
3274
    ckfree((char *) aliasPtr->aliasName);
3275
    for (i = 0; i < aliasPtr->objc; i++) {
3276
        Tcl_DecrRefCount(aliasPtr->objv[i]);
3277
    }
3278
    if (aliasPtr->objv != (Tcl_Obj **) NULL) {
3279
        ckfree((char *) aliasPtr->objv);
3280
    }
3281
 
3282
    Tcl_DeleteHashEntry(aliasPtr->aliasEntry);
3283
 
3284
    ckfree((char *) aliasPtr);
3285
}
3286
 
3287
/*
3288
 *----------------------------------------------------------------------
3289
 *
3290
 * MasterRecordDeleteProc -
3291
 *
3292
 *      Is invoked when an interpreter (which is using the "interp" facility)
3293
 *      is deleted, and it cleans up the storage associated with the
3294
 *      "tclMasterRecord" assoc-data entry.
3295
 *
3296
 * Results:
3297
 *      None.
3298
 *
3299
 * Side effects:
3300
 *      Cleans up storage.
3301
 *
3302
 *----------------------------------------------------------------------
3303
 */
3304
 
3305
static void
3306
MasterRecordDeleteProc(clientData, interp)
3307
    ClientData  clientData;             /* Master record for deleted interp. */
3308
    Tcl_Interp *interp;                 /* Interpreter being deleted. */
3309
{
3310
    Target *targetPtr;                  /* Loop variable. */
3311
    Tcl_HashEntry *hPtr;                /* Search element. */
3312
    Tcl_HashSearch hSearch;             /* Search record (internal). */
3313
    Slave *slavePtr;                    /* Loop variable. */
3314
    Master *masterPtr;                  /* Interim storage. */
3315
 
3316
    masterPtr = (Master *) clientData;
3317
    for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
3318
         hPtr != NULL;
3319
         hPtr = Tcl_NextHashEntry(&hSearch)) {
3320
        slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
3321
        (void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd);
3322
    }
3323
    Tcl_DeleteHashTable(&(masterPtr->slaveTable));
3324
 
3325
    for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch);
3326
         hPtr != NULL;
3327
         hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) {
3328
        targetPtr = (Target *) Tcl_GetHashValue(hPtr);
3329
        (void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
3330
                targetPtr->slaveCmd);
3331
    }
3332
    Tcl_DeleteHashTable(&(masterPtr->targetTable));
3333
 
3334
    ckfree((char *) masterPtr);
3335
}
3336
 
3337
/*
3338
 *----------------------------------------------------------------------
3339
 *
3340
 * SlaveRecordDeleteProc --
3341
 *
3342
 *      Is invoked when an interpreter (which is using the interp facility)
3343
 *      is deleted, and it cleans up the storage associated with the
3344
 *      tclSlaveRecord assoc-data entry.
3345
 *
3346
 * Results:
3347
 *      None
3348
 *
3349
 * Side effects:
3350
 *      Cleans up storage.
3351
 *
3352
 *----------------------------------------------------------------------
3353
 */
3354
 
3355
static void
3356
SlaveRecordDeleteProc(clientData, interp)
3357
    ClientData  clientData;             /* Slave record for deleted interp. */
3358
    Tcl_Interp *interp;                 /* Interpreter being deleted. */
3359
{
3360
    Slave *slavePtr;                    /* Interim storage. */
3361
    Alias *aliasPtr;
3362
    Tcl_HashTable *hTblPtr;
3363
    Tcl_HashEntry *hPtr;
3364
    Tcl_HashSearch hSearch;
3365
 
3366
    slavePtr = (Slave *) clientData;
3367
 
3368
    /*
3369
     * In every case that we call SetAssocData on "tclSlaveRecord",
3370
     * slavePtr is not NULL. Otherwise we panic.
3371
     */
3372
 
3373
    if (slavePtr == NULL) {
3374
        panic("SlaveRecordDeleteProc: NULL slavePtr");
3375
    }
3376
 
3377
    if (slavePtr->interpCmd != (Tcl_Command) NULL) {
3378
        Command *cmdPtr = (Command *) slavePtr->interpCmd;
3379
 
3380
        /*
3381
         * The interpCmd has not been deleted in the master yet,  since
3382
         * it's callback sets interpCmd to NULL.
3383
         *
3384
         * Probably Tcl_DeleteInterp() was called on this interpreter directly,
3385
         * rather than via "interp delete", or equivalent (deletion of the
3386
         * command in the master).
3387
         *
3388
         * Perform the cleanup done by SlaveObjectDeleteProc() directly,
3389
         * and turn off the callback now (since we are about to free slavePtr
3390
         * and this interpreter is going away, while the deletion of commands
3391
         * in the master may be deferred).
3392
         */
3393
 
3394
        Tcl_DeleteHashEntry(slavePtr->slaveEntry);
3395
        cmdPtr->clientData = NULL;
3396
        cmdPtr->deleteProc = NULL;
3397
        cmdPtr->deleteData = NULL;
3398
 
3399
        Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
3400
                slavePtr->interpCmd);
3401
    }
3402
 
3403
    /*
3404
     * If there are any aliases, delete those now. This removes any
3405
     * dependency on the order of deletion between commands and the
3406
     * slave record.
3407
     */
3408
 
3409
    hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable);
3410
    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
3411
             hPtr != (Tcl_HashEntry *) NULL;
3412
             hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
3413
        aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
3414
 
3415
        /*
3416
         * The call to Tcl_DeleteCommand will release the storage
3417
         * occupied by the hash entry and the alias record.
3418
         */
3419
 
3420
        Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd);
3421
    }
3422
 
3423
    /*
3424
     * Finally dispose of the hash table and the slave record.
3425
     */
3426
 
3427
    Tcl_DeleteHashTable(hTblPtr);
3428
    ckfree((char *) slavePtr);
3429
}
3430
 
3431
/*
3432
 *----------------------------------------------------------------------
3433
 *
3434
 * TclInterpInit --
3435
 *
3436
 *      Initializes the invoking interpreter for using the "interp"
3437
 *      facility. This is called from inside Tcl_Init.
3438
 *
3439
 * Results:
3440
 *      None.
3441
 *
3442
 * Side effects:
3443
 *      Adds the "interp" command to an interpreter and initializes several
3444
 *      records in the associated data of the invoking interpreter.
3445
 *
3446
 *----------------------------------------------------------------------
3447
 */
3448
 
3449
int
3450
TclInterpInit(interp)
3451
    Tcl_Interp *interp;                 /* Interpreter to initialize. */
3452
{
3453
    Master *masterPtr;                  /* Its Master record. */
3454
    Slave *slavePtr;                    /* And its slave record. */
3455
 
3456
    masterPtr = (Master *) ckalloc((unsigned) sizeof(Master));
3457
 
3458
    Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS);
3459
    Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS);
3460
 
3461
    (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc,
3462
            (ClientData) masterPtr);
3463
 
3464
    slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
3465
 
3466
    slavePtr->masterInterp = (Tcl_Interp *) NULL;
3467
    slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
3468
    slavePtr->slaveInterp = interp;
3469
    slavePtr->interpCmd = (Tcl_Command) NULL;
3470
    Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
3471
 
3472
    (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc,
3473
            (ClientData) slavePtr);
3474
 
3475
    return TCL_OK;
3476
}
3477
 
3478
/*
3479
 *----------------------------------------------------------------------
3480
 *
3481
 * Tcl_IsSafe --
3482
 *
3483
 *      Determines whether an interpreter is safe
3484
 *
3485
 * Results:
3486
 *      1 if it is safe, 0 if it is not.
3487
 *
3488
 * Side effects:
3489
 *      None.
3490
 *
3491
 *----------------------------------------------------------------------
3492
 */
3493
 
3494
int
3495
Tcl_IsSafe(interp)
3496
    Tcl_Interp *interp;         /* Is this interpreter "safe" ? */
3497
{
3498
    Interp *iPtr;
3499
 
3500
    if (interp == (Tcl_Interp *) NULL) {
3501
        return 0;
3502
    }
3503
    iPtr = (Interp *) interp;
3504
 
3505
    return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
3506
}
3507
 
3508
/*
3509
 *----------------------------------------------------------------------
3510
 *
3511
 * Tcl_CreateSlave --
3512
 *
3513
 *      Creates a slave interpreter. The slavePath argument denotes the
3514
 *      name of the new slave relative to the current interpreter; the
3515
 *      slave is a direct descendant of the one-before-last component of
3516
 *      the path, e.g. it is a descendant of the current interpreter if
3517
 *      the slavePath argument contains only one component. Optionally makes
3518
 *      the slave interpreter safe.
3519
 *
3520
 * Results:
3521
 *      Returns the interpreter structure created, or NULL if an error
3522
 *      occurred.
3523
 *
3524
 * Side effects:
3525
 *      Creates a new interpreter and a new interpreter object command in
3526
 *      the interpreter indicated by the slavePath argument.
3527
 *
3528
 *----------------------------------------------------------------------
3529
 */
3530
 
3531
Tcl_Interp *
3532
Tcl_CreateSlave(interp, slavePath, isSafe)
3533
    Tcl_Interp *interp;         /* Interpreter to start search at. */
3534
    char *slavePath;            /* Name of slave to create. */
3535
    int isSafe;                 /* Should new slave be "safe" ? */
3536
{
3537
    Master *masterPtr;                  /* Master record for same. */
3538
 
3539
    if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
3540
        return NULL;
3541
    }
3542
    masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
3543
            NULL);
3544
    if (masterPtr == (Master *) NULL) {
3545
        panic("CreatSlave: could not find master record");
3546
    }
3547
    return CreateSlave(interp, masterPtr, slavePath, isSafe);
3548
}
3549
 
3550
/*
3551
 *----------------------------------------------------------------------
3552
 *
3553
 * Tcl_GetSlave --
3554
 *
3555
 *      Finds a slave interpreter by its path name.
3556
 *
3557
 * Results:
3558
 *      Returns a Tcl_Interp * for the named interpreter or NULL if not
3559
 *      found.
3560
 *
3561
 * Side effects:
3562
 *      None.
3563
 *
3564
 *----------------------------------------------------------------------
3565
 */
3566
 
3567
Tcl_Interp *
3568
Tcl_GetSlave(interp, slavePath)
3569
    Tcl_Interp *interp;         /* Interpreter to start search from. */
3570
    char *slavePath;            /* Path of slave to find. */
3571
{
3572
    Master *masterPtr;          /* Interim storage for Master record. */
3573
 
3574
    if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
3575
        return NULL;
3576
    }
3577
    masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
3578
    if (masterPtr == (Master *) NULL) {
3579
        panic("Tcl_GetSlave: could not find master record");
3580
    }
3581
    return GetInterp(interp, masterPtr, slavePath, NULL);
3582
}
3583
 
3584
/*
3585
 *----------------------------------------------------------------------
3586
 *
3587
 * Tcl_GetMaster --
3588
 *
3589
 *      Finds the master interpreter of a slave interpreter.
3590
 *
3591
 * Results:
3592
 *      Returns a Tcl_Interp * for the master interpreter or NULL if none.
3593
 *
3594
 * Side effects:
3595
 *      None.
3596
 *
3597
 *----------------------------------------------------------------------
3598
 */
3599
 
3600
Tcl_Interp *
3601
Tcl_GetMaster(interp)
3602
    Tcl_Interp *interp;         /* Get the master of this interpreter. */
3603
{
3604
    Slave *slavePtr;            /* Slave record of this interpreter. */
3605
 
3606
    if (interp == (Tcl_Interp *) NULL) {
3607
        return NULL;
3608
    }
3609
    slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
3610
    if (slavePtr == (Slave *) NULL) {
3611
        return NULL;
3612
    }
3613
    return slavePtr->masterInterp;
3614
}
3615
 
3616
/*
3617
 *----------------------------------------------------------------------
3618
 *
3619
 * Tcl_CreateAlias --
3620
 *
3621
 *      Creates an alias between two interpreters.
3622
 *
3623
 * Results:
3624
 *      A standard Tcl result.
3625
 *
3626
 * Side effects:
3627
 *      Creates a new alias, manipulates the result field of slaveInterp.
3628
 *
3629
 *----------------------------------------------------------------------
3630
 */
3631
 
3632
int
3633
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
3634
    Tcl_Interp *slaveInterp;            /* Interpreter for source command. */
3635
    char *slaveCmd;                     /* Command to install in slave. */
3636
    Tcl_Interp *targetInterp;           /* Interpreter for target command. */
3637
    char *targetCmd;                    /* Name of target command. */
3638
    int argc;                           /* How many additional arguments? */
3639
    char **argv;                        /* These are the additional args. */
3640
{
3641
    Master *masterPtr;                  /* Master record for target interp. */
3642
    Tcl_Obj **objv;
3643
    int i;
3644
    int result;
3645
 
3646
    if ((slaveInterp == (Tcl_Interp *) NULL) ||
3647
            (targetInterp == (Tcl_Interp *) NULL) ||
3648
            (slaveCmd == (char *) NULL) ||
3649
            (targetCmd == (char *) NULL)) {
3650
        return TCL_ERROR;
3651
    }
3652
    masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
3653
            NULL);
3654
    if (masterPtr == (Master *) NULL) {
3655
        panic("Tcl_CreateAlias: could not find master record");
3656
    }
3657
    objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
3658
    for (i = 0; i < argc; i++) {
3659
        objv[i] = Tcl_NewStringObj(argv[i], -1);
3660
        Tcl_IncrRefCount(objv[i]);
3661
    }
3662
 
3663
    result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
3664
            masterPtr, slaveCmd, targetCmd, argc, objv);
3665
 
3666
    ckfree((char *) objv);
3667
 
3668
    return result;
3669
}
3670
 
3671
/*
3672
 *----------------------------------------------------------------------
3673
 *
3674
 * Tcl_CreateAliasObj --
3675
 *
3676
 *      Object version: Creates an alias between two interpreters.
3677
 *
3678
 * Results:
3679
 *      A standard Tcl result.
3680
 *
3681
 * Side effects:
3682
 *      Creates a new alias.
3683
 *
3684
 *----------------------------------------------------------------------
3685
 */
3686
 
3687
int
3688
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
3689
    Tcl_Interp *slaveInterp;            /* Interpreter for source command. */
3690
    char *slaveCmd;                     /* Command to install in slave. */
3691
    Tcl_Interp *targetInterp;           /* Interpreter for target command. */
3692
    char *targetCmd;                    /* Name of target command. */
3693
    int objc;                           /* How many additional arguments? */
3694
    Tcl_Obj *CONST objv[];              /* Argument vector. */
3695
{
3696
    Master *masterPtr;                  /* Master record for target interp. */
3697
 
3698
    if ((slaveInterp == (Tcl_Interp *) NULL) ||
3699
            (targetInterp == (Tcl_Interp *) NULL) ||
3700
            (slaveCmd == (char *) NULL) ||
3701
            (targetCmd == (char *) NULL)) {
3702
        return TCL_ERROR;
3703
    }
3704
    masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
3705
            NULL);
3706
    if (masterPtr == (Master *) NULL) {
3707
        panic("Tcl_CreateAlias: could not find master record");
3708
    }
3709
    return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
3710
            masterPtr, slaveCmd, targetCmd, objc, objv);
3711
}
3712
 
3713
/*
3714
 *----------------------------------------------------------------------
3715
 *
3716
 * Tcl_GetAlias --
3717
 *
3718
 *      Gets information about an alias.
3719
 *
3720
 * Results:
3721
 *      A standard Tcl result.
3722
 *
3723
 * Side effects:
3724
 *      None.
3725
 *
3726
 *----------------------------------------------------------------------
3727
 */
3728
 
3729
int
3730
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
3731
        argvPtr)
3732
    Tcl_Interp *interp;                 /* Interp to start search from. */
3733
    char *aliasName;                    /* Name of alias to find. */
3734
    Tcl_Interp **targetInterpPtr;       /* (Return) target interpreter. */
3735
    char **targetNamePtr;               /* (Return) name of target command. */
3736
    int *argcPtr;                       /* (Return) count of addnl args. */
3737
    char ***argvPtr;                    /* (Return) additional arguments. */
3738
{
3739
    Slave *slavePtr;                    /* Slave record for slave interp. */
3740
    Tcl_HashEntry *hPtr;                /* Search element. */
3741
    Alias *aliasPtr;                    /* Storage for alias found. */
3742
    int len;
3743
    int i;
3744
 
3745
    if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
3746
        return TCL_ERROR;
3747
    }
3748
    slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
3749
    if (slavePtr == (Slave *) NULL) {
3750
        panic("Tcl_GetAlias: could not find slave record");
3751
    }
3752
    hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
3753
    if (hPtr == (Tcl_HashEntry *) NULL) {
3754
        Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found",
3755
                (char *) NULL);
3756
        return TCL_ERROR;
3757
    }
3758
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
3759
    if (targetInterpPtr != (Tcl_Interp **) NULL) {
3760
        *targetInterpPtr = aliasPtr->targetInterp;
3761
    }
3762
    if (targetNamePtr != (char **) NULL) {
3763
        *targetNamePtr = aliasPtr->targetName;
3764
    }
3765
    if (argcPtr != (int *) NULL) {
3766
        *argcPtr = aliasPtr->objc;
3767
    }
3768
    if (argvPtr != (char ***) NULL) {
3769
        *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) *
3770
                aliasPtr->objc);
3771
        for (i = 0; i < aliasPtr->objc; i++) {
3772
            *argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len);
3773
        }
3774
    }
3775
    return TCL_OK;
3776
}
3777
 
3778
/*
3779
 *----------------------------------------------------------------------
3780
 *
3781
 * Tcl_ObjGetAlias --
3782
 *
3783
 *      Object version: Gets information about an alias.
3784
 *
3785
 * Results:
3786
 *      A standard Tcl result.
3787
 *
3788
 * Side effects:
3789
 *      None.
3790
 *
3791
 *----------------------------------------------------------------------
3792
 */
3793
 
3794
int
3795
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
3796
        objvPtr)
3797
    Tcl_Interp *interp;                 /* Interp to start search from. */
3798
    char *aliasName;                    /* Name of alias to find. */
3799
    Tcl_Interp **targetInterpPtr;       /* (Return) target interpreter. */
3800
    char **targetNamePtr;               /* (Return) name of target command. */
3801
    int *objcPtr;                       /* (Return) count of addnl args. */
3802
    Tcl_Obj ***objvPtr;                 /* (Return) additional args. */
3803
{
3804
    Slave *slavePtr;                    /* Slave record for slave interp. */
3805
    Tcl_HashEntry *hPtr;                /* Search element. */
3806
    Alias *aliasPtr;                    /* Storage for alias found. */
3807
 
3808
    if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
3809
        return TCL_ERROR;
3810
    }
3811
    slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
3812
    if (slavePtr == (Slave *) NULL) {
3813
        panic("Tcl_GetAlias: could not find slave record");
3814
    }
3815
    hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
3816
    if (hPtr == (Tcl_HashEntry *) NULL) {
3817
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3818
                "alias \"", aliasName, "\" not found", (char *) NULL);
3819
        return TCL_ERROR;
3820
    }
3821
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
3822
    if (targetInterpPtr != (Tcl_Interp **) NULL) {
3823
        *targetInterpPtr = aliasPtr->targetInterp;
3824
    }
3825
    if (targetNamePtr != (char **) NULL) {
3826
        *targetNamePtr = aliasPtr->targetName;
3827
    }
3828
    if (objcPtr != (int *) NULL) {
3829
        *objcPtr = aliasPtr->objc;
3830
    }
3831
    if (objvPtr != (Tcl_Obj ***) NULL) {
3832
        *objvPtr = aliasPtr->objv;
3833
    }
3834
    return TCL_OK;
3835
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.