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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25