/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (hide annotations) (download)
Sat Nov 5 11:07:06 2016 UTC (7 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 130176 byte(s)
Set EOL properties appropriately to facilitate simultaneous Linux and Windows development.
1 dashley 71 /* $Header$ */
2     /*
3     * tclBasic.c --
4     *
5     * Contains the basic facilities for TCL command interpretation,
6     * including interpreter creation and deletion, command creation
7     * and deletion, and command parsing and execution.
8     *
9     * Copyright (c) 1987-1994 The Regents of the University of California.
10     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
11     * Copyright (c) 1998-1999 by Scriptics Corporation.
12     *
13     * See the file "license.terms" for information on usage and redistribution
14     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15     *
16     * RCS: @(#) $Id: tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $
17     */
18    
19     #include "tclInt.h"
20     #include "tclCompile.h"
21     #ifndef TCL_GENERIC_ONLY
22     # include "tclPort.h"
23     #endif
24    
25     /*
26     * Static procedures in this file:
27     */
28    
29     static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
30     static void ProcessUnexpectedResult _ANSI_ARGS_((
31     Tcl_Interp *interp, int returnCode));
32     static void RecordTracebackInfo _ANSI_ARGS_((
33     Tcl_Interp *interp, Tcl_Obj *objPtr,
34     int numSrcBytes));
35    
36     extern TclStubs tclStubs;
37    
38     /*
39     * The following structure defines the commands in the Tcl core.
40     */
41    
42     typedef struct {
43     char *name; /* Name of object-based command. */
44     Tcl_CmdProc *proc; /* String-based procedure for command. */
45     Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
46     CompileProc *compileProc; /* Procedure called to compile command. */
47     int isSafe; /* If non-zero, command will be present
48     * in safe interpreter. Otherwise it will
49     * be hidden. */
50     } CmdInfo;
51    
52     /*
53     * The built-in commands, and the procedures that implement them:
54     */
55    
56     static CmdInfo builtInCmds[] = {
57     /*
58     * Commands in the generic core. Note that at least one of the proc or
59     * objProc members should be non-NULL. This avoids infinitely recursive
60     * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
61     * command name is computed at runtime and results in the name of a
62     * compiled command.
63     */
64    
65     {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
66     (CompileProc *) NULL, 1},
67     {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
68     (CompileProc *) NULL, 1},
69     {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
70     (CompileProc *) NULL, 1},
71     {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd,
72     TclCompileBreakCmd, 1},
73     {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
74     (CompileProc *) NULL, 1},
75     {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
76     TclCompileCatchCmd, 1},
77     {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
78     (CompileProc *) NULL, 1},
79     {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
80     (CompileProc *) NULL, 1},
81     {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
82     TclCompileContinueCmd, 1},
83     {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd,
84     (CompileProc *) NULL, 0},
85     {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
86     (CompileProc *) NULL, 1},
87     {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
88     (CompileProc *) NULL, 1},
89     {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
90     (CompileProc *) NULL, 0},
91     {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
92     TclCompileExprCmd, 1},
93     {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
94     (CompileProc *) NULL, 1},
95     {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd,
96     (CompileProc *) NULL, 1},
97     {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd,
98     TclCompileForCmd, 1},
99     {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
100     TclCompileForeachCmd, 1},
101     {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
102     (CompileProc *) NULL, 1},
103     {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
104     (CompileProc *) NULL, 1},
105     {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd,
106     TclCompileIfCmd, 1},
107     {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd,
108     TclCompileIncrCmd, 1},
109     {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
110     (CompileProc *) NULL, 1},
111     {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
112     (CompileProc *) NULL, 1},
113     {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
114     (CompileProc *) NULL, 1},
115     {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
116     (CompileProc *) NULL, 1},
117     {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
118     (CompileProc *) NULL, 1},
119     {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
120     (CompileProc *) NULL, 1},
121     {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
122     (CompileProc *) NULL, 1},
123     {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
124     (CompileProc *) NULL, 0},
125     {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
126     (CompileProc *) NULL, 1},
127     {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
128     (CompileProc *) NULL, 1},
129     {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
130     (CompileProc *) NULL, 1},
131     {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
132     (CompileProc *) NULL, 1},
133     {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
134     (CompileProc *) NULL, 1},
135     {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd,
136     (CompileProc *) NULL, 1},
137     {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
138     (CompileProc *) NULL, 1},
139     {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
140     (CompileProc *) NULL, 1},
141     {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
142     (CompileProc *) NULL, 1},
143     {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
144     (CompileProc *) NULL, 1},
145     {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
146     (CompileProc *) NULL, 1},
147     {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
148     (CompileProc *) NULL, 1},
149     {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
150     TclCompileSetCmd, 1},
151     {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
152     (CompileProc *) NULL, 1},
153     {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
154     (CompileProc *) NULL, 1},
155     {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
156     (CompileProc *) NULL, 1},
157     {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
158     (CompileProc *) NULL, 1},
159     {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
160     (CompileProc *) NULL, 1},
161     {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
162     (CompileProc *) NULL, 1},
163     {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
164     (CompileProc *) NULL, 1},
165     {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
166     (CompileProc *) NULL, 1},
167     {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
168     (CompileProc *) NULL, 1},
169     {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd,
170     TclCompileWhileCmd, 1},
171    
172     /*
173     * Commands in the UNIX core:
174     */
175    
176     #ifndef TCL_GENERIC_ONLY
177     {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
178     (CompileProc *) NULL, 1},
179     {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
180     (CompileProc *) NULL, 0},
181     {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
182     (CompileProc *) NULL, 1},
183     {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
184     (CompileProc *) NULL, 1},
185     {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
186     (CompileProc *) NULL, 1},
187     {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd,
188     (CompileProc *) NULL, 0},
189     {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
190     (CompileProc *) NULL, 0},
191     {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
192     (CompileProc *) NULL, 1},
193     {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
194     (CompileProc *) NULL, 1},
195     {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd,
196     (CompileProc *) NULL, 0},
197     {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd,
198     (CompileProc *) NULL, 0},
199     {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
200     (CompileProc *) NULL, 1},
201     {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
202     (CompileProc *) NULL, 1},
203     {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd,
204     (CompileProc *) NULL, 0},
205     {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
206     (CompileProc *) NULL, 1},
207     {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd,
208     (CompileProc *) NULL, 1},
209     {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd,
210     (CompileProc *) NULL, 0},
211     {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd,
212     (CompileProc *) NULL, 1},
213     {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
214     (CompileProc *) NULL, 1},
215     {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd,
216     (CompileProc *) NULL, 1},
217     {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd,
218     (CompileProc *) NULL, 1},
219    
220     #ifdef MAC_TCL
221     {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
222     (CompileProc *) NULL, 0},
223     {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
224     (CompileProc *) NULL, 0},
225     {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd,
226     (CompileProc *) NULL, 0},
227     {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
228     (CompileProc *) NULL, 1},
229     {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
230     (CompileProc *) NULL, 0},
231     #else
232     {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd,
233     (CompileProc *) NULL, 0},
234     {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
235     (CompileProc *) NULL, 0},
236     #endif /* MAC_TCL */
237    
238     #endif /* TCL_GENERIC_ONLY */
239     {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
240     (CompileProc *) NULL, 0}
241     };
242    
243    
244     /*
245     *----------------------------------------------------------------------
246     *
247     * Tcl_CreateInterp --
248     *
249     * Create a new TCL command interpreter.
250     *
251     * Results:
252     * The return value is a token for the interpreter, which may be
253     * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
254     * Tcl_DeleteInterp.
255     *
256     * Side effects:
257     * The command interpreter is initialized with an empty variable
258     * table and the built-in commands.
259     *
260     *----------------------------------------------------------------------
261     */
262    
263     Tcl_Interp *
264     Tcl_CreateInterp()
265     {
266     Interp *iPtr;
267     Tcl_Interp *interp;
268     Command *cmdPtr;
269     BuiltinFunc *builtinFuncPtr;
270     MathFunc *mathFuncPtr;
271     Tcl_HashEntry *hPtr;
272     CmdInfo *cmdInfoPtr;
273     int i;
274     union {
275     char c[sizeof(short)];
276     short s;
277     } order;
278     #ifdef TCL_COMPILE_STATS
279     ByteCodeStats *statsPtr;
280     #endif /* TCL_COMPILE_STATS */
281    
282     TclInitSubsystems(NULL);
283    
284     /*
285     * Panic if someone updated the CallFrame structure without
286     * also updating the Tcl_CallFrame structure (or vice versa).
287     */
288    
289     if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
290     /*NOTREACHED*/
291     panic("Tcl_CallFrame and CallFrame are not the same size");
292     }
293    
294     /*
295     * Initialize support for namespaces and create the global namespace
296     * (whose name is ""; an alias is "::"). This also initializes the
297     * Tcl object type table and other object management code.
298     */
299    
300     iPtr = (Interp *) ckalloc(sizeof(Interp));
301     interp = (Tcl_Interp *) iPtr;
302    
303     iPtr->result = iPtr->resultSpace;
304     iPtr->freeProc = NULL;
305     iPtr->errorLine = 0;
306     iPtr->objResultPtr = Tcl_NewObj();
307     Tcl_IncrRefCount(iPtr->objResultPtr);
308     iPtr->handle = TclHandleCreate(iPtr);
309     iPtr->globalNsPtr = NULL;
310     iPtr->hiddenCmdTablePtr = NULL;
311     iPtr->interpInfo = NULL;
312     Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
313    
314     iPtr->numLevels = 0;
315     iPtr->maxNestingDepth = 1000;
316     iPtr->framePtr = NULL;
317     iPtr->varFramePtr = NULL;
318     iPtr->activeTracePtr = NULL;
319     iPtr->returnCode = TCL_OK;
320     iPtr->errorInfo = NULL;
321     iPtr->errorCode = NULL;
322    
323     iPtr->appendResult = NULL;
324     iPtr->appendAvl = 0;
325     iPtr->appendUsed = 0;
326    
327     Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
328     iPtr->packageUnknown = NULL;
329     iPtr->cmdCount = 0;
330     iPtr->termOffset = 0;
331     TclInitLiteralTable(&(iPtr->literalTable));
332     iPtr->compileEpoch = 0;
333     iPtr->compiledProcPtr = NULL;
334     iPtr->resolverPtr = NULL;
335     iPtr->evalFlags = 0;
336     iPtr->scriptFile = NULL;
337     iPtr->flags = 0;
338     iPtr->tracePtr = NULL;
339     iPtr->assocData = (Tcl_HashTable *) NULL;
340     iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
341     iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
342     Tcl_IncrRefCount(iPtr->emptyObjPtr);
343     iPtr->resultSpace[0] = 0;
344    
345     iPtr->globalNsPtr = NULL; /* force creation of global ns below */
346     iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
347     (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
348     if (iPtr->globalNsPtr == NULL) {
349     panic("Tcl_CreateInterp: can't create global namespace");
350     }
351    
352     /*
353     * Initialize support for code compilation and execution. We call
354     * TclCreateExecEnv after initializing namespaces since it tries to
355     * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
356     * variable).
357     */
358    
359     iPtr->execEnvPtr = TclCreateExecEnv(interp);
360    
361     /*
362     * Initialize the compilation and execution statistics kept for this
363     * interpreter.
364     */
365    
366     #ifdef TCL_COMPILE_STATS
367     statsPtr = &(iPtr->stats);
368     statsPtr->numExecutions = 0;
369     statsPtr->numCompilations = 0;
370     statsPtr->numByteCodesFreed = 0;
371     (VOID *) memset(statsPtr->instructionCount, 0,
372     sizeof(statsPtr->instructionCount));
373    
374     statsPtr->totalSrcBytes = 0.0;
375     statsPtr->totalByteCodeBytes = 0.0;
376     statsPtr->currentSrcBytes = 0.0;
377     statsPtr->currentByteCodeBytes = 0.0;
378     (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
379     (VOID *) memset(statsPtr->byteCodeCount, 0,
380     sizeof(statsPtr->byteCodeCount));
381     (VOID *) memset(statsPtr->lifetimeCount, 0,
382     sizeof(statsPtr->lifetimeCount));
383    
384     statsPtr->currentInstBytes = 0.0;
385     statsPtr->currentLitBytes = 0.0;
386     statsPtr->currentExceptBytes = 0.0;
387     statsPtr->currentAuxBytes = 0.0;
388     statsPtr->currentCmdMapBytes = 0.0;
389    
390     statsPtr->numLiteralsCreated = 0;
391     statsPtr->totalLitStringBytes = 0.0;
392     statsPtr->currentLitStringBytes = 0.0;
393     (VOID *) memset(statsPtr->literalCount, 0,
394     sizeof(statsPtr->literalCount));
395     #endif /* TCL_COMPILE_STATS */
396    
397     /*
398     * Initialise the stub table pointer.
399     */
400    
401     iPtr->stubTable = &tclStubs;
402    
403    
404     /*
405     * Create the core commands. Do it here, rather than calling
406     * Tcl_CreateCommand, because it's faster (there's no need to check for
407     * a pre-existing command by the same name). If a command has a
408     * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
409     * TclInvokeStringCommand. This is an object-based wrapper procedure
410     * that extracts strings, calls the string procedure, and creates an
411     * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
412     * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
413     */
414    
415     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
416     cmdInfoPtr++) {
417     int new;
418     Tcl_HashEntry *hPtr;
419    
420     if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
421     && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
422     && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
423     panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
424     }
425    
426     hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
427     cmdInfoPtr->name, &new);
428     if (new) {
429     cmdPtr = (Command *) ckalloc(sizeof(Command));
430     cmdPtr->hPtr = hPtr;
431     cmdPtr->nsPtr = iPtr->globalNsPtr;
432     cmdPtr->refCount = 1;
433     cmdPtr->cmdEpoch = 0;
434     cmdPtr->compileProc = cmdInfoPtr->compileProc;
435     if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
436     cmdPtr->proc = TclInvokeObjectCommand;
437     cmdPtr->clientData = (ClientData) cmdPtr;
438     } else {
439     cmdPtr->proc = cmdInfoPtr->proc;
440     cmdPtr->clientData = (ClientData) NULL;
441     }
442     if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
443     cmdPtr->objProc = TclInvokeStringCommand;
444     cmdPtr->objClientData = (ClientData) cmdPtr;
445     } else {
446     cmdPtr->objProc = cmdInfoPtr->objProc;
447     cmdPtr->objClientData = (ClientData) NULL;
448     }
449     cmdPtr->deleteProc = NULL;
450     cmdPtr->deleteData = (ClientData) NULL;
451     cmdPtr->deleted = 0;
452     cmdPtr->importRefPtr = NULL;
453     Tcl_SetHashValue(hPtr, cmdPtr);
454     }
455     }
456    
457     /*
458     * Register the builtin math functions.
459     */
460    
461     i = 0;
462     for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL;
463     builtinFuncPtr++) {
464     Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
465     builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
466     (Tcl_MathProc *) NULL, (ClientData) 0);
467     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
468     builtinFuncPtr->name);
469     if (hPtr == NULL) {
470     panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
471     return NULL;
472     }
473     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
474     mathFuncPtr->builtinFuncIndex = i;
475     i++;
476     }
477     iPtr->flags |= EXPR_INITIALIZED;
478    
479     /*
480     * Do Multiple/Safe Interps Tcl init stuff
481     */
482    
483     TclInterpInit(interp);
484    
485     /*
486     * We used to create the "errorInfo" and "errorCode" global vars at this
487     * point because so much of the Tcl implementation assumes they already
488     * exist. This is not quite enough, however, since they can be unset
489     * at any time.
490     *
491     * There are 2 choices:
492     * + Check every place where a GetVar of those is used
493     * and the NULL result is not checked (like in tclLoad.c)
494     * + Make SetVar,... NULL friendly
495     * We choose the second option because :
496     * + It is easy and low cost to check for NULL pointer before
497     * calling strlen()
498     * + It can be helpfull to other people using those API
499     * + Passing a NULL value to those closest 'meaning' is empty string
500     * (specially with the new objects where 0 bytes strings are ok)
501     * So the following init is commented out: -- dl
502     *
503     * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
504     * "", TCL_GLOBAL_ONLY);
505     * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
506     * "NONE", TCL_GLOBAL_ONLY);
507     */
508    
509     #ifndef TCL_GENERIC_ONLY
510     TclSetupEnv(interp);
511     #endif
512    
513     /*
514     * Compute the byte order of this machine.
515     */
516    
517     order.s = 1;
518     Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
519     ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
520     TCL_GLOBAL_ONLY);
521    
522     /*
523     * Set up other variables such as tcl_version and tcl_library
524     */
525    
526     Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
527     Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
528     Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
529     TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
530     TclPrecTraceProc, (ClientData) NULL);
531     TclpSetVariables(interp);
532    
533     #ifdef TCL_THREADS
534     /*
535     * The existence of the "threaded" element of the tcl_platform array indicates
536     * that this particular Tcl shell has been compiled with threads turned on.
537     * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the
538     * interpreter level of thread safety.
539     */
540    
541    
542     Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
543     TCL_GLOBAL_ONLY);
544     #endif
545    
546     /*
547     * Register Tcl's version number.
548     */
549    
550     Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
551    
552     #ifdef Tcl_InitStubs
553     #undef Tcl_InitStubs
554     #endif
555     Tcl_InitStubs(interp, TCL_VERSION, 1);
556    
557     return interp;
558     }
559    
560     /*
561     *----------------------------------------------------------------------
562     *
563     * TclHideUnsafeCommands --
564     *
565     * Hides base commands that are not marked as safe from this
566     * interpreter.
567     *
568     * Results:
569     * TCL_OK if it succeeds, TCL_ERROR else.
570     *
571     * Side effects:
572     * Hides functionality in an interpreter.
573     *
574     *----------------------------------------------------------------------
575     */
576    
577     int
578     TclHideUnsafeCommands(interp)
579     Tcl_Interp *interp; /* Hide commands in this interpreter. */
580     {
581     register CmdInfo *cmdInfoPtr;
582    
583     if (interp == (Tcl_Interp *) NULL) {
584     return TCL_ERROR;
585     }
586     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
587     if (!cmdInfoPtr->isSafe) {
588     Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
589     }
590     }
591     return TCL_OK;
592     }
593    
594     /*
595     *--------------------------------------------------------------
596     *
597     * Tcl_CallWhenDeleted --
598     *
599     * Arrange for a procedure to be called before a given
600     * interpreter is deleted. The procedure is called as soon
601     * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
602     * called on an interpreter that has already been deleted,
603     * the procedure will be called when the last Tcl_Release is
604     * done on the interpreter.
605     *
606     * Results:
607     * None.
608     *
609     * Side effects:
610     * When Tcl_DeleteInterp is invoked to delete interp,
611     * proc will be invoked. See the manual entry for
612     * details.
613     *
614     *--------------------------------------------------------------
615     */
616    
617     void
618     Tcl_CallWhenDeleted(interp, proc, clientData)
619     Tcl_Interp *interp; /* Interpreter to watch. */
620     Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
621     * is about to be deleted. */
622     ClientData clientData; /* One-word value to pass to proc. */
623     {
624     Interp *iPtr = (Interp *) interp;
625     static int assocDataCounter = 0;
626     #ifdef TCL_THREADS
627     static Tcl_Mutex assocMutex;
628     #endif
629     int new;
630     char buffer[32 + TCL_INTEGER_SPACE];
631     AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
632     Tcl_HashEntry *hPtr;
633    
634     Tcl_MutexLock(&assocMutex);
635     sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
636     assocDataCounter++;
637     Tcl_MutexUnlock(&assocMutex);
638    
639     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
640     iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
641     Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
642     }
643     hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
644     dPtr->proc = proc;
645     dPtr->clientData = clientData;
646     Tcl_SetHashValue(hPtr, dPtr);
647     }
648    
649     /*
650     *--------------------------------------------------------------
651     *
652     * Tcl_DontCallWhenDeleted --
653     *
654     * Cancel the arrangement for a procedure to be called when
655     * a given interpreter is deleted.
656     *
657     * Results:
658     * None.
659     *
660     * Side effects:
661     * If proc and clientData were previously registered as a
662     * callback via Tcl_CallWhenDeleted, they are unregistered.
663     * If they weren't previously registered then nothing
664     * happens.
665     *
666     *--------------------------------------------------------------
667     */
668    
669     void
670     Tcl_DontCallWhenDeleted(interp, proc, clientData)
671     Tcl_Interp *interp; /* Interpreter to watch. */
672     Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
673     * is about to be deleted. */
674     ClientData clientData; /* One-word value to pass to proc. */
675     {
676     Interp *iPtr = (Interp *) interp;
677     Tcl_HashTable *hTablePtr;
678     Tcl_HashSearch hSearch;
679     Tcl_HashEntry *hPtr;
680     AssocData *dPtr;
681    
682     hTablePtr = iPtr->assocData;
683     if (hTablePtr == (Tcl_HashTable *) NULL) {
684     return;
685     }
686     for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
687     hPtr = Tcl_NextHashEntry(&hSearch)) {
688     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
689     if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
690     ckfree((char *) dPtr);
691     Tcl_DeleteHashEntry(hPtr);
692     return;
693     }
694     }
695     }
696    
697     /*
698     *----------------------------------------------------------------------
699     *
700     * Tcl_SetAssocData --
701     *
702     * Creates a named association between user-specified data, a delete
703     * function and this interpreter. If the association already exists
704     * the data is overwritten with the new data. The delete function will
705     * be invoked when the interpreter is deleted.
706     *
707     * Results:
708     * None.
709     *
710     * Side effects:
711     * Sets the associated data, creates the association if needed.
712     *
713     *----------------------------------------------------------------------
714     */
715    
716     void
717     Tcl_SetAssocData(interp, name, proc, clientData)
718     Tcl_Interp *interp; /* Interpreter to associate with. */
719     char *name; /* Name for association. */
720     Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
721     * about to be deleted. */
722     ClientData clientData; /* One-word value to pass to proc. */
723     {
724     Interp *iPtr = (Interp *) interp;
725     AssocData *dPtr;
726     Tcl_HashEntry *hPtr;
727     int new;
728    
729     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
730     iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
731     Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
732     }
733     hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
734     if (new == 0) {
735     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
736     } else {
737     dPtr = (AssocData *) ckalloc(sizeof(AssocData));
738     }
739     dPtr->proc = proc;
740     dPtr->clientData = clientData;
741    
742     Tcl_SetHashValue(hPtr, dPtr);
743     }
744    
745     /*
746     *----------------------------------------------------------------------
747     *
748     * Tcl_DeleteAssocData --
749     *
750     * Deletes a named association of user-specified data with
751     * the specified interpreter.
752     *
753     * Results:
754     * None.
755     *
756     * Side effects:
757     * Deletes the association.
758     *
759     *----------------------------------------------------------------------
760     */
761    
762     void
763     Tcl_DeleteAssocData(interp, name)
764     Tcl_Interp *interp; /* Interpreter to associate with. */
765     char *name; /* Name of association. */
766     {
767     Interp *iPtr = (Interp *) interp;
768     AssocData *dPtr;
769     Tcl_HashEntry *hPtr;
770    
771     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
772     return;
773     }
774     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
775     if (hPtr == (Tcl_HashEntry *) NULL) {
776     return;
777     }
778     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
779     if (dPtr->proc != NULL) {
780     (dPtr->proc) (dPtr->clientData, interp);
781     }
782     ckfree((char *) dPtr);
783     Tcl_DeleteHashEntry(hPtr);
784     }
785    
786     /*
787     *----------------------------------------------------------------------
788     *
789     * Tcl_GetAssocData --
790     *
791     * Returns the client data associated with this name in the
792     * specified interpreter.
793     *
794     * Results:
795     * The client data in the AssocData record denoted by the named
796     * association, or NULL.
797     *
798     * Side effects:
799     * None.
800     *
801     *----------------------------------------------------------------------
802     */
803    
804     ClientData
805     Tcl_GetAssocData(interp, name, procPtr)
806     Tcl_Interp *interp; /* Interpreter associated with. */
807     char *name; /* Name of association. */
808     Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
809     * of current deletion callback. */
810     {
811     Interp *iPtr = (Interp *) interp;
812     AssocData *dPtr;
813     Tcl_HashEntry *hPtr;
814    
815     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
816     return (ClientData) NULL;
817     }
818     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
819     if (hPtr == (Tcl_HashEntry *) NULL) {
820     return (ClientData) NULL;
821     }
822     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
823     if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
824     *procPtr = dPtr->proc;
825     }
826     return dPtr->clientData;
827     }
828    
829     /*
830     *----------------------------------------------------------------------
831     *
832     * Tcl_InterpDeleted --
833     *
834     * Returns nonzero if the interpreter has been deleted with a call
835     * to Tcl_DeleteInterp.
836     *
837     * Results:
838     * Nonzero if the interpreter is deleted, zero otherwise.
839     *
840     * Side effects:
841     * None.
842     *
843     *----------------------------------------------------------------------
844     */
845    
846     int
847     Tcl_InterpDeleted(interp)
848     Tcl_Interp *interp;
849     {
850     return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
851     }
852    
853     /*
854     *----------------------------------------------------------------------
855     *
856     * Tcl_DeleteInterp --
857     *
858     * Ensures that the interpreter will be deleted eventually. If there
859     * are no Tcl_Preserve calls in effect for this interpreter, it is
860     * deleted immediately, otherwise the interpreter is deleted when
861     * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
862     * case, the procedure runs the currently registered deletion callbacks.
863     *
864     * Results:
865     * None.
866     *
867     * Side effects:
868     * The interpreter is marked as deleted. The caller may still use it
869     * safely if there are calls to Tcl_Preserve in effect for the
870     * interpreter, but further calls to Tcl_Eval etc in this interpreter
871     * will fail.
872     *
873     *----------------------------------------------------------------------
874     */
875    
876     void
877     Tcl_DeleteInterp(interp)
878     Tcl_Interp *interp; /* Token for command interpreter (returned
879     * by a previous call to Tcl_CreateInterp). */
880     {
881     Interp *iPtr = (Interp *) interp;
882    
883     /*
884     * If the interpreter has already been marked deleted, just punt.
885     */
886    
887     if (iPtr->flags & DELETED) {
888     return;
889     }
890    
891     /*
892     * Mark the interpreter as deleted. No further evals will be allowed.
893     */
894    
895     iPtr->flags |= DELETED;
896    
897     /*
898     * Ensure that the interpreter is eventually deleted.
899     */
900    
901     Tcl_EventuallyFree((ClientData) interp,
902     (Tcl_FreeProc *) DeleteInterpProc);
903     }
904    
905     /*
906     *----------------------------------------------------------------------
907     *
908     * DeleteInterpProc --
909     *
910     * Helper procedure to delete an interpreter. This procedure is
911     * called when the last call to Tcl_Preserve on this interpreter
912     * is matched by a call to Tcl_Release. The procedure cleans up
913     * all resources used in the interpreter and calls all currently
914     * registered interpreter deletion callbacks.
915     *
916     * Results:
917     * None.
918     *
919     * Side effects:
920     * Whatever the interpreter deletion callbacks do. Frees resources
921     * used by the interpreter.
922     *
923     *----------------------------------------------------------------------
924     */
925    
926     static void
927     DeleteInterpProc(interp)
928     Tcl_Interp *interp; /* Interpreter to delete. */
929     {
930     Interp *iPtr = (Interp *) interp;
931     Tcl_HashEntry *hPtr;
932     Tcl_HashSearch search;
933     Tcl_HashTable *hTablePtr;
934     ResolverScheme *resPtr, *nextResPtr;
935    
936     /*
937     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
938     */
939    
940     if (iPtr->numLevels > 0) {
941     panic("DeleteInterpProc called with active evals");
942     }
943    
944     /*
945     * The interpreter should already be marked deleted; otherwise how
946     * did we get here?
947     */
948    
949     if (!(iPtr->flags & DELETED)) {
950     panic("DeleteInterpProc called on interpreter not marked deleted");
951     }
952    
953     TclHandleFree(iPtr->handle);
954    
955     /*
956     * Dismantle everything in the global namespace except for the
957     * "errorInfo" and "errorCode" variables. These remain until the
958     * namespace is actually destroyed, in case any errors occur.
959     *
960     * Dismantle the namespace here, before we clear the assocData. If any
961     * background errors occur here, they will be deleted below.
962     */
963    
964     TclTeardownNamespace(iPtr->globalNsPtr);
965    
966     /*
967     * Delete all the hidden commands.
968     */
969    
970     hTablePtr = iPtr->hiddenCmdTablePtr;
971     if (hTablePtr != NULL) {
972     /*
973     * Non-pernicious deletion. The deletion callbacks will not be
974     * allowed to create any new hidden or non-hidden commands.
975     * Tcl_DeleteCommandFromToken() will remove the entry from the
976     * hiddenCmdTablePtr.
977     */
978    
979     hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
980     for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
981     Tcl_DeleteCommandFromToken(interp,
982     (Tcl_Command) Tcl_GetHashValue(hPtr));
983     }
984     Tcl_DeleteHashTable(hTablePtr);
985     ckfree((char *) hTablePtr);
986     }
987     /*
988     * Tear down the math function table.
989     */
990    
991     for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
992     hPtr != NULL;
993     hPtr = Tcl_NextHashEntry(&search)) {
994     ckfree((char *) Tcl_GetHashValue(hPtr));
995     }
996     Tcl_DeleteHashTable(&iPtr->mathFuncTable);
997    
998     /*
999     * Invoke deletion callbacks; note that a callback can create new
1000     * callbacks, so we iterate.
1001     */
1002    
1003     while (iPtr->assocData != (Tcl_HashTable *) NULL) {
1004     AssocData *dPtr;
1005    
1006     hTablePtr = iPtr->assocData;
1007     iPtr->assocData = (Tcl_HashTable *) NULL;
1008     for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
1009     hPtr != NULL;
1010     hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
1011     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1012     Tcl_DeleteHashEntry(hPtr);
1013     if (dPtr->proc != NULL) {
1014     (*dPtr->proc)(dPtr->clientData, interp);
1015     }
1016     ckfree((char *) dPtr);
1017     }
1018     Tcl_DeleteHashTable(hTablePtr);
1019     ckfree((char *) hTablePtr);
1020     }
1021    
1022     /*
1023     * Finish deleting the global namespace.
1024     */
1025    
1026     Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
1027    
1028     /*
1029     * Free up the result *after* deleting variables, since variable
1030     * deletion could have transferred ownership of the result string
1031     * to Tcl.
1032     */
1033    
1034     Tcl_FreeResult(interp);
1035     interp->result = NULL;
1036     Tcl_DecrRefCount(iPtr->objResultPtr);
1037     iPtr->objResultPtr = NULL;
1038     if (iPtr->errorInfo != NULL) {
1039     ckfree(iPtr->errorInfo);
1040     iPtr->errorInfo = NULL;
1041     }
1042     if (iPtr->errorCode != NULL) {
1043     ckfree(iPtr->errorCode);
1044     iPtr->errorCode = NULL;
1045     }
1046     if (iPtr->appendResult != NULL) {
1047     ckfree(iPtr->appendResult);
1048     iPtr->appendResult = NULL;
1049     }
1050     TclFreePackageInfo(iPtr);
1051     while (iPtr->tracePtr != NULL) {
1052     Trace *nextPtr = iPtr->tracePtr->nextPtr;
1053    
1054     ckfree((char *) iPtr->tracePtr);
1055     iPtr->tracePtr = nextPtr;
1056     }
1057     if (iPtr->execEnvPtr != NULL) {
1058     TclDeleteExecEnv(iPtr->execEnvPtr);
1059     }
1060     Tcl_DecrRefCount(iPtr->emptyObjPtr);
1061     iPtr->emptyObjPtr = NULL;
1062    
1063     resPtr = iPtr->resolverPtr;
1064     while (resPtr) {
1065     nextResPtr = resPtr->nextPtr;
1066     ckfree(resPtr->name);
1067     ckfree((char *) resPtr);
1068     resPtr = nextResPtr;
1069     }
1070    
1071     /*
1072     * Free up literal objects created for scripts compiled by the
1073     * interpreter.
1074     */
1075    
1076     TclDeleteLiteralTable(interp, &(iPtr->literalTable));
1077     ckfree((char *) iPtr);
1078     }
1079    
1080     /*
1081     *---------------------------------------------------------------------------
1082     *
1083     * Tcl_HideCommand --
1084     *
1085     * Makes a command hidden so that it cannot be invoked from within
1086     * an interpreter, only from within an ancestor.
1087     *
1088     * Results:
1089     * A standard Tcl result; also leaves a message in the interp's result
1090     * if an error occurs.
1091     *
1092     * Side effects:
1093     * Removes a command from the command table and create an entry
1094     * into the hidden command table under the specified token name.
1095     *
1096     *---------------------------------------------------------------------------
1097     */
1098    
1099     int
1100     Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
1101     Tcl_Interp *interp; /* Interpreter in which to hide command. */
1102     char *cmdName; /* Name of command to hide. */
1103     char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
1104     {
1105     Interp *iPtr = (Interp *) interp;
1106     Tcl_Command cmd;
1107     Command *cmdPtr;
1108     Tcl_HashTable *hiddenCmdTablePtr;
1109     Tcl_HashEntry *hPtr;
1110     int new;
1111    
1112     if (iPtr->flags & DELETED) {
1113    
1114     /*
1115     * The interpreter is being deleted. Do not create any new
1116     * structures, because it is not safe to modify the interpreter.
1117     */
1118    
1119     return TCL_ERROR;
1120     }
1121    
1122     /*
1123     * Disallow hiding of commands that are currently in a namespace or
1124     * renaming (as part of hiding) into a namespace.
1125     *
1126     * (because the current implementation with a single global table
1127     * and the needed uniqueness of names cause problems with namespaces)
1128     *
1129     * we don't need to check for "::" in cmdName because the real check is
1130     * on the nsPtr below.
1131     *
1132     * hiddenCmdToken is just a string which is not interpreted in any way.
1133     * It may contain :: but the string is not interpreted as a namespace
1134     * qualifier command name. Thus, hiding foo::bar to foo::bar and then
1135     * trying to expose or invoke ::foo::bar will NOT work; but if the
1136     * application always uses the same strings it will get consistent
1137     * behaviour.
1138     *
1139     * But as we currently limit ourselves to the global namespace only
1140     * for the source, in order to avoid potential confusion,
1141     * lets prevent "::" in the token too. --dl
1142     */
1143    
1144     if (strstr(hiddenCmdToken, "::") != NULL) {
1145     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1146     "cannot use namespace qualifiers as hidden command",
1147     "token (rename)", (char *) NULL);
1148     return TCL_ERROR;
1149     }
1150    
1151     /*
1152     * Find the command to hide. An error is returned if cmdName can't
1153     * be found. Look up the command only from the global namespace.
1154     * Full path of the command must be given if using namespaces.
1155     */
1156    
1157     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1158     /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
1159     if (cmd == (Tcl_Command) NULL) {
1160     return TCL_ERROR;
1161     }
1162     cmdPtr = (Command *) cmd;
1163    
1164     /*
1165     * Check that the command is really in global namespace
1166     */
1167    
1168     if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1169     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1170     "can only hide global namespace commands",
1171     " (use rename then hide)", (char *) NULL);
1172     return TCL_ERROR;
1173     }
1174    
1175     /*
1176     * Initialize the hidden command table if necessary.
1177     */
1178    
1179     hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1180     if (hiddenCmdTablePtr == NULL) {
1181     hiddenCmdTablePtr = (Tcl_HashTable *)
1182     ckalloc((unsigned) sizeof(Tcl_HashTable));
1183     Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
1184     iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
1185     }
1186    
1187     /*
1188     * It is an error to move an exposed command to a hidden command with
1189     * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
1190     * exists.
1191     */
1192    
1193     hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
1194     if (!new) {
1195     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1196     "hidden command named \"", hiddenCmdToken, "\" already exists",
1197     (char *) NULL);
1198     return TCL_ERROR;
1199     }
1200    
1201     /*
1202     * Nb : This code is currently 'like' a rename to a specialy set apart
1203     * name table. Changes here and in TclRenameCommand must
1204     * be kept in synch untill the common parts are actually
1205     * factorized out.
1206     */
1207    
1208     /*
1209     * Remove the hash entry for the command from the interpreter command
1210     * table. This is like deleting the command, so bump its command epoch;
1211     * this invalidates any cached references that point to the command.
1212     */
1213    
1214     if (cmdPtr->hPtr != NULL) {
1215     Tcl_DeleteHashEntry(cmdPtr->hPtr);
1216     cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
1217     cmdPtr->cmdEpoch++;
1218     }
1219    
1220     /*
1221     * Now link the hash table entry with the command structure.
1222     * We ensured above that the nsPtr was right.
1223     */
1224    
1225     cmdPtr->hPtr = hPtr;
1226     Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1227    
1228     /*
1229     * If the command being hidden has a compile procedure, increment the
1230     * interpreter's compileEpoch to invalidate its compiled code. This
1231     * makes sure that we don't later try to execute old code compiled with
1232     * command-specific (i.e., inline) bytecodes for the now-hidden
1233     * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
1234     * and code whose compilation epoch doesn't match is recompiled.
1235     */
1236    
1237     if (cmdPtr->compileProc != NULL) {
1238     iPtr->compileEpoch++;
1239     }
1240     return TCL_OK;
1241     }
1242    
1243     /*
1244     *----------------------------------------------------------------------
1245     *
1246     * Tcl_ExposeCommand --
1247     *
1248     * Makes a previously hidden command callable from inside the
1249     * interpreter instead of only by its ancestors.
1250     *
1251     * Results:
1252     * A standard Tcl result. If an error occurs, a message is left
1253     * in the interp's result.
1254     *
1255     * Side effects:
1256     * Moves commands from one hash table to another.
1257     *
1258     *----------------------------------------------------------------------
1259     */
1260    
1261     int
1262     Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
1263     Tcl_Interp *interp; /* Interpreter in which to make command
1264     * callable. */
1265     char *hiddenCmdToken; /* Name of hidden command. */
1266     char *cmdName; /* Name of to-be-exposed command. */
1267     {
1268     Interp *iPtr = (Interp *) interp;
1269     Command *cmdPtr;
1270     Namespace *nsPtr;
1271     Tcl_HashEntry *hPtr;
1272     Tcl_HashTable *hiddenCmdTablePtr;
1273     int new;
1274    
1275     if (iPtr->flags & DELETED) {
1276     /*
1277     * The interpreter is being deleted. Do not create any new
1278     * structures, because it is not safe to modify the interpreter.
1279     */
1280    
1281     return TCL_ERROR;
1282     }
1283    
1284     /*
1285     * Check that we have a regular name for the command
1286     * (that the user is not trying to do an expose and a rename
1287     * (to another namespace) at the same time)
1288     */
1289    
1290     if (strstr(cmdName, "::") != NULL) {
1291     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1292     "can not expose to a namespace ",
1293     "(use expose to toplevel, then rename)",
1294     (char *) NULL);
1295     return TCL_ERROR;
1296     }
1297    
1298     /*
1299     * Get the command from the hidden command table:
1300     */
1301    
1302     hPtr = NULL;
1303     hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1304     if (hiddenCmdTablePtr != NULL) {
1305     hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
1306     }
1307     if (hPtr == (Tcl_HashEntry *) NULL) {
1308     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1309     "unknown hidden command \"", hiddenCmdToken,
1310     "\"", (char *) NULL);
1311     return TCL_ERROR;
1312     }
1313     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1314    
1315    
1316     /*
1317     * Check that we have a true global namespace
1318     * command (enforced by Tcl_HideCommand() but let's double
1319     * check. (If it was not, we would not really know how to
1320     * handle it).
1321     */
1322     if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1323     /*
1324     * This case is theoritically impossible,
1325     * we might rather panic() than 'nicely' erroring out ?
1326     */
1327     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1328     "trying to expose a non global command name space command",
1329     (char *) NULL);
1330     return TCL_ERROR;
1331     }
1332    
1333     /* This is the global table */
1334     nsPtr = cmdPtr->nsPtr;
1335    
1336     /*
1337     * It is an error to overwrite an existing exposed command as a result
1338     * of exposing a previously hidden command.
1339     */
1340    
1341     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
1342     if (!new) {
1343     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1344     "exposed command \"", cmdName,
1345     "\" already exists", (char *) NULL);
1346     return TCL_ERROR;
1347     }
1348    
1349     /*
1350     * Remove the hash entry for the command from the interpreter hidden
1351     * command table.
1352     */
1353    
1354     if (cmdPtr->hPtr != NULL) {
1355     Tcl_DeleteHashEntry(cmdPtr->hPtr);
1356     cmdPtr->hPtr = NULL;
1357     }
1358    
1359     /*
1360     * Now link the hash table entry with the command structure.
1361     * This is like creating a new command, so deal with any shadowing
1362     * of commands in the global namespace.
1363     */
1364    
1365     cmdPtr->hPtr = hPtr;
1366    
1367     Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1368    
1369     /*
1370     * Not needed as we are only in the global namespace
1371     * (but would be needed again if we supported namespace command hiding)
1372     *
1373     * TclResetShadowedCmdRefs(interp, cmdPtr);
1374     */
1375    
1376    
1377     /*
1378     * If the command being exposed has a compile procedure, increment
1379     * interpreter's compileEpoch to invalidate its compiled code. This
1380     * makes sure that we don't later try to execute old code compiled
1381     * assuming the command is hidden. This field is checked in Tcl_EvalObj
1382     * and ObjInterpProc, and code whose compilation epoch doesn't match is
1383     * recompiled.
1384     */
1385    
1386     if (cmdPtr->compileProc != NULL) {
1387     iPtr->compileEpoch++;
1388     }
1389     return TCL_OK;
1390     }
1391    
1392     /*
1393     *----------------------------------------------------------------------
1394     *
1395     * Tcl_CreateCommand --
1396     *
1397     * Define a new command in a command table.
1398     *
1399     * Results:
1400     * The return value is a token for the command, which can
1401     * be used in future calls to Tcl_GetCommandName.
1402     *
1403     * Side effects:
1404     * If a command named cmdName already exists for interp, it is deleted.
1405     * In the future, when cmdName is seen as the name of a command by
1406     * Tcl_Eval, proc will be called. To support the bytecode interpreter,
1407     * the command is created with a wrapper Tcl_ObjCmdProc
1408     * (TclInvokeStringCommand) that eventially calls proc. When the
1409     * command is deleted from the table, deleteProc will be called.
1410     * See the manual entry for details on the calling sequence.
1411     *
1412     *----------------------------------------------------------------------
1413     */
1414    
1415     Tcl_Command
1416     Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
1417     Tcl_Interp *interp; /* Token for command interpreter returned by
1418     * a previous call to Tcl_CreateInterp. */
1419     char *cmdName; /* Name of command. If it contains namespace
1420     * qualifiers, the new command is put in the
1421     * specified namespace; otherwise it is put
1422     * in the global namespace. */
1423     Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
1424     ClientData clientData; /* Arbitrary value passed to string proc. */
1425     Tcl_CmdDeleteProc *deleteProc;
1426     /* If not NULL, gives a procedure to call
1427     * when this command is deleted. */
1428     {
1429     Interp *iPtr = (Interp *) interp;
1430     ImportRef *oldRefPtr = NULL;
1431     Namespace *nsPtr, *dummy1, *dummy2;
1432     Command *cmdPtr, *refCmdPtr;
1433     Tcl_HashEntry *hPtr;
1434     char *tail;
1435     int new;
1436     ImportedCmdData *dataPtr;
1437    
1438     if (iPtr->flags & DELETED) {
1439     /*
1440     * The interpreter is being deleted. Don't create any new
1441     * commands; it's not safe to muck with the interpreter anymore.
1442     */
1443    
1444     return (Tcl_Command) NULL;
1445     }
1446    
1447     /*
1448     * Determine where the command should reside. If its name contains
1449     * namespace qualifiers, we put it in the specified namespace;
1450     * otherwise, we always put it in the global namespace.
1451     */
1452    
1453     if (strstr(cmdName, "::") != NULL) {
1454     TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1455     CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1456     if ((nsPtr == NULL) || (tail == NULL)) {
1457     return (Tcl_Command) NULL;
1458     }
1459     } else {
1460     nsPtr = iPtr->globalNsPtr;
1461     tail = cmdName;
1462     }
1463    
1464     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1465     if (!new) {
1466     /*
1467     * Command already exists. Delete the old one.
1468     * Be careful to preserve any existing import links so we can
1469     * restore them down below. That way, you can redefine a
1470     * command and its import status will remain intact.
1471     */
1472    
1473     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1474     oldRefPtr = cmdPtr->importRefPtr;
1475     cmdPtr->importRefPtr = NULL;
1476    
1477     Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1478     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1479     if (!new) {
1480     /*
1481     * If the deletion callback recreated the command, just throw
1482     * away the new command (if we try to delete it again, we
1483     * could get stuck in an infinite loop).
1484     */
1485    
1486     ckfree((char*) Tcl_GetHashValue(hPtr));
1487     }
1488     }
1489     cmdPtr = (Command *) ckalloc(sizeof(Command));
1490     Tcl_SetHashValue(hPtr, cmdPtr);
1491     cmdPtr->hPtr = hPtr;
1492     cmdPtr->nsPtr = nsPtr;
1493     cmdPtr->refCount = 1;
1494     cmdPtr->cmdEpoch = 0;
1495     cmdPtr->compileProc = (CompileProc *) NULL;
1496     cmdPtr->objProc = TclInvokeStringCommand;
1497     cmdPtr->objClientData = (ClientData) cmdPtr;
1498     cmdPtr->proc = proc;
1499     cmdPtr->clientData = clientData;
1500     cmdPtr->deleteProc = deleteProc;
1501     cmdPtr->deleteData = clientData;
1502     cmdPtr->deleted = 0;
1503     cmdPtr->importRefPtr = NULL;
1504    
1505     /*
1506     * Plug in any existing import references found above. Be sure
1507     * to update all of these references to point to the new command.
1508     */
1509    
1510     if (oldRefPtr != NULL) {
1511     cmdPtr->importRefPtr = oldRefPtr;
1512     while (oldRefPtr != NULL) {
1513     refCmdPtr = oldRefPtr->importedCmdPtr;
1514     dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1515     dataPtr->realCmdPtr = cmdPtr;
1516     oldRefPtr = oldRefPtr->nextPtr;
1517     }
1518     }
1519    
1520     /*
1521     * We just created a command, so in its namespace and all of its parent
1522     * namespaces, it may shadow global commands with the same name. If any
1523     * shadowed commands are found, invalidate all cached command references
1524     * in the affected namespaces.
1525     */
1526    
1527     TclResetShadowedCmdRefs(interp, cmdPtr);
1528     return (Tcl_Command) cmdPtr;
1529     }
1530    
1531     /*
1532     *----------------------------------------------------------------------
1533     *
1534     * Tcl_CreateObjCommand --
1535     *
1536     * Define a new object-based command in a command table.
1537     *
1538     * Results:
1539     * The return value is a token for the command, which can
1540     * be used in future calls to Tcl_GetCommandName.
1541     *
1542     * Side effects:
1543     * If no command named "cmdName" already exists for interp, one is
1544     * created. Otherwise, if a command does exist, then if the
1545     * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
1546     * Tcl_CreateCommand was called previously for the same command and
1547     * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
1548     * delete the old command.
1549     *
1550     * In the future, during bytecode evaluation when "cmdName" is seen as
1551     * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
1552     * Tcl_ObjCmdProc proc will be called. When the command is deleted from
1553     * the table, deleteProc will be called. See the manual entry for
1554     * details on the calling sequence.
1555     *
1556     *----------------------------------------------------------------------
1557     */
1558    
1559     Tcl_Command
1560     Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
1561     Tcl_Interp *interp; /* Token for command interpreter (returned
1562     * by previous call to Tcl_CreateInterp). */
1563     char *cmdName; /* Name of command. If it contains namespace
1564     * qualifiers, the new command is put in the
1565     * specified namespace; otherwise it is put
1566     * in the global namespace. */
1567     Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
1568     * name. */
1569     ClientData clientData; /* Arbitrary value to pass to object
1570     * procedure. */
1571     Tcl_CmdDeleteProc *deleteProc;
1572     /* If not NULL, gives a procedure to call
1573     * when this command is deleted. */
1574     {
1575     Interp *iPtr = (Interp *) interp;
1576     ImportRef *oldRefPtr = NULL;
1577     Namespace *nsPtr, *dummy1, *dummy2;
1578     Command *cmdPtr, *refCmdPtr;
1579     Tcl_HashEntry *hPtr;
1580     char *tail;
1581     int new;
1582     ImportedCmdData *dataPtr;
1583    
1584     if (iPtr->flags & DELETED) {
1585     /*
1586     * The interpreter is being deleted. Don't create any new
1587     * commands; it's not safe to muck with the interpreter anymore.
1588     */
1589    
1590     return (Tcl_Command) NULL;
1591     }
1592    
1593     /*
1594     * Determine where the command should reside. If its name contains
1595     * namespace qualifiers, we put it in the specified namespace;
1596     * otherwise, we always put it in the global namespace.
1597     */
1598    
1599     if (strstr(cmdName, "::") != NULL) {
1600     TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1601     CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1602     if ((nsPtr == NULL) || (tail == NULL)) {
1603     return (Tcl_Command) NULL;
1604     }
1605     } else {
1606     nsPtr = iPtr->globalNsPtr;
1607     tail = cmdName;
1608     }
1609    
1610     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1611     if (!new) {
1612     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1613    
1614     /*
1615     * Command already exists. If its object-based Tcl_ObjCmdProc is
1616     * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
1617     * argument "proc". Otherwise, we delete the old command.
1618     */
1619    
1620     if (cmdPtr->objProc == TclInvokeStringCommand) {
1621     cmdPtr->objProc = proc;
1622     cmdPtr->objClientData = clientData;
1623     cmdPtr->deleteProc = deleteProc;
1624     cmdPtr->deleteData = clientData;
1625     return (Tcl_Command) cmdPtr;
1626     }
1627    
1628     /*
1629     * Otherwise, we delete the old command. Be careful to preserve
1630     * any existing import links so we can restore them down below.
1631     * That way, you can redefine a command and its import status
1632     * will remain intact.
1633     */
1634    
1635     oldRefPtr = cmdPtr->importRefPtr;
1636     cmdPtr->importRefPtr = NULL;
1637    
1638     Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1639     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1640     if (!new) {
1641     /*
1642     * If the deletion callback recreated the command, just throw
1643     * away the new command (if we try to delete it again, we
1644     * could get stuck in an infinite loop).
1645     */
1646    
1647     ckfree((char *) Tcl_GetHashValue(hPtr));
1648     }
1649     }
1650     cmdPtr = (Command *) ckalloc(sizeof(Command));
1651     Tcl_SetHashValue(hPtr, cmdPtr);
1652     cmdPtr->hPtr = hPtr;
1653     cmdPtr->nsPtr = nsPtr;
1654     cmdPtr->refCount = 1;
1655     cmdPtr->cmdEpoch = 0;
1656     cmdPtr->compileProc = (CompileProc *) NULL;
1657     cmdPtr->objProc = proc;
1658     cmdPtr->objClientData = clientData;
1659     cmdPtr->proc = TclInvokeObjectCommand;
1660     cmdPtr->clientData = (ClientData) cmdPtr;
1661     cmdPtr->deleteProc = deleteProc;
1662     cmdPtr->deleteData = clientData;
1663     cmdPtr->deleted = 0;
1664     cmdPtr->importRefPtr = NULL;
1665    
1666     /*
1667     * Plug in any existing import references found above. Be sure
1668     * to update all of these references to point to the new command.
1669     */
1670    
1671     if (oldRefPtr != NULL) {
1672     cmdPtr->importRefPtr = oldRefPtr;
1673     while (oldRefPtr != NULL) {
1674     refCmdPtr = oldRefPtr->importedCmdPtr;
1675     dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1676     dataPtr->realCmdPtr = cmdPtr;
1677     oldRefPtr = oldRefPtr->nextPtr;
1678     }
1679     }
1680    
1681     /*
1682     * We just created a command, so in its namespace and all of its parent
1683     * namespaces, it may shadow global commands with the same name. If any
1684     * shadowed commands are found, invalidate all cached command references
1685     * in the affected namespaces.
1686     */
1687    
1688     TclResetShadowedCmdRefs(interp, cmdPtr);
1689     return (Tcl_Command) cmdPtr;
1690     }
1691    
1692     /*
1693     *----------------------------------------------------------------------
1694     *
1695     * TclInvokeStringCommand --
1696     *
1697     * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
1698     * Tcl_CmdProc if no object-based procedure exists for a command. A
1699     * pointer to this procedure is stored as the Tcl_ObjCmdProc in a
1700     * Command structure. It simply turns around and calls the string
1701     * Tcl_CmdProc in the Command structure.
1702     *
1703     * Results:
1704     * A standard Tcl object result value.
1705     *
1706     * Side effects:
1707     * Besides those side effects of the called Tcl_CmdProc,
1708     * TclInvokeStringCommand allocates and frees storage.
1709     *
1710     *----------------------------------------------------------------------
1711     */
1712    
1713     int
1714     TclInvokeStringCommand(clientData, interp, objc, objv)
1715     ClientData clientData; /* Points to command's Command structure. */
1716     Tcl_Interp *interp; /* Current interpreter. */
1717     register int objc; /* Number of arguments. */
1718     Tcl_Obj *CONST objv[]; /* Argument objects. */
1719     {
1720     register Command *cmdPtr = (Command *) clientData;
1721     register int i;
1722     int result;
1723    
1724     /*
1725     * This procedure generates an argv array for the string arguments. It
1726     * starts out with stack-allocated space but uses dynamically-allocated
1727     * storage if needed.
1728     */
1729    
1730     #define NUM_ARGS 20
1731     char *(argStorage[NUM_ARGS]);
1732     char **argv = argStorage;
1733    
1734     /*
1735     * Create the string argument array "argv". Make sure argv is large
1736     * enough to hold the objc arguments plus 1 extra for the zero
1737     * end-of-argv word.
1738     */
1739    
1740     if ((objc + 1) > NUM_ARGS) {
1741     argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
1742     }
1743    
1744     for (i = 0; i < objc; i++) {
1745     argv[i] = Tcl_GetString(objv[i]);
1746     }
1747     argv[objc] = 0;
1748    
1749     /*
1750     * Invoke the command's string-based Tcl_CmdProc.
1751     */
1752    
1753     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
1754    
1755     /*
1756     * Free the argv array if malloc'ed storage was used.
1757     */
1758    
1759     if (argv != argStorage) {
1760     ckfree((char *) argv);
1761     }
1762     return result;
1763     #undef NUM_ARGS
1764     }
1765    
1766     /*
1767     *----------------------------------------------------------------------
1768     *
1769     * TclInvokeObjectCommand --
1770     *
1771     * "Wrapper" Tcl_CmdProc used to call an existing object-based
1772     * Tcl_ObjCmdProc if no string-based procedure exists for a command.
1773     * A pointer to this procedure is stored as the Tcl_CmdProc in a
1774     * Command structure. It simply turns around and calls the object
1775     * Tcl_ObjCmdProc in the Command structure.
1776     *
1777     * Results:
1778     * A standard Tcl string result value.
1779     *
1780     * Side effects:
1781     * Besides those side effects of the called Tcl_CmdProc,
1782     * TclInvokeStringCommand allocates and frees storage.
1783     *
1784     *----------------------------------------------------------------------
1785     */
1786    
1787     int
1788     TclInvokeObjectCommand(clientData, interp, argc, argv)
1789     ClientData clientData; /* Points to command's Command structure. */
1790     Tcl_Interp *interp; /* Current interpreter. */
1791     int argc; /* Number of arguments. */
1792     register char **argv; /* Argument strings. */
1793     {
1794     Command *cmdPtr = (Command *) clientData;
1795     register Tcl_Obj *objPtr;
1796     register int i;
1797     int length, result;
1798    
1799     /*
1800     * This procedure generates an objv array for object arguments that hold
1801     * the argv strings. It starts out with stack-allocated space but uses
1802     * dynamically-allocated storage if needed.
1803     */
1804    
1805     #define NUM_ARGS 20
1806     Tcl_Obj *(argStorage[NUM_ARGS]);
1807     register Tcl_Obj **objv = argStorage;
1808    
1809     /*
1810     * Create the object argument array "objv". Make sure objv is large
1811     * enough to hold the objc arguments plus 1 extra for the zero
1812     * end-of-objv word.
1813     */
1814    
1815     if ((argc + 1) > NUM_ARGS) {
1816     objv = (Tcl_Obj **)
1817     ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
1818     }
1819    
1820     for (i = 0; i < argc; i++) {
1821     length = strlen(argv[i]);
1822     TclNewObj(objPtr);
1823     TclInitStringRep(objPtr, argv[i], length);
1824     Tcl_IncrRefCount(objPtr);
1825     objv[i] = objPtr;
1826     }
1827     objv[argc] = 0;
1828    
1829     /*
1830     * Invoke the command's object-based Tcl_ObjCmdProc.
1831     */
1832    
1833     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
1834    
1835     /*
1836     * Move the interpreter's object result to the string result,
1837     * then reset the object result.
1838     */
1839    
1840     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1841     TCL_VOLATILE);
1842    
1843     /*
1844     * Decrement the ref counts for the argument objects created above,
1845     * then free the objv array if malloc'ed storage was used.
1846     */
1847    
1848     for (i = 0; i < argc; i++) {
1849     objPtr = objv[i];
1850     Tcl_DecrRefCount(objPtr);
1851     }
1852     if (objv != argStorage) {
1853     ckfree((char *) objv);
1854     }
1855     return result;
1856     #undef NUM_ARGS
1857     }
1858    
1859     /*
1860     *----------------------------------------------------------------------
1861     *
1862     * TclRenameCommand --
1863     *
1864     * Called to give an existing Tcl command a different name. Both the
1865     * old command name and the new command name can have "::" namespace
1866     * qualifiers. If the new command has a different namespace context,
1867     * the command will be moved to that namespace and will execute in
1868     * the context of that new namespace.
1869     *
1870     * If the new command name is NULL or the null string, the command is
1871     * deleted.
1872     *
1873     * Results:
1874     * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1875     *
1876     * Side effects:
1877     * If anything goes wrong, an error message is returned in the
1878     * interpreter's result object.
1879     *
1880     *----------------------------------------------------------------------
1881     */
1882    
1883     int
1884     TclRenameCommand(interp, oldName, newName)
1885     Tcl_Interp *interp; /* Current interpreter. */
1886     char *oldName; /* Existing command name. */
1887     char *newName; /* New command name. */
1888     {
1889     Interp *iPtr = (Interp *) interp;
1890     char *newTail;
1891     Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
1892     Tcl_Command cmd;
1893     Command *cmdPtr;
1894     Tcl_HashEntry *hPtr, *oldHPtr;
1895     int new, result;
1896    
1897     /*
1898     * Find the existing command. An error is returned if cmdName can't
1899     * be found.
1900     */
1901    
1902     cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
1903     /*flags*/ 0);
1904     cmdPtr = (Command *) cmd;
1905     if (cmdPtr == NULL) {
1906     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
1907     ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
1908     " \"", oldName, "\": command doesn't exist", (char *) NULL);
1909     return TCL_ERROR;
1910     }
1911     cmdNsPtr = cmdPtr->nsPtr;
1912    
1913     /*
1914     * If the new command name is NULL or empty, delete the command. Do this
1915     * with Tcl_DeleteCommandFromToken, since we already have the command.
1916     */
1917    
1918     if ((newName == NULL) || (*newName == '\0')) {
1919     Tcl_DeleteCommandFromToken(interp, cmd);
1920     return TCL_OK;
1921     }
1922    
1923     /*
1924     * Make sure that the destination command does not already exist.
1925     * The rename operation is like creating a command, so we should
1926     * automatically create the containing namespaces just like
1927     * Tcl_CreateCommand would.
1928     */
1929    
1930     TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
1931     CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
1932    
1933     if ((newNsPtr == NULL) || (newTail == NULL)) {
1934     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1935     "can't rename to \"", newName, "\": bad command name",
1936     (char *) NULL);
1937     return TCL_ERROR;
1938     }
1939     if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
1940     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1941     "can't rename to \"", newName,
1942     "\": command already exists", (char *) NULL);
1943     return TCL_ERROR;
1944     }
1945    
1946    
1947     /*
1948     * Warning: any changes done in the code here are likely
1949     * to be needed in Tcl_HideCommand() code too.
1950     * (until the common parts are extracted out) --dl
1951     */
1952    
1953     /*
1954     * Put the command in the new namespace so we can check for an alias
1955     * loop. Since we are adding a new command to a namespace, we must
1956     * handle any shadowing of the global commands that this might create.
1957     */
1958    
1959     oldHPtr = cmdPtr->hPtr;
1960     hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
1961     Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1962     cmdPtr->hPtr = hPtr;
1963     cmdPtr->nsPtr = newNsPtr;
1964     TclResetShadowedCmdRefs(interp, cmdPtr);
1965    
1966     /*
1967     * Now check for an alias loop. If we detect one, put everything back
1968     * the way it was and report the error.
1969     */
1970    
1971     result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
1972     if (result != TCL_OK) {
1973     Tcl_DeleteHashEntry(cmdPtr->hPtr);
1974     cmdPtr->hPtr = oldHPtr;
1975     cmdPtr->nsPtr = cmdNsPtr;
1976     return result;
1977     }
1978    
1979     /*
1980     * The new command name is okay, so remove the command from its
1981     * current namespace. This is like deleting the command, so bump
1982     * the cmdEpoch to invalidate any cached references to the command.
1983     */
1984    
1985     Tcl_DeleteHashEntry(oldHPtr);
1986     cmdPtr->cmdEpoch++;
1987    
1988     /*
1989     * If the command being renamed has a compile procedure, increment the
1990     * interpreter's compileEpoch to invalidate its compiled code. This
1991     * makes sure that we don't later try to execute old code compiled for
1992     * the now-renamed command.
1993     */
1994    
1995     if (cmdPtr->compileProc != NULL) {
1996     iPtr->compileEpoch++;
1997     }
1998    
1999     return TCL_OK;
2000     }
2001    
2002     /*
2003     *----------------------------------------------------------------------
2004     *
2005     * Tcl_SetCommandInfo --
2006     *
2007     * Modifies various information about a Tcl command. Note that
2008     * this procedure will not change a command's namespace; use
2009     * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
2010     * member of *infoPtr is ignored.
2011     *
2012     * Results:
2013     * If cmdName exists in interp, then the information at *infoPtr
2014     * is stored with the command in place of the current information
2015     * and 1 is returned. If the command doesn't exist then 0 is
2016     * returned.
2017     *
2018     * Side effects:
2019     * None.
2020     *
2021     *----------------------------------------------------------------------
2022     */
2023    
2024     int
2025     Tcl_SetCommandInfo(interp, cmdName, infoPtr)
2026     Tcl_Interp *interp; /* Interpreter in which to look
2027     * for command. */
2028     char *cmdName; /* Name of desired command. */
2029     Tcl_CmdInfo *infoPtr; /* Where to find information
2030     * to store in the command. */
2031     {
2032     Tcl_Command cmd;
2033     Command *cmdPtr;
2034    
2035     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2036     /*flags*/ 0);
2037     if (cmd == (Tcl_Command) NULL) {
2038     return 0;
2039     }
2040    
2041     /*
2042     * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
2043     */
2044    
2045     cmdPtr = (Command *) cmd;
2046     cmdPtr->proc = infoPtr->proc;
2047     cmdPtr->clientData = infoPtr->clientData;
2048     if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
2049     cmdPtr->objProc = TclInvokeStringCommand;
2050     cmdPtr->objClientData = (ClientData) cmdPtr;
2051     } else {
2052     cmdPtr->objProc = infoPtr->objProc;
2053     cmdPtr->objClientData = infoPtr->objClientData;
2054     }
2055     cmdPtr->deleteProc = infoPtr->deleteProc;
2056     cmdPtr->deleteData = infoPtr->deleteData;
2057     return 1;
2058     }
2059    
2060     /*
2061     *----------------------------------------------------------------------
2062     *
2063     * Tcl_GetCommandInfo --
2064     *
2065     * Returns various information about a Tcl command.
2066     *
2067     * Results:
2068     * If cmdName exists in interp, then *infoPtr is modified to
2069     * hold information about cmdName and 1 is returned. If the
2070     * command doesn't exist then 0 is returned and *infoPtr isn't
2071     * modified.
2072     *
2073     * Side effects:
2074     * None.
2075     *
2076     *----------------------------------------------------------------------
2077     */
2078    
2079     int
2080     Tcl_GetCommandInfo(interp, cmdName, infoPtr)
2081     Tcl_Interp *interp; /* Interpreter in which to look
2082     * for command. */
2083     char *cmdName; /* Name of desired command. */
2084     Tcl_CmdInfo *infoPtr; /* Where to store information about
2085     * command. */
2086     {
2087     Tcl_Command cmd;
2088     Command *cmdPtr;
2089    
2090     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2091     /*flags*/ 0);
2092     if (cmd == (Tcl_Command) NULL) {
2093     return 0;
2094     }
2095    
2096     /*
2097     * Set isNativeObjectProc 1 if objProc was registered by a call to
2098     * Tcl_CreateObjCommand. Otherwise set it to 0.
2099     */
2100    
2101     cmdPtr = (Command *) cmd;
2102     infoPtr->isNativeObjectProc =
2103     (cmdPtr->objProc != TclInvokeStringCommand);
2104     infoPtr->objProc = cmdPtr->objProc;
2105     infoPtr->objClientData = cmdPtr->objClientData;
2106     infoPtr->proc = cmdPtr->proc;
2107     infoPtr->clientData = cmdPtr->clientData;
2108     infoPtr->deleteProc = cmdPtr->deleteProc;
2109     infoPtr->deleteData = cmdPtr->deleteData;
2110     infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
2111     return 1;
2112     }
2113    
2114     /*
2115     *----------------------------------------------------------------------
2116     *
2117     * Tcl_GetCommandName --
2118     *
2119     * Given a token returned by Tcl_CreateCommand, this procedure
2120     * returns the current name of the command (which may have changed
2121     * due to renaming).
2122     *
2123     * Results:
2124     * The return value is the name of the given command.
2125     *
2126     * Side effects:
2127     * None.
2128     *
2129     *----------------------------------------------------------------------
2130     */
2131    
2132     char *
2133     Tcl_GetCommandName(interp, command)
2134     Tcl_Interp *interp; /* Interpreter containing the command. */
2135     Tcl_Command command; /* Token for command returned by a previous
2136     * call to Tcl_CreateCommand. The command
2137     * must not have been deleted. */
2138     {
2139     Command *cmdPtr = (Command *) command;
2140    
2141     if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
2142    
2143     /*
2144     * This should only happen if command was "created" after the
2145     * interpreter began to be deleted, so there isn't really any
2146     * command. Just return an empty string.
2147     */
2148    
2149     return "";
2150     }
2151     return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
2152     }
2153    
2154     /*
2155     *----------------------------------------------------------------------
2156     *
2157     * Tcl_GetCommandFullName --
2158     *
2159     * Given a token returned by, e.g., Tcl_CreateCommand or
2160     * Tcl_FindCommand, this procedure appends to an object the command's
2161     * full name, qualified by a sequence of parent namespace names. The
2162     * command's fully-qualified name may have changed due to renaming.
2163     *
2164     * Results:
2165     * None.
2166     *
2167     * Side effects:
2168     * The command's fully-qualified name is appended to the string
2169     * representation of objPtr.
2170     *
2171     *----------------------------------------------------------------------
2172     */
2173    
2174     void
2175     Tcl_GetCommandFullName(interp, command, objPtr)
2176     Tcl_Interp *interp; /* Interpreter containing the command. */
2177     Tcl_Command command; /* Token for command returned by a previous
2178     * call to Tcl_CreateCommand. The command
2179     * must not have been deleted. */
2180     Tcl_Obj *objPtr; /* Points to the object onto which the
2181     * command's full name is appended. */
2182    
2183     {
2184     Interp *iPtr = (Interp *) interp;
2185     register Command *cmdPtr = (Command *) command;
2186     char *name;
2187    
2188     /*
2189     * Add the full name of the containing namespace, followed by the "::"
2190     * separator, and the command name.
2191     */
2192    
2193     if (cmdPtr != NULL) {
2194     if (cmdPtr->nsPtr != NULL) {
2195     Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
2196     if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
2197     Tcl_AppendToObj(objPtr, "::", 2);
2198     }
2199     }
2200     if (cmdPtr->hPtr != NULL) {
2201     name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
2202     Tcl_AppendToObj(objPtr, name, -1);
2203     }
2204     }
2205     }
2206    
2207     /*
2208     *----------------------------------------------------------------------
2209     *
2210     * Tcl_DeleteCommand --
2211     *
2212     * Remove the given command from the given interpreter.
2213     *
2214     * Results:
2215     * 0 is returned if the command was deleted successfully.
2216     * -1 is returned if there didn't exist a command by that name.
2217     *
2218     * Side effects:
2219     * cmdName will no longer be recognized as a valid command for
2220     * interp.
2221     *
2222     *----------------------------------------------------------------------
2223     */
2224    
2225     int
2226     Tcl_DeleteCommand(interp, cmdName)
2227     Tcl_Interp *interp; /* Token for command interpreter (returned
2228     * by a previous Tcl_CreateInterp call). */
2229     char *cmdName; /* Name of command to remove. */
2230     {
2231     Tcl_Command cmd;
2232    
2233     /*
2234     * Find the desired command and delete it.
2235     */
2236    
2237     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2238     /*flags*/ 0);
2239     if (cmd == (Tcl_Command) NULL) {
2240     return -1;
2241     }
2242     return Tcl_DeleteCommandFromToken(interp, cmd);
2243     }
2244    
2245     /*
2246     *----------------------------------------------------------------------
2247     *
2248     * Tcl_DeleteCommandFromToken --
2249     *
2250     * Removes the given command from the given interpreter. This procedure
2251     * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
2252     * of a command name for efficiency.
2253     *
2254     * Results:
2255     * 0 is returned if the command was deleted successfully.
2256     * -1 is returned if there didn't exist a command by that name.
2257     *
2258     * Side effects:
2259     * The command specified by "cmd" will no longer be recognized as a
2260     * valid command for "interp".
2261     *
2262     *----------------------------------------------------------------------
2263     */
2264    
2265     int
2266     Tcl_DeleteCommandFromToken(interp, cmd)
2267     Tcl_Interp *interp; /* Token for command interpreter returned by
2268     * a previous call to Tcl_CreateInterp. */
2269     Tcl_Command cmd; /* Token for command to delete. */
2270     {
2271     Interp *iPtr = (Interp *) interp;
2272     Command *cmdPtr = (Command *) cmd;
2273     ImportRef *refPtr, *nextRefPtr;
2274     Tcl_Command importCmd;
2275    
2276     /*
2277     * The code here is tricky. We can't delete the hash table entry
2278     * before invoking the deletion callback because there are cases
2279     * where the deletion callback needs to invoke the command (e.g.
2280     * object systems such as OTcl). However, this means that the
2281     * callback could try to delete or rename the command. The deleted
2282     * flag allows us to detect these cases and skip nested deletes.
2283     */
2284    
2285     if (cmdPtr->deleted) {
2286     /*
2287     * Another deletion is already in progress. Remove the hash
2288     * table entry now, but don't invoke a callback or free the
2289     * command structure.
2290     */
2291    
2292     Tcl_DeleteHashEntry(cmdPtr->hPtr);
2293     cmdPtr->hPtr = NULL;
2294     return 0;
2295     }
2296    
2297     /*
2298     * If the command being deleted has a compile procedure, increment the
2299     * interpreter's compileEpoch to invalidate its compiled code. This
2300     * makes sure that we don't later try to execute old code compiled with
2301     * command-specific (i.e., inline) bytecodes for the now-deleted
2302     * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
2303     * code whose compilation epoch doesn't match is recompiled.
2304     */
2305    
2306     if (cmdPtr->compileProc != NULL) {
2307     iPtr->compileEpoch++;
2308     }
2309    
2310     cmdPtr->deleted = 1;
2311     if (cmdPtr->deleteProc != NULL) {
2312     /*
2313     * Delete the command's client data. If this was an imported command
2314     * created when a command was imported into a namespace, this client
2315     * data will be a pointer to a ImportedCmdData structure describing
2316     * the "real" command that this imported command refers to.
2317     */
2318    
2319     /*
2320     * If you are getting a crash during the call to deleteProc and
2321     * cmdPtr->deleteProc is a pointer to the function free(), the
2322     * most likely cause is that your extension allocated memory
2323     * for the clientData argument to Tcl_CreateObjCommand() with
2324     * the ckalloc() macro and you are now trying to deallocate
2325     * this memory with free() instead of ckfree(). You should
2326     * pass a pointer to your own method that calls ckfree().
2327     */
2328    
2329     (*cmdPtr->deleteProc)(cmdPtr->deleteData);
2330     }
2331    
2332     /*
2333     * Bump the command epoch counter. This will invalidate all cached
2334     * references that point to this command.
2335     */
2336    
2337     cmdPtr->cmdEpoch++;
2338    
2339     /*
2340     * If this command was imported into other namespaces, then imported
2341     * commands were created that refer back to this command. Delete these
2342     * imported commands now.
2343     */
2344    
2345     for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
2346     refPtr = nextRefPtr) {
2347     nextRefPtr = refPtr->nextPtr;
2348     importCmd = (Tcl_Command) refPtr->importedCmdPtr;
2349     Tcl_DeleteCommandFromToken(interp, importCmd);
2350     }
2351    
2352     /*
2353     * Don't use hPtr to delete the hash entry here, because it's
2354     * possible that the deletion callback renamed the command.
2355     * Instead, use cmdPtr->hptr, and make sure that no-one else
2356     * has already deleted the hash entry.
2357     */
2358    
2359     if (cmdPtr->hPtr != NULL) {
2360     Tcl_DeleteHashEntry(cmdPtr->hPtr);
2361     }
2362    
2363     /*
2364     * Mark the Command structure as no longer valid. This allows
2365     * TclExecuteByteCode to recognize when a Command has logically been
2366     * deleted and a pointer to this Command structure cached in a CmdName
2367     * object is invalid. TclExecuteByteCode will look up the command again
2368     * in the interpreter's command hashtable.
2369     */
2370    
2371     cmdPtr->objProc = NULL;
2372    
2373     /*
2374     * Now free the Command structure, unless there is another reference to
2375     * it from a CmdName Tcl object in some ByteCode code sequence. In that
2376     * case, delay the cleanup until all references are either discarded
2377     * (when a ByteCode is freed) or replaced by a new reference (when a
2378     * cached CmdName Command reference is found to be invalid and
2379     * TclExecuteByteCode looks up the command in the command hashtable).
2380     */
2381    
2382     TclCleanupCommand(cmdPtr);
2383     return 0;
2384     }
2385    
2386     /*
2387     *----------------------------------------------------------------------
2388     *
2389     * TclCleanupCommand --
2390     *
2391     * This procedure frees up a Command structure unless it is still
2392     * referenced from an interpreter's command hashtable or from a CmdName
2393     * Tcl object representing the name of a command in a ByteCode
2394     * instruction sequence.
2395     *
2396     * Results:
2397     * None.
2398     *
2399     * Side effects:
2400     * Memory gets freed unless a reference to the Command structure still
2401     * exists. In that case the cleanup is delayed until the command is
2402     * deleted or when the last ByteCode referring to it is freed.
2403     *
2404     *----------------------------------------------------------------------
2405     */
2406    
2407     void
2408     TclCleanupCommand(cmdPtr)
2409     register Command *cmdPtr; /* Points to the Command structure to
2410     * be freed. */
2411     {
2412     cmdPtr->refCount--;
2413     if (cmdPtr->refCount <= 0) {
2414     ckfree((char *) cmdPtr);
2415     }
2416     }
2417    
2418     /*
2419     *----------------------------------------------------------------------
2420     *
2421     * Tcl_CreateMathFunc --
2422     *
2423     * Creates a new math function for expressions in a given
2424     * interpreter.
2425     *
2426     * Results:
2427     * None.
2428     *
2429     * Side effects:
2430     * The function defined by "name" is created or redefined. If the
2431     * function already exists then its definition is replaced; this
2432     * includes the builtin functions. Redefining a builtin function forces
2433     * all existing code to be invalidated since that code may be compiled
2434     * using an instruction specific to the replaced function. In addition,
2435     * redefioning a non-builtin function will force existing code to be
2436     * invalidated if the number of arguments has changed.
2437     *
2438     *----------------------------------------------------------------------
2439     */
2440    
2441     void
2442     Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
2443     Tcl_Interp *interp; /* Interpreter in which function is
2444     * to be available. */
2445     char *name; /* Name of function (e.g. "sin"). */
2446     int numArgs; /* Nnumber of arguments required by
2447     * function. */
2448     Tcl_ValueType *argTypes; /* Array of types acceptable for
2449     * each argument. */
2450     Tcl_MathProc *proc; /* Procedure that implements the
2451     * math function. */
2452     ClientData clientData; /* Additional value to pass to the
2453     * function. */
2454     {
2455     Interp *iPtr = (Interp *) interp;
2456     Tcl_HashEntry *hPtr;
2457     MathFunc *mathFuncPtr;
2458     int new, i;
2459    
2460     hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
2461     if (new) {
2462     Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
2463     }
2464     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
2465    
2466     if (!new) {
2467     if (mathFuncPtr->builtinFuncIndex >= 0) {
2468     /*
2469     * We are redefining a builtin math function. Invalidate the
2470     * interpreter's existing code by incrementing its
2471     * compileEpoch member. This field is checked in Tcl_EvalObj
2472     * and ObjInterpProc, and code whose compilation epoch doesn't
2473     * match is recompiled. Newly compiled code will no longer
2474     * treat the function as builtin.
2475     */
2476    
2477     iPtr->compileEpoch++;
2478     } else {
2479     /*
2480     * A non-builtin function is being redefined. We must invalidate
2481     * existing code if the number of arguments has changed. This
2482     * is because existing code was compiled assuming that number.
2483     */
2484    
2485     if (numArgs != mathFuncPtr->numArgs) {
2486     iPtr->compileEpoch++;
2487     }
2488     }
2489     }
2490    
2491     mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
2492     if (numArgs > MAX_MATH_ARGS) {
2493     numArgs = MAX_MATH_ARGS;
2494     }
2495     mathFuncPtr->numArgs = numArgs;
2496     for (i = 0; i < numArgs; i++) {
2497     mathFuncPtr->argTypes[i] = argTypes[i];
2498     }
2499     mathFuncPtr->proc = proc;
2500     mathFuncPtr->clientData = clientData;
2501     }
2502    
2503     /*
2504     *----------------------------------------------------------------------
2505     *
2506     * Tcl_EvalObjEx --
2507     *
2508     * Execute Tcl commands stored in a Tcl object. These commands are
2509     * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
2510     * is specified.
2511     *
2512     * Results:
2513     * The return value is one of the return codes defined in tcl.h
2514     * (such as TCL_OK), and the interpreter's result contains a value
2515     * to supplement the return code.
2516     *
2517     * Side effects:
2518     * The object is converted, if necessary, to a ByteCode object that
2519     * holds the bytecode instructions for the commands. Executing the
2520     * commands will almost certainly have side effects that depend
2521     * on those commands.
2522     *
2523     * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
2524     * last character executed in the objPtr's string.
2525     *
2526     *----------------------------------------------------------------------
2527     */
2528    
2529     int
2530     Tcl_EvalObjEx(interp, objPtr, flags)
2531     Tcl_Interp *interp; /* Token for command interpreter
2532     * (returned by a previous call to
2533     * Tcl_CreateInterp). */
2534     register Tcl_Obj *objPtr; /* Pointer to object containing
2535     * commands to execute. */
2536     int flags; /* Collection of OR-ed bits that
2537     * control the evaluation of the
2538     * script. Supported values are
2539     * TCL_EVAL_GLOBAL and
2540     * TCL_EVAL_DIRECT. */
2541     {
2542     register Interp *iPtr = (Interp *) interp;
2543     int evalFlags; /* Interp->evalFlags value when the
2544     * procedure was called. */
2545     register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
2546     int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
2547     * at all were executed. */
2548     int numSrcBytes;
2549     int result;
2550     CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
2551     * in case TCL_EVAL_GLOBAL was set. */
2552     Namespace *namespacePtr;
2553    
2554     Tcl_IncrRefCount(objPtr);
2555    
2556     if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
2557     /*
2558     * We're not supposed to use the compiler or byte-code interpreter.
2559     * Let Tcl_EvalEx evaluate the command directly (and probably
2560     * more slowly).
2561     *
2562     * Pure List Optimization (no string representation). In this
2563     * case, we can safely use Tcl_EvalObjv instead and get an
2564     * appreciable improvement in execution speed. This is because it
2565     * allows us to avoid a setFromAny step that would just pack
2566     * everything into a string and back out again.
2567     *
2568     * USE_EVAL_DIRECT is a special flag used for testing purpose only
2569     * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
2570     */
2571     if (!(iPtr->flags & USE_EVAL_DIRECT) &&
2572     (objPtr->typePtr == &tclListType) && /* is a list... */
2573     (objPtr->bytes == NULL) /* ...without a string rep */) {
2574     register List *listRepPtr =
2575     (List *) objPtr->internalRep.otherValuePtr;
2576     result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
2577     listRepPtr->elements, flags);
2578     } else {
2579     register char *p;
2580     p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
2581     result = Tcl_EvalEx(interp, p, numSrcBytes, flags);
2582     }
2583     Tcl_DecrRefCount(objPtr);
2584     return result;
2585     }
2586    
2587     /*
2588     * Prevent the object from being deleted as a side effect of evaling it.
2589     */
2590    
2591     savedVarFramePtr = iPtr->varFramePtr;
2592     if (flags & TCL_EVAL_GLOBAL) {
2593     iPtr->varFramePtr = NULL;
2594     }
2595    
2596     /*
2597     * Reset both the interpreter's string and object results and clear out
2598     * any error information. This makes sure that we return an empty
2599     * result if there are no commands in the command string.
2600     */
2601    
2602     Tcl_ResetResult(interp);
2603    
2604     /*
2605     * Check depth of nested calls to Tcl_Eval: if this gets too large,
2606     * it's probably because of an infinite loop somewhere.
2607     */
2608    
2609     iPtr->numLevels++;
2610     if (iPtr->numLevels > iPtr->maxNestingDepth) {
2611     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2612     "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
2613     result = TCL_ERROR;
2614     goto done;
2615     }
2616    
2617     /*
2618     * On the Mac, we will never reach the default recursion limit before
2619     * blowing the stack. So we need to do a check here.
2620     */
2621    
2622     if (TclpCheckStackSpace() == 0) {
2623     /*NOTREACHED*/
2624     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2625     "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
2626     result = TCL_ERROR;
2627     goto done;
2628     }
2629    
2630     /*
2631     * If the interpreter has been deleted, return an error.
2632     */
2633    
2634     if (iPtr->flags & DELETED) {
2635     Tcl_ResetResult(interp);
2636     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2637     "attempt to call eval in deleted interpreter", -1);
2638     Tcl_SetErrorCode(interp, "CORE", "IDELETE",
2639     "attempt to call eval in deleted interpreter",
2640     (char *) NULL);
2641     result = TCL_ERROR;
2642     goto done;
2643     }
2644    
2645     /*
2646     * Get the ByteCode from the object. If it exists, make sure it hasn't
2647     * been invalidated by, e.g., someone redefining a command with a
2648     * compile procedure (this might make the compiled code wrong). If
2649     * necessary, convert the object to be a ByteCode object and compile it.
2650     * Also, if the code was compiled in/for a different interpreter,
2651     * or for a different namespace, or for the same namespace but
2652     * with different name resolution rules, we recompile it.
2653     *
2654     * Precompiled objects, however, are immutable and therefore
2655     * they are not recompiled, even if the epoch has changed.
2656     *
2657     * To be pedantically correct, we should also check that the
2658     * originating procPtr is the same as the current context procPtr
2659     * (assuming one exists at all - none for global level). This
2660     * code is #def'ed out because [info body] was changed to never
2661     * return a bytecode type object, which should obviate us from
2662     * the extra checks here.
2663     */
2664    
2665     if (iPtr->varFramePtr != NULL) {
2666     namespacePtr = iPtr->varFramePtr->nsPtr;
2667     } else {
2668     namespacePtr = iPtr->globalNsPtr;
2669     }
2670    
2671     if (objPtr->typePtr == &tclByteCodeType) {
2672     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2673    
2674     if (((Interp *) *codePtr->interpHandle != iPtr)
2675     || (codePtr->compileEpoch != iPtr->compileEpoch)
2676     #ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
2677     || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
2678     iPtr->varFramePtr->procPtr == codePtr->procPtr))
2679     #endif
2680     || (codePtr->nsPtr != namespacePtr)
2681     || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
2682     if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
2683     if ((Interp *) *codePtr->interpHandle != iPtr) {
2684     panic("Tcl_EvalObj: compiled script jumped interps");
2685     }
2686     codePtr->compileEpoch = iPtr->compileEpoch;
2687     } else {
2688     tclByteCodeType.freeIntRepProc(objPtr);
2689     }
2690     }
2691     }
2692     if (objPtr->typePtr != &tclByteCodeType) {
2693     iPtr->errorLine = 1;
2694     result = tclByteCodeType.setFromAnyProc(interp, objPtr);
2695     if (result != TCL_OK) {
2696     goto done;
2697     }
2698     } else {
2699     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2700     if (((Interp *) *codePtr->interpHandle != iPtr)
2701     || (codePtr->compileEpoch != iPtr->compileEpoch)) {
2702     (*tclByteCodeType.freeIntRepProc)(objPtr);
2703     iPtr->errorLine = 1;
2704     result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
2705     if (result != TCL_OK) {
2706     iPtr->numLevels--;
2707     return result;
2708     }
2709     }
2710     }
2711     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2712    
2713     /*
2714     * Extract then reset the compilation flags in the interpreter.
2715     * Resetting the flags must be done after any compilation.
2716     */
2717    
2718     evalFlags = iPtr->evalFlags;
2719     iPtr->evalFlags = 0;
2720    
2721     /*
2722     * Execute the commands. If the code was compiled from an empty string,
2723     * don't bother executing the code.
2724     */
2725    
2726     numSrcBytes = codePtr->numSrcBytes;
2727     if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
2728     /*
2729     * Increment the code's ref count while it is being executed. If
2730     * afterwards no references to it remain, free the code.
2731     */
2732    
2733     codePtr->refCount++;
2734     result = TclExecuteByteCode(interp, codePtr);
2735     codePtr->refCount--;
2736     if (codePtr->refCount <= 0) {
2737     TclCleanupByteCode(codePtr);
2738     }
2739     } else {
2740     result = TCL_OK;
2741     }
2742    
2743     /*
2744     * If no commands at all were executed, check for asynchronous
2745     * handlers so that they at least get one change to execute.
2746     * This is needed to handle event loops written in Tcl with
2747     * empty bodies.
2748     */
2749    
2750     if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
2751     result = Tcl_AsyncInvoke(interp, result);
2752     }
2753    
2754     /*
2755     * Update the interpreter's evaluation level count. If we are again at
2756     * the top level, process any unusual return code returned by the
2757     * evaluated code.
2758     */
2759    
2760     if (iPtr->numLevels == 1) {
2761     if (result == TCL_RETURN) {
2762     result = TclUpdateReturnInfo(iPtr);
2763     }
2764     if ((result != TCL_OK) && (result != TCL_ERROR)
2765     && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
2766     ProcessUnexpectedResult(interp, result);
2767     result = TCL_ERROR;
2768     }
2769     }
2770    
2771     /*
2772     * If an error occurred, record information about what was being
2773     * executed when the error occurred.
2774     */
2775    
2776     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2777     RecordTracebackInfo(interp, objPtr, numSrcBytes);
2778     }
2779    
2780     /*
2781     * Set the interpreter's termOffset member to the offset of the
2782     * character just after the last one executed. We approximate the offset
2783     * of the last character executed by using the number of characters
2784     * compiled.
2785     */
2786    
2787     iPtr->termOffset = numSrcBytes;
2788     iPtr->flags &= ~ERR_ALREADY_LOGGED;
2789    
2790     done:
2791     TclDecrRefCount(objPtr);
2792     iPtr->varFramePtr = savedVarFramePtr;
2793     iPtr->numLevels--;
2794     return result;
2795     }
2796    
2797     /*
2798     *----------------------------------------------------------------------
2799     *
2800     * ProcessUnexpectedResult --
2801     *
2802     * Procedure called by Tcl_EvalObj to set the interpreter's result
2803     * value to an appropriate error message when the code it evaluates
2804     * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
2805     * the topmost evaluation level.
2806     *
2807     * Results:
2808     * None.
2809     *
2810     * Side effects:
2811     * The interpreter result is set to an error message appropriate to
2812     * the result code.
2813     *
2814     *----------------------------------------------------------------------
2815     */
2816    
2817     static void
2818     ProcessUnexpectedResult(interp, returnCode)
2819     Tcl_Interp *interp; /* The interpreter in which the unexpected
2820     * result code was returned. */
2821     int returnCode; /* The unexpected result code. */
2822     {
2823     Tcl_ResetResult(interp);
2824     if (returnCode == TCL_BREAK) {
2825     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2826     "invoked \"break\" outside of a loop", -1);
2827     } else if (returnCode == TCL_CONTINUE) {
2828     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2829     "invoked \"continue\" outside of a loop", -1);
2830     } else {
2831     char buf[30 + TCL_INTEGER_SPACE];
2832    
2833     sprintf(buf, "command returned bad code: %d", returnCode);
2834     Tcl_SetResult(interp, buf, TCL_VOLATILE);
2835     }
2836     }
2837    
2838     /*
2839     *----------------------------------------------------------------------
2840     *
2841     * RecordTracebackInfo --
2842     *
2843     * Procedure called by Tcl_EvalObj to record information about what was
2844     * being executed when the error occurred.
2845     *
2846     * Results:
2847     * None.
2848     *
2849     * Side effects:
2850     * Appends information about the script being evaluated to the
2851     * interpreter's "errorInfo" variable.
2852     *
2853     *----------------------------------------------------------------------
2854     */
2855    
2856     static void
2857     RecordTracebackInfo(interp, objPtr, numSrcBytes)
2858     Tcl_Interp *interp; /* The interpreter in which the error
2859     * occurred. */
2860     Tcl_Obj *objPtr; /* Points to object containing script whose
2861     * evaluation resulted in an error. */
2862     int numSrcBytes; /* Number of bytes compiled in script. */
2863     {
2864     Interp *iPtr = (Interp *) interp;
2865     char buf[200];
2866     char *ellipsis, *bytes;
2867     int length;
2868    
2869     /*
2870     * Decide how much of the command to print in the error message
2871     * (up to a certain number of bytes).
2872     */
2873    
2874     bytes = Tcl_GetStringFromObj(objPtr, &length);
2875     length = TclMin(numSrcBytes, length);
2876    
2877     ellipsis = "";
2878     if (length > 150) {
2879     length = 150;
2880     ellipsis = " ...";
2881     }
2882    
2883     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
2884     sprintf(buf, "\n while executing\n\"%.*s%s\"",
2885     length, bytes, ellipsis);
2886     } else {
2887     sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
2888     length, bytes, ellipsis);
2889     }
2890     Tcl_AddObjErrorInfo(interp, buf, -1);
2891     }
2892    
2893     /*
2894     *---------------------------------------------------------------------------
2895     *
2896     * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
2897     *
2898     * Procedures to evaluate an expression and return its value in a
2899     * particular form.
2900     *
2901     * Results:
2902     * Each of the procedures below returns a standard Tcl result. If an
2903     * error occurs then an error message is left in the interp's result.
2904     * Otherwise the value of the expression, in the appropriate form,
2905     * is stored at *ptr. If the expression had a result that was
2906     * incompatible with the desired form then an error is returned.
2907     *
2908     * Side effects:
2909     * None.
2910     *
2911     *---------------------------------------------------------------------------
2912     */
2913    
2914     int
2915     Tcl_ExprLong(interp, string, ptr)
2916     Tcl_Interp *interp; /* Context in which to evaluate the
2917     * expression. */
2918     char *string; /* Expression to evaluate. */
2919     long *ptr; /* Where to store result. */
2920     {
2921     register Tcl_Obj *exprPtr;
2922     Tcl_Obj *resultPtr;
2923     int length = strlen(string);
2924     int result = TCL_OK;
2925    
2926     if (length > 0) {
2927     exprPtr = Tcl_NewStringObj(string, length);
2928     Tcl_IncrRefCount(exprPtr);
2929     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
2930     if (result == TCL_OK) {
2931     /*
2932     * Store an integer based on the expression result.
2933     */
2934    
2935     if (resultPtr->typePtr == &tclIntType) {
2936     *ptr = resultPtr->internalRep.longValue;
2937     } else if (resultPtr->typePtr == &tclDoubleType) {
2938     *ptr = (long) resultPtr->internalRep.doubleValue;
2939     } else {
2940     Tcl_SetResult(interp,
2941     "expression didn't have numeric value", TCL_STATIC);
2942     result = TCL_ERROR;
2943     }
2944     Tcl_DecrRefCount(resultPtr); /* discard the result object */
2945     } else {
2946     /*
2947     * Move the interpreter's object result to the string result,
2948     * then reset the object result.
2949     */
2950    
2951     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
2952     TCL_VOLATILE);
2953     }
2954     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
2955     } else {
2956     /*
2957     * An empty string. Just set the result integer to 0.
2958     */
2959    
2960     *ptr = 0;
2961     }
2962     return result;
2963     }
2964    
2965     int
2966     Tcl_ExprDouble(interp, string, ptr)
2967     Tcl_Interp *interp; /* Context in which to evaluate the
2968     * expression. */
2969     char *string; /* Expression to evaluate. */
2970     double *ptr; /* Where to store result. */
2971     {
2972     register Tcl_Obj *exprPtr;
2973     Tcl_Obj *resultPtr;
2974     int length = strlen(string);
2975     int result = TCL_OK;
2976    
2977     if (length > 0) {
2978     exprPtr = Tcl_NewStringObj(string, length);
2979     Tcl_IncrRefCount(exprPtr);
2980     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
2981     if (result == TCL_OK) {
2982     /*
2983     * Store a double based on the expression result.
2984     */
2985    
2986     if (resultPtr->typePtr == &tclIntType) {
2987     *ptr = (double) resultPtr->internalRep.longValue;
2988     } else if (resultPtr->typePtr == &tclDoubleType) {
2989     *ptr = resultPtr->internalRep.doubleValue;
2990     } else {
2991     Tcl_SetResult(interp,
2992     "expression didn't have numeric value", TCL_STATIC);
2993     result = TCL_ERROR;
2994     }
2995     Tcl_DecrRefCount(resultPtr); /* discard the result object */
2996     } else {
2997     /*
2998     * Move the interpreter's object result to the string result,
2999     * then reset the object result.
3000     */
3001    
3002     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3003     TCL_VOLATILE);
3004     }
3005     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
3006     } else {
3007     /*
3008     * An empty string. Just set the result double to 0.0.
3009     */
3010    
3011     *ptr = 0.0;
3012     }
3013     return result;
3014     }
3015    
3016     int
3017     Tcl_ExprBoolean(interp, string, ptr)
3018     Tcl_Interp *interp; /* Context in which to evaluate the
3019     * expression. */
3020     char *string; /* Expression to evaluate. */
3021     int *ptr; /* Where to store 0/1 result. */
3022     {
3023     register Tcl_Obj *exprPtr;
3024     Tcl_Obj *resultPtr;
3025     int length = strlen(string);
3026     int result = TCL_OK;
3027    
3028     if (length > 0) {
3029     exprPtr = Tcl_NewStringObj(string, length);
3030     Tcl_IncrRefCount(exprPtr);
3031     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
3032     if (result == TCL_OK) {
3033     /*
3034     * Store a boolean based on the expression result.
3035     */
3036    
3037     if (resultPtr->typePtr == &tclIntType) {
3038     *ptr = (resultPtr->internalRep.longValue != 0);
3039     } else if (resultPtr->typePtr == &tclDoubleType) {
3040     *ptr = (resultPtr->internalRep.doubleValue != 0.0);
3041     } else {
3042     result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
3043     }
3044     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3045     }
3046     if (result != TCL_OK) {
3047     /*
3048     * Move the interpreter's object result to the string result,
3049     * then reset the object result.
3050     */
3051    
3052     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3053     TCL_VOLATILE);
3054     }
3055     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
3056     } else {
3057     /*
3058     * An empty string. Just set the result boolean to 0 (false).
3059     */
3060    
3061     *ptr = 0;
3062     }
3063     return result;
3064     }
3065    
3066     /*
3067     *--------------------------------------------------------------
3068     *
3069     * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
3070     *
3071     * Procedures to evaluate an expression in an object and return its
3072     * value in a particular form.
3073     *
3074     * Results:
3075     * Each of the procedures below returns a standard Tcl result
3076     * object. If an error occurs then an error message is left in the
3077     * interpreter's result. Otherwise the value of the expression, in the
3078     * appropriate form, is stored at *ptr. If the expression had a result
3079     * that was incompatible with the desired form then an error is
3080     * returned.
3081     *
3082     * Side effects:
3083     * None.
3084     *
3085     *--------------------------------------------------------------
3086     */
3087    
3088     int
3089     Tcl_ExprLongObj(interp, objPtr, ptr)
3090     Tcl_Interp *interp; /* Context in which to evaluate the
3091     * expression. */
3092     register Tcl_Obj *objPtr; /* Expression to evaluate. */
3093     long *ptr; /* Where to store long result. */
3094     {
3095     Tcl_Obj *resultPtr;
3096     int result;
3097    
3098     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
3099     if (result == TCL_OK) {
3100     if (resultPtr->typePtr == &tclIntType) {
3101     *ptr = resultPtr->internalRep.longValue;
3102     } else if (resultPtr->typePtr == &tclDoubleType) {
3103     *ptr = (long) resultPtr->internalRep.doubleValue;
3104     } else {
3105     result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
3106     if (result != TCL_OK) {
3107     return result;
3108     }
3109     }
3110     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3111     }
3112     return result;
3113     }
3114    
3115     int
3116     Tcl_ExprDoubleObj(interp, objPtr, ptr)
3117     Tcl_Interp *interp; /* Context in which to evaluate the
3118     * expression. */
3119     register Tcl_Obj *objPtr; /* Expression to evaluate. */
3120     double *ptr; /* Where to store double result. */
3121     {
3122     Tcl_Obj *resultPtr;
3123     int result;
3124    
3125     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
3126     if (result == TCL_OK) {
3127     if (resultPtr->typePtr == &tclIntType) {
3128     *ptr = (double) resultPtr->internalRep.longValue;
3129     } else if (resultPtr->typePtr == &tclDoubleType) {
3130     *ptr = resultPtr->internalRep.doubleValue;
3131     } else {
3132     result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
3133     if (result != TCL_OK) {
3134     return result;
3135     }
3136     }
3137     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3138     }
3139     return result;
3140     }
3141    
3142     int
3143     Tcl_ExprBooleanObj(interp, objPtr, ptr)
3144     Tcl_Interp *interp; /* Context in which to evaluate the
3145     * expression. */
3146     register Tcl_Obj *objPtr; /* Expression to evaluate. */
3147     int *ptr; /* Where to store 0/1 result. */
3148     {
3149     Tcl_Obj *resultPtr;
3150     int result;
3151    
3152     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
3153     if (result == TCL_OK) {
3154     if (resultPtr->typePtr == &tclIntType) {
3155     *ptr = (resultPtr->internalRep.longValue != 0);
3156     } else if (resultPtr->typePtr == &tclDoubleType) {
3157     *ptr = (resultPtr->internalRep.doubleValue != 0.0);
3158     } else {
3159     result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
3160     }
3161     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3162     }
3163     return result;
3164     }
3165    
3166     /*
3167     *----------------------------------------------------------------------
3168     *
3169     * TclInvoke --
3170     *
3171     * Invokes a Tcl command, given an argv/argc, from either the
3172     * exposed or the hidden sets of commands in the given interpreter.
3173     * NOTE: The command is invoked in the current stack frame of
3174     * the interpreter, thus it can modify local variables.
3175     *
3176     * Results:
3177     * A standard Tcl result.
3178     *
3179     * Side effects:
3180     * Whatever the command does.
3181     *
3182     *----------------------------------------------------------------------
3183     */
3184    
3185     int
3186     TclInvoke(interp, argc, argv, flags)
3187     Tcl_Interp *interp; /* Where to invoke the command. */
3188     int argc; /* Count of args. */
3189     register char **argv; /* The arg strings; argv[0] is the name of
3190     * the command to invoke. */
3191     int flags; /* Combination of flags controlling the
3192     * call: TCL_INVOKE_HIDDEN and
3193     * TCL_INVOKE_NO_UNKNOWN. */
3194     {
3195     register Tcl_Obj *objPtr;
3196     register int i;
3197     int length, result;
3198    
3199     /*
3200     * This procedure generates an objv array for object arguments that hold
3201     * the argv strings. It starts out with stack-allocated space but uses
3202     * dynamically-allocated storage if needed.
3203     */
3204    
3205     #define NUM_ARGS 20
3206     Tcl_Obj *(objStorage[NUM_ARGS]);
3207     register Tcl_Obj **objv = objStorage;
3208    
3209     /*
3210     * Create the object argument array "objv". Make sure objv is large
3211     * enough to hold the objc arguments plus 1 extra for the zero
3212     * end-of-objv word.
3213     */
3214    
3215     if ((argc + 1) > NUM_ARGS) {
3216     objv = (Tcl_Obj **)
3217     ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
3218     }
3219    
3220     for (i = 0; i < argc; i++) {
3221     length = strlen(argv[i]);
3222     objv[i] = Tcl_NewStringObj(argv[i], length);
3223     Tcl_IncrRefCount(objv[i]);
3224     }
3225     objv[argc] = 0;
3226    
3227     /*
3228     * Use TclObjInterpProc to actually invoke the command.
3229     */
3230    
3231     result = TclObjInvoke(interp, argc, objv, flags);
3232    
3233     /*
3234     * Move the interpreter's object result to the string result,
3235     * then reset the object result.
3236     */
3237    
3238     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3239     TCL_VOLATILE);
3240    
3241     /*
3242     * Decrement the ref counts on the objv elements since we are done
3243     * with them.
3244     */
3245    
3246     for (i = 0; i < argc; i++) {
3247     objPtr = objv[i];
3248     Tcl_DecrRefCount(objPtr);
3249     }
3250    
3251     /*
3252     * Free the objv array if malloc'ed storage was used.
3253     */
3254    
3255     if (objv != objStorage) {
3256     ckfree((char *) objv);
3257     }
3258     return result;
3259     #undef NUM_ARGS
3260     }
3261    
3262     /*
3263     *----------------------------------------------------------------------
3264     *
3265     * TclGlobalInvoke --
3266     *
3267     * Invokes a Tcl command, given an argv/argc, from either the
3268     * exposed or hidden sets of commands in the given interpreter.
3269     * NOTE: The command is invoked in the global stack frame of
3270     * the interpreter, thus it cannot see any current state on
3271     * the stack for that interpreter.
3272     *
3273     * Results:
3274     * A standard Tcl result.
3275     *
3276     * Side effects:
3277     * Whatever the command does.
3278     *
3279     *----------------------------------------------------------------------
3280     */
3281    
3282     int
3283     TclGlobalInvoke(interp, argc, argv, flags)
3284     Tcl_Interp *interp; /* Where to invoke the command. */
3285     int argc; /* Count of args. */
3286     register char **argv; /* The arg strings; argv[0] is the name of
3287     * the command to invoke. */
3288     int flags; /* Combination of flags controlling the
3289     * call: TCL_INVOKE_HIDDEN and
3290     * TCL_INVOKE_NO_UNKNOWN. */
3291     {
3292     register Interp *iPtr = (Interp *) interp;
3293     int result;
3294     CallFrame *savedVarFramePtr;
3295    
3296     savedVarFramePtr = iPtr->varFramePtr;
3297     iPtr->varFramePtr = NULL;
3298     result = TclInvoke(interp, argc, argv, flags);
3299     iPtr->varFramePtr = savedVarFramePtr;
3300     return result;
3301     }
3302    
3303     /*
3304     *----------------------------------------------------------------------
3305     *
3306     * TclObjInvokeGlobal --
3307     *
3308     * Object version: Invokes a Tcl command, given an objv/objc, from
3309     * either the exposed or hidden set of commands in the given
3310     * interpreter.
3311     * NOTE: The command is invoked in the global stack frame of the
3312     * interpreter, thus it cannot see any current state on the
3313     * stack of that interpreter.
3314     *
3315     * Results:
3316     * A standard Tcl result.
3317     *
3318     * Side effects:
3319     * Whatever the command does.
3320     *
3321     *----------------------------------------------------------------------
3322     */
3323    
3324     int
3325     TclObjInvokeGlobal(interp, objc, objv, flags)
3326     Tcl_Interp *interp; /* Interpreter in which command is to be
3327     * invoked. */
3328     int objc; /* Count of arguments. */
3329     Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
3330     * name of the command to invoke. */
3331     int flags; /* Combination of flags controlling the
3332     * call: TCL_INVOKE_HIDDEN,
3333     * TCL_INVOKE_NO_UNKNOWN, or
3334     * TCL_INVOKE_NO_TRACEBACK. */
3335     {
3336     register Interp *iPtr = (Interp *) interp;
3337     int result;
3338     CallFrame *savedVarFramePtr;
3339    
3340     savedVarFramePtr = iPtr->varFramePtr;
3341     iPtr->varFramePtr = NULL;
3342     result = TclObjInvoke(interp, objc, objv, flags);
3343     iPtr->varFramePtr = savedVarFramePtr;
3344     return result;
3345     }
3346    
3347     /*
3348     *----------------------------------------------------------------------
3349     *
3350     * TclObjInvoke --
3351     *
3352     * Invokes a Tcl command, given an objv/objc, from either the
3353     * exposed or the hidden sets of commands in the given interpreter.
3354     *
3355     * Results:
3356     * A standard Tcl object result.
3357     *
3358     * Side effects:
3359     * Whatever the command does.
3360     *
3361     *----------------------------------------------------------------------
3362     */
3363    
3364     int
3365     TclObjInvoke(interp, objc, objv, flags)
3366     Tcl_Interp *interp; /* Interpreter in which command is to be
3367     * invoked. */
3368     int objc; /* Count of arguments. */
3369     Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
3370     * name of the command to invoke. */
3371     int flags; /* Combination of flags controlling the
3372     * call: TCL_INVOKE_HIDDEN,
3373     * TCL_INVOKE_NO_UNKNOWN, or
3374     * TCL_INVOKE_NO_TRACEBACK. */
3375     {
3376     register Interp *iPtr = (Interp *) interp;
3377     Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
3378     char *cmdName; /* Name of the command from objv[0]. */
3379     register Tcl_HashEntry *hPtr;
3380     Tcl_Command cmd;
3381     Command *cmdPtr;
3382     int localObjc; /* Used to invoke "unknown" if the */
3383     Tcl_Obj **localObjv = NULL; /* command is not found. */
3384     register int i;
3385     int length, result;
3386     char *bytes;
3387    
3388     if (interp == (Tcl_Interp *) NULL) {
3389     return TCL_ERROR;
3390     }
3391    
3392     if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
3393     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3394     "illegal argument vector", -1);
3395     return TCL_ERROR;
3396     }
3397    
3398     cmdName = Tcl_GetString(objv[0]);
3399     if (flags & TCL_INVOKE_HIDDEN) {
3400     /*
3401     * We never invoke "unknown" for hidden commands.
3402     */
3403    
3404     hPtr = NULL;
3405     hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
3406     if (hTblPtr != NULL) {
3407     hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
3408     }
3409     if (hPtr == NULL) {
3410     Tcl_ResetResult(interp);
3411     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3412     "invalid hidden command name \"", cmdName, "\"",
3413     (char *) NULL);
3414     return TCL_ERROR;
3415     }
3416     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
3417     } else {
3418     cmdPtr = NULL;
3419     cmd = Tcl_FindCommand(interp, cmdName,
3420     (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
3421     if (cmd != (Tcl_Command) NULL) {
3422     cmdPtr = (Command *) cmd;
3423     }
3424     if (cmdPtr == NULL) {
3425     if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
3426     cmd = Tcl_FindCommand(interp, "unknown",
3427     (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
3428     if (cmd != (Tcl_Command) NULL) {
3429     cmdPtr = (Command *) cmd;
3430     }
3431     if (cmdPtr != NULL) {
3432     localObjc = (objc + 1);
3433     localObjv = (Tcl_Obj **)
3434     ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
3435     localObjv[0] = Tcl_NewStringObj("unknown", -1);
3436     Tcl_IncrRefCount(localObjv[0]);
3437     for (i = 0; i < objc; i++) {
3438     localObjv[i+1] = objv[i];
3439     }
3440     objc = localObjc;
3441     objv = localObjv;
3442     }
3443     }
3444    
3445     /*
3446     * Check again if we found the command. If not, "unknown" is
3447     * not present and we cannot help, or the caller said not to
3448     * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
3449     */
3450    
3451     if (cmdPtr == NULL) {
3452     Tcl_ResetResult(interp);
3453     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3454     "invalid command name \"", cmdName, "\"",
3455     (char *) NULL);
3456     return TCL_ERROR;
3457     }
3458     }
3459     }
3460    
3461     /*
3462     * Invoke the command procedure. First reset the interpreter's string
3463     * and object results to their default empty values since they could
3464     * have gotten changed by earlier invocations.
3465     */
3466    
3467     Tcl_ResetResult(interp);
3468     iPtr->cmdCount++;
3469     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
3470    
3471     /*
3472     * If an error occurred, record information about what was being
3473     * executed when the error occurred.
3474     */
3475    
3476     if ((result == TCL_ERROR)
3477     && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
3478     && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
3479     Tcl_DString ds;
3480    
3481     Tcl_DStringInit(&ds);
3482     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
3483     Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
3484     } else {
3485     Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
3486     }
3487     for (i = 0; i < objc; i++) {
3488     bytes = Tcl_GetStringFromObj(objv[i], &length);
3489     Tcl_DStringAppend(&ds, bytes, length);
3490     if (i < (objc - 1)) {
3491     Tcl_DStringAppend(&ds, " ", -1);
3492     } else if (Tcl_DStringLength(&ds) > 100) {
3493     Tcl_DStringSetLength(&ds, 100);
3494     Tcl_DStringAppend(&ds, "...", -1);
3495     break;
3496     }
3497     }
3498    
3499     Tcl_DStringAppend(&ds, "\"", -1);
3500     Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
3501     Tcl_DStringFree(&ds);
3502     iPtr->flags &= ~ERR_ALREADY_LOGGED;
3503     }
3504    
3505     /*
3506     * Free any locally allocated storage used to call "unknown".
3507     */
3508    
3509     if (localObjv != (Tcl_Obj **) NULL) {
3510     Tcl_DecrRefCount(localObjv[0]);
3511     ckfree((char *) localObjv);
3512     }
3513     return result;
3514     }
3515    
3516     /*
3517     *---------------------------------------------------------------------------
3518     *
3519     * Tcl_ExprString --
3520     *
3521     * Evaluate an expression in a string and return its value in string
3522     * form.
3523     *
3524     * Results:
3525     * A standard Tcl result. If the result is TCL_OK, then the interp's
3526     * result is set to the string value of the expression. If the result
3527     * is TCL_ERROR, then the interp's result contains an error message.
3528     *
3529     * Side effects:
3530     * A Tcl object is allocated to hold a copy of the expression string.
3531     * This expression object is passed to Tcl_ExprObj and then
3532     * deallocated.
3533     *
3534     *---------------------------------------------------------------------------
3535     */
3536    
3537     int
3538     Tcl_ExprString(interp, string)
3539     Tcl_Interp *interp; /* Context in which to evaluate the
3540     * expression. */
3541     char *string; /* Expression to evaluate. */
3542     {
3543     register Tcl_Obj *exprPtr;
3544     Tcl_Obj *resultPtr;
3545     int length = strlen(string);
3546     char buf[TCL_DOUBLE_SPACE];
3547     int result = TCL_OK;
3548    
3549     if (length > 0) {
3550     TclNewObj(exprPtr);
3551     TclInitStringRep(exprPtr, string, length);
3552     Tcl_IncrRefCount(exprPtr);
3553    
3554     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
3555     if (result == TCL_OK) {
3556     /*
3557     * Set the interpreter's string result from the result object.
3558     */
3559    
3560     if (resultPtr->typePtr == &tclIntType) {
3561     sprintf(buf, "%ld", resultPtr->internalRep.longValue);
3562     Tcl_SetResult(interp, buf, TCL_VOLATILE);
3563     } else if (resultPtr->typePtr == &tclDoubleType) {
3564     Tcl_PrintDouble((Tcl_Interp *) NULL,
3565     resultPtr->internalRep.doubleValue, buf);
3566     Tcl_SetResult(interp, buf, TCL_VOLATILE);
3567     } else {
3568     /*
3569     * Set interpreter's string result from the result object.
3570     */
3571    
3572     Tcl_SetResult(interp, TclGetString(resultPtr),
3573     TCL_VOLATILE);
3574     }
3575     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3576     } else {
3577     /*
3578     * Move the interpreter's object result to the string result,
3579     * then reset the object result.
3580     */
3581    
3582     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3583     TCL_VOLATILE);
3584     }
3585     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
3586     } else {
3587     /*
3588     * An empty string. Just set the interpreter's result to 0.
3589     */
3590    
3591     Tcl_SetResult(interp, "0", TCL_VOLATILE);
3592     }
3593     return result;
3594     }
3595    
3596     /*
3597     *--------------------------------------------------------------
3598     *
3599     * Tcl_ExprObj --
3600     *
3601     * Evaluate an expression in a Tcl_Obj.
3602     *
3603     * Results:
3604     * A standard Tcl object result. If the result is other than TCL_OK,
3605     * then the interpreter's result contains an error message. If the
3606     * result is TCL_OK, then a pointer to the expression's result value
3607     * object is stored in resultPtrPtr. In that case, the object's ref
3608     * count is incremented to reflect the reference returned to the
3609     * caller; the caller is then responsible for the resulting object
3610     * and must, for example, decrement the ref count when it is finished
3611     * with the object.
3612     *
3613     * Side effects:
3614     * Any side effects caused by subcommands in the expression, if any.
3615     * The interpreter result is not modified unless there is an error.
3616     *
3617     *--------------------------------------------------------------
3618     */
3619    
3620     int
3621     Tcl_ExprObj(interp, objPtr, resultPtrPtr)
3622     Tcl_Interp *interp; /* Context in which to evaluate the
3623     * expression. */
3624     register Tcl_Obj *objPtr; /* Points to Tcl object containing
3625     * expression to evaluate. */
3626     Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
3627     * result is stored if no errors occur. */
3628     {
3629     Interp *iPtr = (Interp *) interp;
3630     CompileEnv compEnv; /* Compilation environment structure
3631     * allocated in frame. */
3632     LiteralTable *localTablePtr = &(compEnv.localLitTable);
3633     register ByteCode *codePtr = NULL;
3634     /* Tcl Internal type of bytecode.
3635     * Initialized to avoid compiler warning. */
3636     AuxData *auxDataPtr;
3637     LiteralEntry *entryPtr;
3638     Tcl_Obj *saveObjPtr;
3639     char *string;
3640     int length, i, result;
3641    
3642     /*
3643     * First handle some common expressions specially.
3644     */
3645    
3646     string = Tcl_GetStringFromObj(objPtr, &length);
3647     if (length == 1) {
3648     if (*string == '0') {
3649     *resultPtrPtr = Tcl_NewLongObj(0);
3650     Tcl_IncrRefCount(*resultPtrPtr);
3651     return TCL_OK;
3652     } else if (*string == '1') {
3653     *resultPtrPtr = Tcl_NewLongObj(1);
3654     Tcl_IncrRefCount(*resultPtrPtr);
3655     return TCL_OK;
3656     }
3657     } else if ((length == 2) && (*string == '!')) {
3658     if (*(string+1) == '0') {
3659     *resultPtrPtr = Tcl_NewLongObj(1);
3660     Tcl_IncrRefCount(*resultPtrPtr);
3661     return TCL_OK;
3662     } else if (*(string+1) == '1') {
3663     *resultPtrPtr = Tcl_NewLongObj(0);
3664     Tcl_IncrRefCount(*resultPtrPtr);
3665     return TCL_OK;
3666     }
3667     }
3668    
3669     /*
3670     * Get the ByteCode from the object. If it exists, make sure it hasn't
3671     * been invalidated by, e.g., someone redefining a command with a
3672     * compile procedure (this might make the compiled code wrong). If
3673     * necessary, convert the object to be a ByteCode object and compile it.
3674     * Also, if the code was compiled in/for a different interpreter, we
3675     * recompile it.
3676     *
3677     * Precompiled expressions, however, are immutable and therefore
3678     * they are not recompiled, even if the epoch has changed.
3679     *
3680     */
3681    
3682     if (objPtr->typePtr == &tclByteCodeType) {
3683     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
3684     if (((Interp *) *codePtr->interpHandle != iPtr)
3685     || (codePtr->compileEpoch != iPtr->compileEpoch)) {
3686     if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
3687     if ((Interp *) *codePtr->interpHandle != iPtr) {
3688     panic("Tcl_ExprObj: compiled expression jumped interps");
3689     }
3690     codePtr->compileEpoch = iPtr->compileEpoch;
3691     } else {
3692     (*tclByteCodeType.freeIntRepProc)(objPtr);
3693     objPtr->typePtr = (Tcl_ObjType *) NULL;
3694     }
3695     }
3696     }
3697     if (objPtr->typePtr != &tclByteCodeType) {
3698     TclInitCompileEnv(interp, &compEnv, string, length);
3699     result = TclCompileExpr(interp, string, length, &compEnv);
3700    
3701     /*
3702     * Free the compilation environment's literal table bucket array if
3703     * it was dynamically allocated.
3704     */
3705    
3706     if (localTablePtr->buckets != localTablePtr->staticBuckets) {
3707     ckfree((char *) localTablePtr->buckets);
3708     }
3709    
3710     if (result != TCL_OK) {
3711     /*
3712     * Compilation errors. Free storage allocated for compilation.
3713     */
3714    
3715     #ifdef TCL_COMPILE_DEBUG
3716     TclVerifyLocalLiteralTable(&compEnv);
3717     #endif /*TCL_COMPILE_DEBUG*/
3718     entryPtr = compEnv.literalArrayPtr;
3719     for (i = 0; i < compEnv.literalArrayNext; i++) {
3720     TclReleaseLiteral(interp, entryPtr->objPtr);
3721     entryPtr++;
3722     }
3723     #ifdef TCL_COMPILE_DEBUG
3724     TclVerifyGlobalLiteralTable(iPtr);
3725     #endif /*TCL_COMPILE_DEBUG*/
3726    
3727     auxDataPtr = compEnv.auxDataArrayPtr;
3728     for (i = 0; i < compEnv.auxDataArrayNext; i++) {
3729     if (auxDataPtr->type->freeProc != NULL) {
3730     auxDataPtr->type->freeProc(auxDataPtr->clientData);
3731     }
3732     auxDataPtr++;
3733     }
3734     TclFreeCompileEnv(&compEnv);
3735     return result;
3736     }
3737    
3738     /*
3739     * Successful compilation. If the expression yielded no
3740     * instructions, push an zero object as the expression's result.
3741     */
3742    
3743     if (compEnv.codeNext == compEnv.codeStart) {
3744     TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
3745     &compEnv);
3746     }
3747    
3748     /*
3749     * Add a "done" instruction as the last instruction and change the
3750     * object into a ByteCode object. Ownership of the literal objects
3751     * and aux data items is given to the ByteCode object.
3752     */
3753    
3754     compEnv.numSrcBytes = iPtr->termOffset;
3755     TclEmitOpcode(INST_DONE, &compEnv);
3756     TclInitByteCodeObj(objPtr, &compEnv);
3757     TclFreeCompileEnv(&compEnv);
3758     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
3759     #ifdef TCL_COMPILE_DEBUG
3760     if (tclTraceCompile == 2) {
3761     TclPrintByteCodeObj(interp, objPtr);
3762     }
3763     #endif /* TCL_COMPILE_DEBUG */
3764     }
3765    
3766     /*
3767     * Execute the expression after first saving the interpreter's result.
3768     */
3769    
3770     saveObjPtr = Tcl_GetObjResult(interp);
3771     Tcl_IncrRefCount(saveObjPtr);
3772     Tcl_ResetResult(interp);
3773    
3774     /*
3775     * Increment the code's ref count while it is being executed. If
3776     * afterwards no references to it remain, free the code.
3777     */
3778    
3779     codePtr->refCount++;
3780     result = TclExecuteByteCode(interp, codePtr);
3781     codePtr->refCount--;
3782     if (codePtr->refCount <= 0) {
3783     TclCleanupByteCode(codePtr);
3784     objPtr->typePtr = NULL;
3785     objPtr->internalRep.otherValuePtr = NULL;
3786     }
3787    
3788     /*
3789     * If the expression evaluated successfully, store a pointer to its
3790     * value object in resultPtrPtr then restore the old interpreter result.
3791     * We increment the object's ref count to reflect the reference that we
3792     * are returning to the caller. We also decrement the ref count of the
3793     * interpreter's result object after calling Tcl_SetResult since we
3794     * next store into that field directly.
3795     */
3796    
3797     if (result == TCL_OK) {
3798     *resultPtrPtr = iPtr->objResultPtr;
3799     Tcl_IncrRefCount(iPtr->objResultPtr);
3800    
3801     Tcl_SetObjResult(interp, saveObjPtr);
3802     }
3803     Tcl_DecrRefCount(saveObjPtr);
3804     return result;
3805     }
3806    
3807     /*
3808     *----------------------------------------------------------------------
3809     *
3810     * Tcl_CreateTrace --
3811     *
3812     * Arrange for a procedure to be called to trace command execution.
3813     *
3814     * Results:
3815     * The return value is a token for the trace, which may be passed
3816     * to Tcl_DeleteTrace to eliminate the trace.
3817     *
3818     * Side effects:
3819     * From now on, proc will be called just before a command procedure
3820     * is called to execute a Tcl command. Calls to proc will have the
3821     * following form:
3822     *
3823     * void
3824     * proc(clientData, interp, level, command, cmdProc, cmdClientData,
3825     * argc, argv)
3826     * ClientData clientData;
3827     * Tcl_Interp *interp;
3828     * int level;
3829     * char *command;
3830     * int (*cmdProc)();
3831     * ClientData cmdClientData;
3832     * int argc;
3833     * char **argv;
3834     * {
3835     * }
3836     *
3837     * The clientData and interp arguments to proc will be the same
3838     * as the corresponding arguments to this procedure. Level gives
3839     * the nesting level of command interpretation for this interpreter
3840     * (0 corresponds to top level). Command gives the ASCII text of
3841     * the raw command, cmdProc and cmdClientData give the procedure that
3842     * will be called to process the command and the ClientData value it
3843     * will receive, and argc and argv give the arguments to the
3844     * command, after any argument parsing and substitution. Proc
3845     * does not return a value.
3846     *
3847     *----------------------------------------------------------------------
3848     */
3849    
3850     Tcl_Trace
3851     Tcl_CreateTrace(interp, level, proc, clientData)
3852     Tcl_Interp *interp; /* Interpreter in which to create trace. */
3853     int level; /* Only call proc for commands at nesting
3854     * level<=argument level (1=>top level). */
3855     Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
3856     * command. */
3857     ClientData clientData; /* Arbitrary value word to pass to proc. */
3858     {
3859     register Trace *tracePtr;
3860     register Interp *iPtr = (Interp *) interp;
3861    
3862     /*
3863     * Invalidate existing compiled code for this interpreter and arrange
3864     * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
3865     * new code, no commands will be compiled inline (i.e., into an inline
3866     * sequence of instructions). We do this because commands that were
3867     * compiled inline will never result in a command trace being called.
3868     */
3869    
3870     iPtr->compileEpoch++;
3871     iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
3872    
3873     tracePtr = (Trace *) ckalloc(sizeof(Trace));
3874     tracePtr->level = level;
3875     tracePtr->proc = proc;
3876     tracePtr->clientData = clientData;
3877     tracePtr->nextPtr = iPtr->tracePtr;
3878     iPtr->tracePtr = tracePtr;
3879    
3880     return (Tcl_Trace) tracePtr;
3881     }
3882    
3883     /*
3884     *----------------------------------------------------------------------
3885     *
3886     * Tcl_DeleteTrace --
3887     *
3888     * Remove a trace.
3889     *
3890     * Results:
3891     * None.
3892     *
3893     * Side effects:
3894     * From now on there will be no more calls to the procedure given