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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (show annotations) (download)
Sat Nov 5 11:07:06 2016 UTC (8 years, 1 month 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 /* $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
3895 * in trace.
3896 *
3897 *----------------------------------------------------------------------
3898 */
3899
3900 void
3901 Tcl_DeleteTrace(interp, trace)
3902 Tcl_Interp *interp; /* Interpreter that contains trace. */
3903 Tcl_Trace trace; /* Token for trace (returned previously by
3904 * Tcl_CreateTrace). */
3905 {
3906 register Interp *iPtr = (Interp *) interp;
3907 register Trace *tracePtr = (Trace *) trace;
3908 register Trace *tracePtr2;
3909
3910 if (iPtr->tracePtr == tracePtr) {
3911 iPtr->tracePtr = tracePtr->nextPtr;
3912 ckfree((char *) tracePtr);
3913 } else {
3914 for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
3915 tracePtr2 = tracePtr2->nextPtr) {
3916 if (tracePtr2->nextPtr == tracePtr) {
3917 tracePtr2->nextPtr = tracePtr->nextPtr;
3918 ckfree((char *) tracePtr);
3919 break;
3920 }
3921 }
3922 }
3923
3924 if (iPtr->tracePtr == NULL) {
3925 /*
3926 * When compiling new code, allow commands to be compiled inline.
3927 */
3928
3929 iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
3930 }
3931 }
3932
3933 /*
3934 *----------------------------------------------------------------------
3935 *
3936 * Tcl_AddErrorInfo --
3937 *
3938 * Add information to the "errorInfo" variable that describes the
3939 * current error.
3940 *
3941 * Results:
3942 * None.
3943 *
3944 * Side effects:
3945 * The contents of message are added to the "errorInfo" variable.
3946 * If Tcl_Eval has been called since the current value of errorInfo
3947 * was set, errorInfo is cleared before adding the new message.
3948 * If we are just starting to log an error, errorInfo is initialized
3949 * from the error message in the interpreter's result.
3950 *
3951 *----------------------------------------------------------------------
3952 */
3953
3954 void
3955 Tcl_AddErrorInfo(interp, message)
3956 Tcl_Interp *interp; /* Interpreter to which error information
3957 * pertains. */
3958 CONST char *message; /* Message to record. */
3959 {
3960 Tcl_AddObjErrorInfo(interp, message, -1);
3961 }
3962
3963 /*
3964 *----------------------------------------------------------------------
3965 *
3966 * Tcl_AddObjErrorInfo --
3967 *
3968 * Add information to the "errorInfo" variable that describes the
3969 * current error. This routine differs from Tcl_AddErrorInfo by
3970 * taking a byte pointer and length.
3971 *
3972 * Results:
3973 * None.
3974 *
3975 * Side effects:
3976 * "length" bytes from "message" are added to the "errorInfo" variable.
3977 * If "length" is negative, use bytes up to the first NULL byte.
3978 * If Tcl_EvalObj has been called since the current value of errorInfo
3979 * was set, errorInfo is cleared before adding the new message.
3980 * If we are just starting to log an error, errorInfo is initialized
3981 * from the error message in the interpreter's result.
3982 *
3983 *----------------------------------------------------------------------
3984 */
3985
3986 void
3987 Tcl_AddObjErrorInfo(interp, message, length)
3988 Tcl_Interp *interp; /* Interpreter to which error information
3989 * pertains. */
3990 CONST char *message; /* Points to the first byte of an array of
3991 * bytes of the message. */
3992 int length; /* The number of bytes in the message.
3993 * If < 0, then append all bytes up to a
3994 * NULL byte. */
3995 {
3996 register Interp *iPtr = (Interp *) interp;
3997 Tcl_Obj *messagePtr;
3998
3999 /*
4000 * If we are just starting to log an error, errorInfo is initialized
4001 * from the error message in the interpreter's result.
4002 */
4003
4004 if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
4005 iPtr->flags |= ERR_IN_PROGRESS;
4006
4007 if (iPtr->result[0] == 0) {
4008 (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr,
4009 TCL_GLOBAL_ONLY);
4010 } else { /* use the string result */
4011 Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
4012 TCL_GLOBAL_ONLY);
4013 }
4014
4015 /*
4016 * If the errorCode variable wasn't set by the code that generated
4017 * the error, set it to "NONE".
4018 */
4019
4020 if (!(iPtr->flags & ERROR_CODE_SET)) {
4021 (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
4022 TCL_GLOBAL_ONLY);
4023 }
4024 }
4025
4026 /*
4027 * Now append "message" to the end of errorInfo.
4028 */
4029
4030 if (length != 0) {
4031 messagePtr = Tcl_NewStringObj(message, length);
4032 Tcl_IncrRefCount(messagePtr);
4033 Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr,
4034 (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
4035 Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
4036 }
4037 }
4038
4039 /*
4040 *---------------------------------------------------------------------------
4041 *
4042 * Tcl_VarEvalVA --
4043 *
4044 * Given a variable number of string arguments, concatenate them
4045 * all together and execute the result as a Tcl command.
4046 *
4047 * Results:
4048 * A standard Tcl return result. An error message or other result may
4049 * be left in the interp's result.
4050 *
4051 * Side effects:
4052 * Depends on what was done by the command.
4053 *
4054 *---------------------------------------------------------------------------
4055 */
4056
4057 int
4058 Tcl_VarEvalVA (interp, argList)
4059 Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
4060 va_list argList; /* Variable argument list. */
4061 {
4062 Tcl_DString buf;
4063 char *string;
4064 int result;
4065
4066 /*
4067 * Copy the strings one after the other into a single larger
4068 * string. Use stack-allocated space for small commands, but if
4069 * the command gets too large than call ckalloc to create the
4070 * space.
4071 */
4072
4073 Tcl_DStringInit(&buf);
4074 while (1) {
4075 string = va_arg(argList, char *);
4076 if (string == NULL) {
4077 break;
4078 }
4079 Tcl_DStringAppend(&buf, string, -1);
4080 }
4081
4082 result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
4083 Tcl_DStringFree(&buf);
4084 return result;
4085 }
4086
4087 /*
4088 *----------------------------------------------------------------------
4089 *
4090 * Tcl_VarEval --
4091 *
4092 * Given a variable number of string arguments, concatenate them
4093 * all together and execute the result as a Tcl command.
4094 *
4095 * Results:
4096 * A standard Tcl return result. An error message or other
4097 * result may be left in interp->result.
4098 *
4099 * Side effects:
4100 * Depends on what was done by the command.
4101 *
4102 *----------------------------------------------------------------------
4103 */
4104 /* VARARGS2 */ /* ARGSUSED */
4105 int
4106 Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
4107 {
4108 Tcl_Interp *interp;
4109 va_list argList;
4110 int result;
4111
4112 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
4113 result = Tcl_VarEvalVA(interp, argList);
4114 va_end(argList);
4115
4116 return result;
4117 }
4118
4119 /*
4120 *---------------------------------------------------------------------------
4121 *
4122 * Tcl_GlobalEval --
4123 *
4124 * Evaluate a command at global level in an interpreter.
4125 *
4126 * Results:
4127 * A standard Tcl result is returned, and the interp's result is
4128 * modified accordingly.
4129 *
4130 * Side effects:
4131 * The command string is executed in interp, and the execution
4132 * is carried out in the variable context of global level (no
4133 * procedures active), just as if an "uplevel #0" command were
4134 * being executed.
4135 *
4136 ---------------------------------------------------------------------------
4137 */
4138
4139 int
4140 Tcl_GlobalEval(interp, command)
4141 Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
4142 char *command; /* Command to evaluate. */
4143 {
4144 register Interp *iPtr = (Interp *) interp;
4145 int result;
4146 CallFrame *savedVarFramePtr;
4147
4148 savedVarFramePtr = iPtr->varFramePtr;
4149 iPtr->varFramePtr = NULL;
4150 result = Tcl_Eval(interp, command);
4151 iPtr->varFramePtr = savedVarFramePtr;
4152 return result;
4153 }
4154
4155 /*
4156 *----------------------------------------------------------------------
4157 *
4158 * Tcl_SetRecursionLimit --
4159 *
4160 * Set the maximum number of recursive calls that may be active
4161 * for an interpreter at once.
4162 *
4163 * Results:
4164 * The return value is the old limit on nesting for interp.
4165 *
4166 * Side effects:
4167 * None.
4168 *
4169 *----------------------------------------------------------------------
4170 */
4171
4172 int
4173 Tcl_SetRecursionLimit(interp, depth)
4174 Tcl_Interp *interp; /* Interpreter whose nesting limit
4175 * is to be set. */
4176 int depth; /* New value for maximimum depth. */
4177 {
4178 Interp *iPtr = (Interp *) interp;
4179 int old;
4180
4181 old = iPtr->maxNestingDepth;
4182 if (depth > 0) {
4183 iPtr->maxNestingDepth = depth;
4184 }
4185 return old;
4186 }
4187
4188 /*
4189 *----------------------------------------------------------------------
4190 *
4191 * Tcl_AllowExceptions --
4192 *
4193 * Sets a flag in an interpreter so that exceptions can occur
4194 * in the next call to Tcl_Eval without them being turned into
4195 * errors.
4196 *
4197 * Results:
4198 * None.
4199 *
4200 * Side effects:
4201 * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
4202 * evalFlags structure. See the reference documentation for
4203 * more details.
4204 *
4205 *----------------------------------------------------------------------
4206 */
4207
4208 void
4209 Tcl_AllowExceptions(interp)
4210 Tcl_Interp *interp; /* Interpreter in which to set flag. */
4211 {
4212 Interp *iPtr = (Interp *) interp;
4213
4214 iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
4215 }
4216
4217
4218 /*
4219 *----------------------------------------------------------------------
4220 *
4221 * Tcl_GetVersion
4222 *
4223 * Get the Tcl major, minor, and patchlevel version numbers and
4224 * the release type. A patch is a release type TCL_FINAL_RELEASE
4225 * with a patchLevel > 0.
4226 *
4227 * Results:
4228 * None.
4229 *
4230 * Side effects:
4231 * None.
4232 *
4233 *----------------------------------------------------------------------
4234 */
4235
4236 void Tcl_GetVersion(majorV, minorV, patchLevelV, type)
4237 int *majorV;
4238 int *minorV;
4239 int *patchLevelV;
4240 int *type;
4241 {
4242 if (majorV != NULL) {
4243 *majorV = TCL_MAJOR_VERSION;
4244 }
4245 if (minorV != NULL) {
4246 *minorV = TCL_MINOR_VERSION;
4247 }
4248 if (patchLevelV != NULL) {
4249 *patchLevelV = TCL_RELEASE_SERIAL;
4250 }
4251 if (type != NULL) {
4252 *type = TCL_RELEASE_LEVEL;
4253 }
4254 }
4255
4256 /* End of tclbasic.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25