source: trunk/tcl/tclBasic.c@ 12

Last change on this file since 12 was 2, checked in by Pavel Demin, 16 years ago

first commit

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