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-1996 Sun Microsystems, Inc.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * SCCS: @(#) tclBasic.c 1.210 96/03/25 17:17:54
15 */
16
17 #include "tclInt.h"
18 #include "tkshlib.h"
19 #include "tclcmd.h"
20
21 /*
22 * This variable indicates to the close procedures of channel drivers that
23 * we are in the middle of an interpreter deletion, and hence in "implicit"
24 * close mode. In that mode, the close procedures should not close the
25 * OS handle for standard IO channels. Since interpreter deletion may be
26 * recursive, this variable is actually a counter of the levels of nesting.
27 */
28
29 int tclInInterpreterDeletion = 0;
30
31 /*
32 * Static procedures in this file:
33 */
34
35 static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
36
37 /*
38 * The following structure defines all of the commands in the Tcl core,
39 * and the C procedures that execute them.
40 */
41
42 typedef struct {
43 char *name; /* Name of command. */
44 Tcl_CmdProc *proc; /* Procedure that executes command. */
45 } CmdInfo;
46
47 /*
48 * Built-in commands, and the procedures associated with them:
49 */
50
51 static CmdInfo builtInCmds[] = {
52 /*
53 * Commands in the generic core:
54 */
55
56 {"append", Tcl_AppendCmd},
57 {"array", Tcl_ArrayCmd},
58 {"break", Tcl_BreakCmd},
59 {"case", Tcl_CaseCmd},
60 {"catch", Tcl_CatchCmd},
61 {"clock", Tcl_ClockCmd},
62 {"concat", Tcl_ConcatCmd},
63 {"continue", Tcl_ContinueCmd},
64 {"error", Tcl_ErrorCmd},
65 {"eval", Tcl_EvalCmd},
66 /* {"exit", Tcl_ExitCmd}, */
67 {"expr", Tcl_ExprCmd},
68 {"fileevent", Tcl_FileEventCmd},
69 {"for", Tcl_ForCmd},
70 {"foreach", Tcl_ForeachCmd},
71 {"format", Tcl_FormatCmd},
72 {"global", Tcl_GlobalCmd},
73 /* {"history", Tcl_HistoryCmd}, */
74 {"if", Tcl_IfCmd},
75 {"incr", Tcl_IncrCmd},
76 {"info", Tksh_InfoCmd},
77 {"interp", Tcl_InterpCmd},
78 {"join", Tcl_JoinCmd},
79 {"lappend", Tcl_LappendCmd},
80 {"lindex", Tcl_LindexCmd},
81 {"linsert", Tcl_LinsertCmd},
82 {"list", Tcl_ListCmd},
83 {"llength", Tcl_LlengthCmd},
84 {"load", Tcl_LoadCmd},
85 {"lrange", Tcl_LrangeCmd},
86 {"lreplace", Tcl_LreplaceCmd},
87 {"lsearch", Tcl_LsearchCmd},
88 {"lsort", Tcl_LsortCmd},
89 {"package", Tcl_PackageCmd},
90 {"proc", Tcl_ProcCmd},
91 {"regexp", Tcl_RegexpCmd},
92 {"regsub", Tcl_RegsubCmd},
93 {"rename", Tksh_RenameCmd},
94 {"return", Tcl_ReturnCmd},
95 {"scan", Tcl_ScanCmd},
96 {"set", Tcl_SetCmd},
97 {"split", Tcl_SplitCmd},
98 {"string", Tcl_StringCmd},
99 {"subst", Tcl_SubstCmd},
100 {"switch", Tcl_SwitchCmd},
101 {"trace", Tcl_TraceCmd},
102 {"unset", Tcl_UnsetCmd},
103 {"uplevel", Tcl_UplevelCmd},
104 {"upvar", Tcl_UpvarCmd},
105 {"while", Tcl_WhileCmd},
106
107 /*
108 * Commands in the UNIX core:
109 */
110
111 #ifndef TCL_GENERIC_ONLY
112 {"after", Tcl_AfterCmd},
113 {"cd", Tcl_CdCmd},
114 {"close", Tcl_CloseCmd},
115 {"eof", Tcl_EofCmd},
116 {"fblocked", Tcl_FblockedCmd},
117 {"fconfigure", Tcl_FconfigureCmd},
118 {"file", Tcl_FileCmd},
119 {"flush", Tcl_FlushCmd},
120 {"gets", Tcl_GetsCmd},
121 {"glob", Tcl_GlobCmd},
122 {"open", Tcl_OpenCmd},
123 {"pid", Tcl_PidCmd},
124 {"puts", Tcl_PutsCmd},
125 /* {"pwd", Tcl_PwdCmd}, */
126 {"read", Tcl_ReadCmd},
127 {"seek", Tcl_SeekCmd},
128 /* {"socket", Tcl_SocketCmd}, */
129 {"tell", Tcl_TellCmd},
130 {"time", Tcl_TimeCmd},
131 {"update", Tcl_UpdateCmd},
132 {"vwait", Tcl_VwaitCmd},
133 {"unsupported0", TclUnsupported0Cmd},
134
135 #ifdef MAC_TCL
136 {"beep", Tcl_MacBeepCmd},
137 {"cp", Tcl_CpCmd},
138 {"echo", Tcl_EchoCmd},
139 {"ls", Tcl_LsCmd},
140 {"mkdir", Tcl_MkdirCmd},
141 {"mv", Tcl_MvCmd},
142 {"resource", Tcl_ResourceCmd},
143 {"rm", Tcl_RmCmd},
144 {"rmdir", Tcl_RmdirCmd},
145 {"source", Tcl_MacSourceCmd},
146 #else
147 {"exec", Tcl_ExecCmd},
148 {"source", Tksh_SourceCmd},
149 #endif /* MAC_TCL */
150
151 #endif /* TCL_GENERIC_ONLY */
152 {NULL, (Tcl_CmdProc *) NULL}
153 };
154
155 /*
156 *----------------------------------------------------------------------
157 *
158 * Tcl_CreateInterp --
159 *
160 * Create a new TCL command interpreter.
161 *
162 * Results:
163 * The return value is a token for the interpreter, which may be
164 * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
165 * Tcl_DeleteInterp.
166 *
167 * Side effects:
168 * The command interpreter is initialized with an empty variable
169 * table and the built-in commands.
170 *
171 *----------------------------------------------------------------------
172 */
173
174 Tcl_Interp *
Tcl_CreateInterp()175 Tcl_CreateInterp()
176 {
177 register Interp *iPtr;
178 int i;
179
180 iPtr = (Interp *) ckalloc(sizeof(Interp));
181 iPtr->result = iPtr->resultSpace;
182 iPtr->freeProc = 0;
183 iPtr->errorLine = 0;
184 Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
185 iPtr->numLevels = 0;
186 iPtr->maxNestingDepth = 1000;
187 iPtr->returnCode = TCL_OK;
188 iPtr->errorInfo = NULL;
189 iPtr->errorCode = NULL;
190 iPtr->appendResult = NULL;
191 iPtr->appendAvl = 0;
192 iPtr->appendUsed = 0;
193 for (i = 0; i < NUM_REGEXPS; i++) {
194 iPtr->patterns[i] = NULL;
195 iPtr->patLengths[i] = -1;
196 iPtr->regexps[i] = NULL;
197 }
198 Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
199 iPtr->packageUnknown = NULL;
200 strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
201 iPtr->pdPrec = DEFAULT_PD_PREC;
202 iPtr->cmdCount = 0;
203 iPtr->noEval = 0;
204 iPtr->evalFlags = 0;
205 iPtr->scriptFile = NULL;
206 iPtr->flags = 0;
207 iPtr->assocData = (Tcl_HashTable *) NULL;
208 iPtr->resultSpace[0] = 0;
209
210 TkshCreateInterp((Tcl_Interp *) iPtr, (void *) builtInCmds);
211 #ifndef TCL_GENERIC_ONLY
212 TclSetupEnv((Tcl_Interp *) iPtr);
213 #endif
214
215 /*
216 * Do Safe-Tcl init stuff
217 */
218
219 (void) TclInterpInit((Tcl_Interp *)iPtr);
220
221 /*
222 * Set up variables such as tcl_library and tcl_precision.
223 */
224
225 TclPlatformInit((Tcl_Interp *)iPtr);
226
227 /*
228 * Register Tcl's version number.
229 */
230
231 Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
232
233 return (Tcl_Interp *) iPtr;
234 }
235
236 /*
237 *--------------------------------------------------------------
238 *
239 * Tcl_CallWhenDeleted --
240 *
241 * Arrange for a procedure to be called before a given
242 * interpreter is deleted. The procedure is called as soon
243 * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
244 * called on an interpreter that has already been deleted,
245 * the procedure will be called when the last Tcl_Release is
246 * done on the interpreter.
247 *
248 * Results:
249 * None.
250 *
251 * Side effects:
252 * When Tcl_DeleteInterp is invoked to delete interp,
253 * proc will be invoked. See the manual entry for
254 * details.
255 *
256 *--------------------------------------------------------------
257 */
258
259 void
Tcl_CallWhenDeleted(interp,proc,clientData)260 Tcl_CallWhenDeleted(interp, proc, clientData)
261 Tcl_Interp *interp; /* Interpreter to watch. */
262 Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
263 * is about to be deleted. */
264 ClientData clientData; /* One-word value to pass to proc. */
265 {
266 Interp *iPtr = (Interp *) interp;
267 static int assocDataCounter = 0;
268 int new;
269 char buffer[128];
270 AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
271 Tcl_HashEntry *hPtr;
272
273 sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
274 assocDataCounter++;
275
276 if (iPtr->assocData == (Tcl_HashTable *) NULL) {
277 iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
278 Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
279 }
280 hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
281 dPtr->proc = proc;
282 dPtr->clientData = clientData;
283 Tcl_SetHashValue(hPtr, dPtr);
284 }
285
286 /*
287 *--------------------------------------------------------------
288 *
289 * Tcl_DontCallWhenDeleted --
290 *
291 * Cancel the arrangement for a procedure to be called when
292 * a given interpreter is deleted.
293 *
294 * Results:
295 * None.
296 *
297 * Side effects:
298 * If proc and clientData were previously registered as a
299 * callback via Tcl_CallWhenDeleted, they are unregistered.
300 * If they weren't previously registered then nothing
301 * happens.
302 *
303 *--------------------------------------------------------------
304 */
305
306 void
Tcl_DontCallWhenDeleted(interp,proc,clientData)307 Tcl_DontCallWhenDeleted(interp, proc, clientData)
308 Tcl_Interp *interp; /* Interpreter to watch. */
309 Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
310 * is about to be deleted. */
311 ClientData clientData; /* One-word value to pass to proc. */
312 {
313 Interp *iPtr = (Interp *) interp;
314 Tcl_HashTable *hTablePtr;
315 Tcl_HashSearch hSearch;
316 Tcl_HashEntry *hPtr;
317 AssocData *dPtr;
318
319 hTablePtr = iPtr->assocData;
320 if (hTablePtr == (Tcl_HashTable *) NULL) {
321 return;
322 }
323 for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
324 hPtr = Tcl_NextHashEntry(&hSearch)) {
325 dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
326 if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
327 ckfree((char *) dPtr);
328 Tcl_DeleteHashEntry(hPtr);
329 return;
330 }
331 }
332 }
333
334 /*
335 *----------------------------------------------------------------------
336 *
337 * Tcl_SetAssocData --
338 *
339 * Creates a named association between user-specified data, a delete
340 * function and this interpreter. If the association already exists
341 * the data is overwritten with the new data. The delete function will
342 * be invoked when the interpreter is deleted.
343 *
344 * Results:
345 * None.
346 *
347 * Side effects:
348 * Sets the associated data, creates the association if needed.
349 *
350 *----------------------------------------------------------------------
351 */
352
353 void
Tcl_SetAssocData(interp,name,proc,clientData)354 Tcl_SetAssocData(interp, name, proc, clientData)
355 Tcl_Interp *interp; /* Interpreter to associate with. */
356 char *name; /* Name for association. */
357 Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
358 * about to be deleted. */
359 ClientData clientData; /* One-word value to pass to proc. */
360 {
361 Interp *iPtr = (Interp *) interp;
362 AssocData *dPtr;
363 Tcl_HashEntry *hPtr;
364 int new;
365
366 if (iPtr->assocData == (Tcl_HashTable *) NULL) {
367 iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
368 Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
369 }
370 hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
371 if (new == 0) {
372 dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
373 } else {
374 dPtr = (AssocData *) ckalloc(sizeof(AssocData));
375 }
376 dPtr->proc = proc;
377 dPtr->clientData = clientData;
378
379 Tcl_SetHashValue(hPtr, dPtr);
380 }
381
382 /*
383 *----------------------------------------------------------------------
384 *
385 * Tcl_DeleteAssocData --
386 *
387 * Deletes a named association of user-specified data with
388 * the specified interpreter.
389 *
390 * Results:
391 * None.
392 *
393 * Side effects:
394 * Deletes the association.
395 *
396 *----------------------------------------------------------------------
397 */
398
399 void
Tcl_DeleteAssocData(interp,name)400 Tcl_DeleteAssocData(interp, name)
401 Tcl_Interp *interp; /* Interpreter to associate with. */
402 char *name; /* Name of association. */
403 {
404 Interp *iPtr = (Interp *) interp;
405 AssocData *dPtr;
406 Tcl_HashEntry *hPtr;
407
408 if (iPtr->assocData == (Tcl_HashTable *) NULL) {
409 return;
410 }
411 hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
412 if (hPtr == (Tcl_HashEntry *) NULL) {
413 return;
414 }
415 dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
416 if (dPtr->proc != NULL) {
417 (dPtr->proc) (dPtr->clientData, interp);
418 }
419 ckfree((char *) dPtr);
420 Tcl_DeleteHashEntry(hPtr);
421 }
422
423 /*
424 *----------------------------------------------------------------------
425 *
426 * Tcl_GetAssocData --
427 *
428 * Returns the client data associated with this name in the
429 * specified interpreter.
430 *
431 * Results:
432 * The client data in the AssocData record denoted by the named
433 * association, or NULL.
434 *
435 * Side effects:
436 * None.
437 *
438 *----------------------------------------------------------------------
439 */
440
441 ClientData
Tcl_GetAssocData(interp,name,procPtr)442 Tcl_GetAssocData(interp, name, procPtr)
443 Tcl_Interp *interp; /* Interpreter associated with. */
444 char *name; /* Name of association. */
445 Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
446 * of current deletion callback. */
447 {
448 Interp *iPtr = (Interp *) interp;
449 AssocData *dPtr;
450 Tcl_HashEntry *hPtr;
451
452 if (iPtr->assocData == (Tcl_HashTable *) NULL) {
453 return (ClientData) NULL;
454 }
455 hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
456 if (hPtr == (Tcl_HashEntry *) NULL) {
457 return (ClientData) NULL;
458 }
459 dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
460 if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
461 *procPtr = dPtr->proc;
462 }
463 return dPtr->clientData;
464 }
465
466 /*
467 *----------------------------------------------------------------------
468 *
469 * DeleteInterpProc --
470 *
471 * Helper procedure to delete an interpreter. This procedure is
472 * called when the last call to Tcl_Preserve on this interpreter
473 * is matched by a call to Tcl_Release. The procedure cleans up
474 * all resources used in the interpreter and calls all currently
475 * registered interpreter deletion callbacks.
476 *
477 * Results:
478 * None.
479 *
480 * Side effects:
481 * Whatever the interpreter deletion callbacks do. Frees resources
482 * used by the interpreter.
483 *
484 *----------------------------------------------------------------------
485 */
486
487 static void
DeleteInterpProc(interp)488 DeleteInterpProc(interp)
489 Tcl_Interp *interp; /* Interpreter to delete. */
490 {
491 Interp *iPtr = (Interp *) interp;
492 Tcl_HashEntry *hPtr;
493 Tcl_HashSearch search;
494 /* int i; */
495 Tcl_HashTable *hTablePtr;
496 AssocData *dPtr;
497
498 /*
499 * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
500 */
501
502 if (iPtr->numLevels > 0) {
503 panic("DeleteInterpProc called with active evals");
504 }
505
506 /*
507 * The interpreter should already be marked deleted; otherwise how
508 * did we get here?
509 */
510
511 if (!(iPtr->flags & DELETED)) {
512 panic("DeleteInterpProc called on interpreter not marked deleted");
513 }
514
515 /*
516 * Increment the interp deletion counter, so that close procedures
517 * for channel drivers can notice that we are in "implicit" close mode.
518 */
519
520 tclInInterpreterDeletion++;
521
522 /* DELETE ALL COMMANDS HERE */
523
524 for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
525 hPtr != NULL;
526 hPtr = Tcl_NextHashEntry(&search)) {
527 ckfree((char *) Tcl_GetHashValue(hPtr));
528 }
529 Tcl_DeleteHashTable(&iPtr->mathFuncTable);
530
531 /*
532 * Invoke deletion callbacks; note that a callback can create new
533 * callbacks, so we iterate.
534 */
535
536 while (iPtr->assocData != (Tcl_HashTable *) NULL) {
537 hTablePtr = iPtr->assocData;
538 iPtr->assocData = (Tcl_HashTable *) NULL;
539 for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
540 hPtr != NULL;
541 hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
542 dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
543 Tcl_DeleteHashEntry(hPtr);
544 if (dPtr->proc != NULL) {
545 (*dPtr->proc)(dPtr->clientData, interp);
546 }
547 ckfree((char *) dPtr);
548 }
549 Tcl_DeleteHashTable(hTablePtr);
550 ckfree((char *) hTablePtr);
551 }
552
553 /*
554 * Delete all global variables:
555 */
556
557 #if 0
558 TclDeleteVars(iPtr, &iPtr->globalTable);
559 #endif
560
561 /*
562 * Free up the result *after* deleting variables, since variable
563 * deletion could have transferred ownership of the result string
564 * to Tcl.
565 */
566
567 Tcl_FreeResult(interp);
568 interp->result = NULL;
569
570 if (iPtr->errorInfo != NULL) {
571 ckfree(iPtr->errorInfo);
572 iPtr->errorInfo = NULL;
573 }
574 if (iPtr->errorCode != NULL) {
575 ckfree(iPtr->errorCode);
576 iPtr->errorCode = NULL;
577 }
578 if (iPtr->appendResult != NULL) {
579 ckfree(iPtr->appendResult);
580 iPtr->appendResult = NULL;
581 }
582 #if 0
583 for (i = 0; i < NUM_REGEXPS; i++) {
584 if (iPtr->patterns[i] == NULL) {
585 break;
586 }
587 ckfree(iPtr->patterns[i]);
588 ckfree((char *) iPtr->regexps[i]);
589 iPtr->regexps[i] = NULL;
590 }
591 #endif
592 TclFreePackageInfo(iPtr);
593 #if 0 /* Traces not fully suppored yet */
594 while (iPtr->tracePtr != NULL) {
595 Trace *nextPtr = iPtr->tracePtr->nextPtr;
596
597 ckfree((char *) iPtr->tracePtr);
598 iPtr->tracePtr = nextPtr;
599 }
600 #endif
601
602 /*
603 * Finally decrement the nested interpreter deletion counter.
604 */
605
606 tclInInterpreterDeletion--;
607 if (tclInInterpreterDeletion < 0) {
608 tclInInterpreterDeletion = 0;
609 }
610
611 ckfree((char *) iPtr);
612 }
613
614 /*
615 *----------------------------------------------------------------------
616 *
617 * Tcl_InterpDeleted --
618 *
619 * Returns nonzero if the interpreter has been deleted with a call
620 * to Tcl_DeleteInterp.
621 *
622 * Results:
623 * Nonzero if the interpreter is deleted, zero otherwise.
624 *
625 * Side effects:
626 * None.
627 *
628 *----------------------------------------------------------------------
629 */
630
631 int
Tcl_InterpDeleted(interp)632 Tcl_InterpDeleted(interp)
633 Tcl_Interp *interp;
634 {
635 return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
636 }
637
638 /*
639 *----------------------------------------------------------------------
640 *
641 * Tcl_DeleteInterp --
642 *
643 * Ensures that the interpreter will be deleted eventually. If there
644 * are no Tcl_Preserve calls in effect for this interpreter, it is
645 * deleted immediately, otherwise the interpreter is deleted when
646 * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
647 * case, the procedure runs the currently registered deletion callbacks.
648 *
649 * Results:
650 * None.
651 *
652 * Side effects:
653 * The interpreter is marked as deleted. The caller may still use it
654 * safely if there are calls to Tcl_Preserve in effect for the
655 * interpreter, but further calls to Tcl_Eval etc in this interpreter
656 * will fail.
657 *
658 *----------------------------------------------------------------------
659 */
660
661 void
Tcl_DeleteInterp(interp)662 Tcl_DeleteInterp(interp)
663 Tcl_Interp *interp; /* Token for command interpreter (returned
664 * by a previous call to Tcl_CreateInterp). */
665 {
666 Interp *iPtr = (Interp *) interp;
667
668 /*
669 * If the interpreter has already been marked deleted, just punt.
670 */
671
672 if (iPtr->flags & DELETED) {
673 return;
674 }
675
676 /*
677 * Mark the interpreter as deleted. No further evals will be allowed.
678 */
679
680 iPtr->flags |= DELETED;
681
682 /*
683 * Ensure that the interpreter is eventually deleted.
684 */
685
686 Tcl_EventuallyFree((ClientData) interp,
687 (Tcl_FreeProc *) DeleteInterpProc);
688 }
689
690 /*
691 *----------------------------------------------------------------------
692 *
693 * Tcl_CreateTrace --
694 *
695 * Arrange for a procedure to be called to trace command execution.
696 *
697 * Results:
698 * The return value is a token for the trace, which may be passed
699 * to Tcl_DeleteTrace to eliminate the trace.
700 *
701 * Side effects:
702 * From now on, proc will be called just before a command procedure
703 * is called to execute a Tcl command. Calls to proc will have the
704 * following form:
705 *
706 * void
707 * proc(clientData, interp, level, command, cmdProc, cmdClientData,
708 * argc, argv)
709 * ClientData clientData;
710 * Tcl_Interp *interp;
711 * int level;
712 * char *command;
713 * int (*cmdProc)();
714 * ClientData cmdClientData;
715 * int argc;
716 * char **argv;
717 * {
718 * }
719 *
720 * The clientData and interp arguments to proc will be the same
721 * as the corresponding arguments to this procedure. Level gives
722 * the nesting level of command interpretation for this interpreter
723 * (0 corresponds to top level). Command gives the ASCII text of
724 * the raw command, cmdProc and cmdClientData give the procedure that
725 * will be called to process the command and the ClientData value it
726 * will receive, and argc and argv give the arguments to the
727 * command, after any argument parsing and substitution. Proc
728 * does not return a value.
729 *
730 *----------------------------------------------------------------------
731 */
732
733 Tcl_Trace
Tcl_CreateTrace(interp,level,proc,clientData)734 Tcl_CreateTrace(interp, level, proc, clientData)
735 Tcl_Interp *interp; /* Interpreter in which to create the trace. */
736 int level; /* Only call proc for commands at nesting level
737 * <= level (1 => top level). */
738 Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
739 * command. */
740 ClientData clientData; /* Arbitrary one-word value to pass to proc. */
741 {
742 register Trace *tracePtr;
743 register Interp *iPtr = (Interp *) interp;
744
745 tracePtr = (Trace *) ckalloc(sizeof(Trace));
746 tracePtr->level = level;
747 tracePtr->proc = proc;
748 tracePtr->clientData = clientData;
749 tracePtr->nextPtr = iPtr->tracePtr;
750 iPtr->tracePtr = tracePtr;
751
752 return (Tcl_Trace) tracePtr;
753 }
754
755 /*
756 *----------------------------------------------------------------------
757 *
758 * Tcl_DeleteTrace --
759 *
760 * Remove a trace.
761 *
762 * Results:
763 * None.
764 *
765 * Side effects:
766 * From now on there will be no more calls to the procedure given
767 * in trace.
768 *
769 *----------------------------------------------------------------------
770 */
771
772 void
Tcl_DeleteTrace(interp,trace)773 Tcl_DeleteTrace(interp, trace)
774 Tcl_Interp *interp; /* Interpreter that contains trace. */
775 Tcl_Trace trace; /* Token for trace (returned previously by
776 * Tcl_CreateTrace). */
777 {
778 register Interp *iPtr = (Interp *) interp;
779 register Trace *tracePtr = (Trace *) trace;
780 register Trace *tracePtr2;
781
782 if (iPtr->tracePtr == tracePtr) {
783 iPtr->tracePtr = tracePtr->nextPtr;
784 ckfree((char *) tracePtr);
785 } else {
786 for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
787 tracePtr2 = tracePtr2->nextPtr) {
788 if (tracePtr2->nextPtr == tracePtr) {
789 tracePtr2->nextPtr = tracePtr->nextPtr;
790 ckfree((char *) tracePtr);
791 return;
792 }
793 }
794 }
795 }
796
797 /*
798 *----------------------------------------------------------------------
799 *
800 * Tcl_AddErrorInfo --
801 *
802 * Add information to a message being accumulated that describes
803 * the current error.
804 *
805 * Results:
806 * None.
807 *
808 * Side effects:
809 * The contents of message are added to the "errorInfo" variable.
810 * If Tcl_Eval has been called since the current value of errorInfo
811 * was set, errorInfo is cleared before adding the new message.
812 *
813 *----------------------------------------------------------------------
814 */
815
816 void
Tcl_AddErrorInfo(interp,message)817 Tcl_AddErrorInfo(interp, message)
818 Tcl_Interp *interp; /* Interpreter to which error information
819 * pertains. */
820 char *message; /* Message to record. */
821 {
822 register Interp *iPtr = (Interp *) interp;
823
824 /*
825 * If an error is already being logged, then the new errorInfo
826 * is the concatenation of the old info and the new message.
827 * If this is the first piece of info for the error, then the
828 * new errorInfo is the concatenation of the message in
829 * interp->result and the new message.
830 */
831
832 if (!(iPtr->flags & ERR_IN_PROGRESS)) {
833 Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
834 TCL_GLOBAL_ONLY);
835 iPtr->flags |= ERR_IN_PROGRESS;
836
837 /*
838 * If the errorCode variable wasn't set by the code that generated
839 * the error, set it to "NONE".
840 */
841
842 if (!(iPtr->flags & ERROR_CODE_SET)) {
843 (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
844 TCL_GLOBAL_ONLY);
845 }
846 }
847 Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
848 TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
849 }
850
851 /*
852 *----------------------------------------------------------------------
853 *
854 * Tcl_VarEval --
855 *
856 * Given a variable number of string arguments, concatenate them
857 * all together and execute the result as a Tcl command.
858 *
859 * Results:
860 * A standard Tcl return result. An error message or other
861 * result may be left in interp->result.
862 *
863 * Side effects:
864 * Depends on what was done by the command.
865 *
866 *----------------------------------------------------------------------
867 */
868 /* VARARGS2 */ /* ARGSUSED */
869 int
TCL_VARARGS_DEF(Tcl_Interp *,arg1)870 Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
871 {
872 va_list argList;
873 Tcl_DString buf;
874 char *string;
875 Tcl_Interp *interp;
876 int result;
877
878 /*
879 * Copy the strings one after the other into a single larger
880 * string. Use stack-allocated space for small commands, but if
881 * the command gets too large than call ckalloc to create the
882 * space.
883 */
884
885 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
886 Tcl_DStringInit(&buf);
887 while (1) {
888 string = va_arg(argList, char *);
889 if (string == NULL) {
890 break;
891 }
892 Tcl_DStringAppend(&buf, string, -1);
893 }
894 va_end(argList);
895
896 result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
897 Tcl_DStringFree(&buf);
898 return result;
899 }
900
901 /*
902 *----------------------------------------------------------------------
903 *
904 * Tcl_SetRecursionLimit --
905 *
906 * Set the maximum number of recursive calls that may be active
907 * for an interpreter at once.
908 *
909 * Results:
910 * The return value is the old limit on nesting for interp.
911 *
912 * Side effects:
913 * None.
914 *
915 *----------------------------------------------------------------------
916 */
917
918 int
Tcl_SetRecursionLimit(interp,depth)919 Tcl_SetRecursionLimit(interp, depth)
920 Tcl_Interp *interp; /* Interpreter whose nesting limit
921 * is to be set. */
922 int depth; /* New value for maximimum depth. */
923 {
924 Interp *iPtr = (Interp *) interp;
925 int old;
926
927 old = iPtr->maxNestingDepth;
928 if (depth > 0) {
929 iPtr->maxNestingDepth = depth;
930 }
931 return old;
932 }
933
934 /*
935 *----------------------------------------------------------------------
936 *
937 * Tcl_AllowExceptions --
938 *
939 * Sets a flag in an interpreter so that exceptions can occur
940 * in the next call to Tcl_Eval without them being turned into
941 * errors.
942 *
943 * Results:
944 * None.
945 *
946 * Side effects:
947 * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
948 * evalFlags structure. See the reference documentation for
949 * more details.
950 *
951 *----------------------------------------------------------------------
952 */
953
954 void
Tcl_AllowExceptions(interp)955 Tcl_AllowExceptions(interp)
956 Tcl_Interp *interp; /* Interpreter in which to set flag. */
957 {
958 Interp *iPtr = (Interp *) interp;
959
960 iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
961 }
962