]> git.zerfleddert.de Git - micropolis/blob - src/tcl/tclbasic.c
fix colors on BGR displays
[micropolis] / src / tcl / tclbasic.c
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 1987-1992 Regents of the University of California
9 * Permission to use, copy, modify, and distribute this
10 * software and its documentation for any purpose and without
11 * fee is hereby granted, provided that the above copyright
12 * notice appear in all copies. The University of California
13 * makes no representations about the suitability of this
14 * software for any purpose. It is provided "as is" without
15 * express or implied warranty.
16 */
17
18 #ifndef lint
19 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclBasic.c,v 1.131 92/06/21 14:09:41 ouster Exp $ SPRITE (Berkeley)";
20 #endif
21
22 #include "tclint.h"
23
24 /*
25 * The following structure defines all of the commands in the Tcl core,
26 * and the C procedures that execute them.
27 */
28
29 typedef struct {
30 char *name; /* Name of command. */
31 Tcl_CmdProc *proc; /* Procedure that executes command. */
32 } CmdInfo;
33
34 /*
35 * Built-in commands, and the procedures associated with them:
36 */
37
38 static CmdInfo builtInCmds[] = {
39 /*
40 * Commands in the generic core:
41 */
42
43 {"append", Tcl_AppendCmd},
44 {"array", Tcl_ArrayCmd},
45 {"break", Tcl_BreakCmd},
46 {"case", Tcl_CaseCmd},
47 {"catch", Tcl_CatchCmd},
48 {"concat", Tcl_ConcatCmd},
49 {"continue", Tcl_ContinueCmd},
50 {"error", Tcl_ErrorCmd},
51 {"eval", Tcl_EvalCmd},
52 {"expr", Tcl_ExprCmd},
53 {"for", Tcl_ForCmd},
54 {"foreach", Tcl_ForeachCmd},
55 {"format", Tcl_FormatCmd},
56 {"global", Tcl_GlobalCmd},
57 {"if", Tcl_IfCmd},
58 {"incr", Tcl_IncrCmd},
59 {"info", Tcl_InfoCmd},
60 {"join", Tcl_JoinCmd},
61 {"lappend", Tcl_LappendCmd},
62 {"lindex", Tcl_LindexCmd},
63 {"linsert", Tcl_LinsertCmd},
64 {"list", Tcl_ListCmd},
65 {"llength", Tcl_LlengthCmd},
66 {"lrange", Tcl_LrangeCmd},
67 {"lreplace", Tcl_LreplaceCmd},
68 {"lsearch", Tcl_LsearchCmd},
69 {"lsort", Tcl_LsortCmd},
70 {"proc", Tcl_ProcCmd},
71 {"regexp", Tcl_RegexpCmd},
72 {"regsub", Tcl_RegsubCmd},
73 {"rename", Tcl_RenameCmd},
74 {"return", Tcl_ReturnCmd},
75 {"scan", Tcl_ScanCmd},
76 {"set", Tcl_SetCmd},
77 {"split", Tcl_SplitCmd},
78 {"string", Tcl_StringCmd},
79 {"trace", Tcl_TraceCmd},
80 {"unset", Tcl_UnsetCmd},
81 {"uplevel", Tcl_UplevelCmd},
82 {"upvar", Tcl_UpvarCmd},
83 {"while", Tcl_WhileCmd},
84
85 /*
86 * Commands in the UNIX core:
87 */
88
89 #ifndef TCL_GENERIC_ONLY
90 {"cd", Tcl_CdCmd},
91 {"close", Tcl_CloseCmd},
92 {"eof", Tcl_EofCmd},
93 {"exec", Tcl_ExecCmd},
94 {"exit", Tcl_ExitCmd},
95 {"file", Tcl_FileCmd},
96 {"flush", Tcl_FlushCmd},
97 {"gets", Tcl_GetsCmd},
98 {"glob", Tcl_GlobCmd},
99 {"open", Tcl_OpenCmd},
100 {"puts", Tcl_PutsCmd},
101 {"pwd", Tcl_PwdCmd},
102 {"read", Tcl_ReadCmd},
103 {"seek", Tcl_SeekCmd},
104 {"source", Tcl_SourceCmd},
105 {"tell", Tcl_TellCmd},
106 {"time", Tcl_TimeCmd},
107 #endif /* TCL_GENERIC_ONLY */
108 {NULL, (Tcl_CmdProc *) NULL}
109 };
110 \f
111 /*
112 *----------------------------------------------------------------------
113 *
114 * Tcl_CreateInterp --
115 *
116 * Create a new TCL command interpreter.
117 *
118 * Results:
119 * The return value is a token for the interpreter, which may be
120 * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
121 * Tcl_DeleteInterp.
122 *
123 * Side effects:
124 * The command interpreter is initialized with an empty variable
125 * table and the built-in commands.
126 *
127 *----------------------------------------------------------------------
128 */
129
130 Tcl_Interp *
131 Tcl_CreateInterp()
132 {
133 register Interp *iPtr;
134 register Command *cmdPtr;
135 register CmdInfo *cmdInfoPtr;
136 int i;
137
138 iPtr = (Interp *) ckalloc(sizeof(Interp));
139 iPtr->result = iPtr->resultSpace;
140 iPtr->freeProc = 0;
141 iPtr->errorLine = 0;
142 Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
143 Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
144 iPtr->numLevels = 0;
145 iPtr->framePtr = NULL;
146 iPtr->varFramePtr = NULL;
147 iPtr->activeTracePtr = NULL;
148 iPtr->numEvents = 0;
149 iPtr->events = NULL;
150 iPtr->curEvent = 0;
151 iPtr->curEventNum = 0;
152 iPtr->revPtr = NULL;
153 iPtr->historyFirst = NULL;
154 iPtr->revDisables = 1;
155 iPtr->evalFirst = iPtr->evalLast = NULL;
156 iPtr->appendResult = NULL;
157 iPtr->appendAvl = 0;
158 iPtr->appendUsed = 0;
159 iPtr->numFiles = 0;
160 iPtr->filePtrArray = NULL;
161 for (i = 0; i < NUM_REGEXPS; i++) {
162 iPtr->patterns[i] = NULL;
163 iPtr->patLengths[i] = -1;
164 iPtr->regexps[i] = NULL;
165 }
166 iPtr->cmdCount = 0;
167 iPtr->noEval = 0;
168 iPtr->scriptFile = NULL;
169 iPtr->flags = 0;
170 iPtr->tracePtr = NULL;
171 iPtr->resultSpace[0] = 0;
172
173 /*
174 * Create the built-in commands. Do it here, rather than calling
175 * Tcl_CreateCommand, because it's faster (there's no need to
176 * check for a pre-existing command by the same name).
177 */
178
179 for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
180 int new;
181 Tcl_HashEntry *hPtr;
182
183 hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
184 cmdInfoPtr->name, &new);
185 if (new) {
186 cmdPtr = (Command *) ckalloc(sizeof(Command));
187 cmdPtr->proc = cmdInfoPtr->proc;
188 cmdPtr->clientData = (ClientData) NULL;
189 cmdPtr->deleteProc = NULL;
190 Tcl_SetHashValue(hPtr, cmdPtr);
191 }
192 }
193
194 #ifndef TCL_GENERIC_ONLY
195 TclSetupEnv((Tcl_Interp *) iPtr);
196 #endif
197
198 return (Tcl_Interp *) iPtr;
199 }
200 \f
201 /*
202 *----------------------------------------------------------------------
203 *
204 * Tcl_DeleteInterp --
205 *
206 * Delete an interpreter and free up all of the resources associated
207 * with it.
208 *
209 * Results:
210 * None.
211 *
212 * Side effects:
213 * The interpreter is destroyed. The caller should never again
214 * use the interp token.
215 *
216 *----------------------------------------------------------------------
217 */
218
219 void
220 Tcl_DeleteInterp(interp)
221 Tcl_Interp *interp; /* Token for command interpreter (returned
222 * by a previous call to Tcl_CreateInterp). */
223 {
224 Interp *iPtr = (Interp *) interp;
225 Tcl_HashEntry *hPtr;
226 Tcl_HashSearch search;
227 register Command *cmdPtr;
228 int i;
229
230 /*
231 * If the interpreter is in use, delay the deletion until later.
232 */
233
234 iPtr->flags |= DELETED;
235 if (iPtr->numLevels != 0) {
236 return;
237 }
238
239 /*
240 * Free up any remaining resources associated with the
241 * interpreter.
242 */
243
244 for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
245 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
246 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
247 if (cmdPtr->deleteProc != NULL) {
248 (*cmdPtr->deleteProc)(cmdPtr->clientData);
249 }
250 ckfree((char *) cmdPtr);
251 }
252 Tcl_DeleteHashTable(&iPtr->commandTable);
253 TclDeleteVars(iPtr, &iPtr->globalTable);
254 if (iPtr->events != NULL) {
255 int i;
256
257 for (i = 0; i < iPtr->numEvents; i++) {
258 ckfree(iPtr->events[i].command);
259 }
260 ckfree((char *) iPtr->events);
261 }
262 while (iPtr->revPtr != NULL) {
263 HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
264
265 ckfree((char *) iPtr->revPtr);
266 iPtr->revPtr = nextPtr;
267 }
268 if (iPtr->appendResult != NULL) {
269 ckfree(iPtr->appendResult);
270 }
271 #ifndef TCL_GENERIC_ONLY
272 if (iPtr->numFiles > 0) {
273 for (i = 0; i < iPtr->numFiles; i++) {
274 OpenFile *filePtr;
275
276 filePtr = iPtr->filePtrArray[i];
277 if (filePtr == NULL) {
278 continue;
279 }
280 if (i >= 3) {
281 fclose(filePtr->f);
282 if (filePtr->f2 != NULL) {
283 fclose(filePtr->f2);
284 }
285 if (filePtr->numPids > 0) {
286 Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
287 ckfree((char *) filePtr->pidPtr);
288 }
289 }
290 ckfree((char *) filePtr);
291 }
292 ckfree((char *) iPtr->filePtrArray);
293 }
294 #endif
295 for (i = 0; i < NUM_REGEXPS; i++) {
296 if (iPtr->patterns[i] == NULL) {
297 break;
298 }
299 ckfree(iPtr->patterns[i]);
300 ckfree((char *) iPtr->regexps[i]);
301 }
302 while (iPtr->tracePtr != NULL) {
303 Trace *nextPtr = iPtr->tracePtr->nextPtr;
304
305 ckfree((char *) iPtr->tracePtr);
306 iPtr->tracePtr = nextPtr;
307 }
308 ckfree((char *) iPtr);
309 }
310 \f
311 /*
312 *----------------------------------------------------------------------
313 *
314 * Tcl_CreateCommand --
315 *
316 * Define a new command in a command table.
317 *
318 * Results:
319 * None.
320 *
321 * Side effects:
322 * If a command named cmdName already exists for interp, it is
323 * deleted. In the future, when cmdName is seen as the name of
324 * a command by Tcl_Eval, proc will be called. When the command
325 * is deleted from the table, deleteProc will be called. See the
326 * manual entry for details on the calling sequence.
327 *
328 *----------------------------------------------------------------------
329 */
330
331 void
332 Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
333 Tcl_Interp *interp; /* Token for command interpreter (returned
334 * by a previous call to Tcl_CreateInterp). */
335 char *cmdName; /* Name of command. */
336 Tcl_CmdProc *proc; /* Command procedure to associate with
337 * cmdName. */
338 ClientData clientData; /* Arbitrary one-word value to pass to proc. */
339 Tcl_CmdDeleteProc *deleteProc;
340 /* If not NULL, gives a procedure to call when
341 * this command is deleted. */
342 {
343 Interp *iPtr = (Interp *) interp;
344 register Command *cmdPtr;
345 Tcl_HashEntry *hPtr;
346 int new;
347
348 hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
349 if (!new) {
350 /*
351 * Command already exists: delete the old one.
352 */
353
354 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
355 if (cmdPtr->deleteProc != NULL) {
356 (*cmdPtr->deleteProc)(cmdPtr->clientData);
357 }
358 } else {
359 cmdPtr = (Command *) ckalloc(sizeof(Command));
360 Tcl_SetHashValue(hPtr, cmdPtr);
361 }
362 cmdPtr->proc = proc;
363 cmdPtr->clientData = clientData;
364 cmdPtr->deleteProc = deleteProc;
365 }
366 \f
367 /*
368 *----------------------------------------------------------------------
369 *
370 * Tcl_DeleteCommand --
371 *
372 * Remove the given command from the given interpreter.
373 *
374 * Results:
375 * 0 is returned if the command was deleted successfully.
376 * -1 is returned if there didn't exist a command by that
377 * name.
378 *
379 * Side effects:
380 * CmdName will no longer be recognized as a valid command for
381 * interp.
382 *
383 *----------------------------------------------------------------------
384 */
385
386 int
387 Tcl_DeleteCommand(interp, cmdName)
388 Tcl_Interp *interp; /* Token for command interpreter (returned
389 * by a previous call to Tcl_CreateInterp). */
390 char *cmdName; /* Name of command to remove. */
391 {
392 Interp *iPtr = (Interp *) interp;
393 Tcl_HashEntry *hPtr;
394 Command *cmdPtr;
395
396 hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
397 if (hPtr == NULL) {
398 return -1;
399 }
400 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
401 if (cmdPtr->deleteProc != NULL) {
402 (*cmdPtr->deleteProc)(cmdPtr->clientData);
403 }
404 ckfree((char *) cmdPtr);
405 Tcl_DeleteHashEntry(hPtr);
406 return 0;
407 }
408 \f
409 /*
410 *-----------------------------------------------------------------
411 *
412 * Tcl_Eval --
413 *
414 * Parse and execute a command in the Tcl language.
415 *
416 * Results:
417 * The return value is one of the return codes defined in tcl.hd
418 * (such as TCL_OK), and interp->result contains a string value
419 * to supplement the return code. The value of interp->result
420 * will persist only until the next call to Tcl_Eval: copy it or
421 * lose it! *TermPtr is filled in with the character just after
422 * the last one that was part of the command (usually a NULL
423 * character or a closing bracket).
424 *
425 * Side effects:
426 * Almost certainly; depends on the command.
427 *
428 *-----------------------------------------------------------------
429 */
430
431 int
432 Tcl_Eval(interp, cmd, flags, termPtr)
433 Tcl_Interp *interp; /* Token for command interpreter (returned
434 * by a previous call to Tcl_CreateInterp). */
435 char *cmd; /* Pointer to TCL command to interpret. */
436 int flags; /* OR-ed combination of flags like
437 * TCL_BRACKET_TERM and TCL_RECORD_BOUNDS. */
438 char **termPtr; /* If non-NULL, fill in the address it points
439 * to with the address of the char. just after
440 * the last one that was part of cmd. See
441 * the man page for details on this. */
442 {
443 /*
444 * The storage immediately below is used to generate a copy
445 * of the command, after all argument substitutions. Pv will
446 * contain the argv values passed to the command procedure.
447 */
448
449 # define NUM_CHARS 200
450 char copyStorage[NUM_CHARS];
451 ParseValue pv;
452 char *oldBuffer;
453
454 /*
455 * This procedure generates an (argv, argc) array for the command,
456 * It starts out with stack-allocated space but uses dynamically-
457 * allocated storage to increase it if needed.
458 */
459
460 # define NUM_ARGS 10
461 char *(argStorage[NUM_ARGS]);
462 char **argv = argStorage;
463 int argc;
464 int argSize = NUM_ARGS;
465
466 register char *src; /* Points to current character
467 * in cmd. */
468 char termChar; /* Return when this character is found
469 * (either ']' or '\0'). Zero means
470 * that newlines terminate commands. */
471 int result; /* Return value. */
472 register Interp *iPtr = (Interp *) interp;
473 Tcl_HashEntry *hPtr;
474 Command *cmdPtr;
475 char *dummy; /* Make termPtr point here if it was
476 * originally NULL. */
477 char *cmdStart; /* Points to first non-blank char. in
478 * command (used in calling trace
479 * procedures). */
480 char *ellipsis = ""; /* Used in setting errorInfo variable;
481 * set to "..." to indicate that not
482 * all of offending command is included
483 * in errorInfo. "" means that the
484 * command is all there. */
485 register Trace *tracePtr;
486
487 /*
488 * Initialize the result to an empty string and clear out any
489 * error information. This makes sure that we return an empty
490 * result if there are no commands in the command string.
491 */
492
493 Tcl_FreeResult((Tcl_Interp *) iPtr);
494 iPtr->result = iPtr->resultSpace;
495 iPtr->resultSpace[0] = 0;
496 result = TCL_OK;
497
498 /*
499 * Check depth of nested calls to Tcl_Eval: if this gets too large,
500 * it's probably because of an infinite loop somewhere.
501 */
502
503 iPtr->numLevels++;
504 if (iPtr->numLevels > MAX_NESTING_DEPTH) {
505 iPtr->numLevels--;
506 iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
507 return TCL_ERROR;
508 }
509
510 /*
511 * Initialize the area in which command copies will be assembled.
512 */
513
514 pv.buffer = copyStorage;
515 pv.end = copyStorage + NUM_CHARS - 1;
516 pv.expandProc = TclExpandParseValue;
517 pv.clientData = (ClientData) NULL;
518
519 src = cmd;
520 if (flags & TCL_BRACKET_TERM) {
521 termChar = ']';
522 } else {
523 termChar = 0;
524 }
525 if (termPtr == NULL) {
526 termPtr = &dummy;
527 }
528 *termPtr = src;
529 cmdStart = src;
530
531 /*
532 * There can be many sub-commands (separated by semi-colons or
533 * newlines) in one command string. This outer loop iterates over
534 * individual commands.
535 */
536
537 while (*src != termChar) {
538 iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
539
540 /*
541 * Skim off leading white space and semi-colons, and skip
542 * comments.
543 */
544
545 while (1) {
546 register char c = *src;
547
548 if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
549 break;
550 }
551 src += 1;
552 }
553 if (*src == '#') {
554 for (src++; *src != 0; src++) {
555 if (*src == '\n') {
556 src++;
557 break;
558 }
559 }
560 continue;
561 }
562 cmdStart = src;
563
564 /*
565 * Parse the words of the command, generating the argc and
566 * argv for the command procedure. May have to call
567 * TclParseWords several times, expanding the argv array
568 * between calls.
569 */
570
571 pv.next = oldBuffer = pv.buffer;
572 argc = 0;
573 while (1) {
574 int newArgs, maxArgs;
575 char **newArgv;
576 int i;
577
578 /*
579 * Note: the "- 2" below guarantees that we won't use the
580 * last two argv slots here. One is for a NULL pointer to
581 * mark the end of the list, and the other is to leave room
582 * for inserting the command name "unknown" as the first
583 * argument (see below).
584 */
585
586 maxArgs = argSize - argc - 2;
587 result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
588 maxArgs, termPtr, &newArgs, &argv[argc], &pv);
589 src = *termPtr;
590 if (result != TCL_OK) {
591 ellipsis = "...";
592 goto done;
593 }
594
595 /*
596 * Careful! Buffer space may have gotten reallocated while
597 * parsing words. If this happened, be sure to update all
598 * of the older argv pointers to refer to the new space.
599 */
600
601 if (oldBuffer != pv.buffer) {
602 int i;
603
604 for (i = 0; i < argc; i++) {
605 argv[i] = pv.buffer + (argv[i] - oldBuffer);
606 }
607 oldBuffer = pv.buffer;
608 }
609 argc += newArgs;
610 if (newArgs < maxArgs) {
611 argv[argc] = (char *) NULL;
612 break;
613 }
614
615 /*
616 * Args didn't all fit in the current array. Make it bigger.
617 */
618
619 argSize *= 2;
620 newArgv = (char **)
621 ckalloc((unsigned) argSize * sizeof(char *));
622 for (i = 0; i < argc; i++) {
623 newArgv[i] = argv[i];
624 }
625 if (argv != argStorage) {
626 ckfree((char *) argv);
627 }
628 argv = newArgv;
629 }
630
631 /*
632 * If this is an empty command (or if we're just parsing
633 * commands without evaluating them), then just skip to the
634 * next command.
635 */
636
637 if ((argc == 0) || iPtr->noEval) {
638 continue;
639 }
640 argv[argc] = NULL;
641
642 /*
643 * Save information for the history module, if needed.
644 */
645
646 if (flags & TCL_RECORD_BOUNDS) {
647 iPtr->evalFirst = cmdStart;
648 iPtr->evalLast = src-1;
649 }
650
651 /*
652 * Find the procedure to execute this command. If there isn't
653 * one, then see if there is a command "unknown". If so,
654 * invoke it instead, passing it the words of the original
655 * command as arguments.
656 */
657
658 hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
659 if (hPtr == NULL) {
660 int i;
661
662 hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
663 if (hPtr == NULL) {
664 Tcl_ResetResult(interp);
665 Tcl_AppendResult(interp, "invalid command name: \"",
666 argv[0], "\"", (char *) NULL);
667 result = TCL_ERROR;
668 goto done;
669 }
670 for (i = argc; i >= 0; i--) {
671 argv[i+1] = argv[i];
672 }
673 argv[0] = "unknown";
674 argc++;
675 }
676 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
677
678 /*
679 * Call trace procedures, if any.
680 */
681
682 for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
683 tracePtr = tracePtr->nextPtr) {
684 char saved;
685
686 if (tracePtr->level < iPtr->numLevels) {
687 continue;
688 }
689 saved = *src;
690 *src = 0;
691 (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
692 cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
693 *src = saved;
694 }
695
696 /*
697 * At long last, invoke the command procedure. Reset the
698 * result to its default empty value first (it could have
699 * gotten changed by earlier commands in the same command
700 * string).
701 */
702
703 iPtr->cmdCount++;
704 Tcl_FreeResult(iPtr);
705 iPtr->result = iPtr->resultSpace;
706 iPtr->resultSpace[0] = 0;
707 result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
708 if (result != TCL_OK) {
709 break;
710 }
711 }
712
713 /*
714 * Free up any extra resources that were allocated.
715 */
716
717 done:
718 if (pv.buffer != copyStorage) {
719 ckfree((char *) pv.buffer);
720 }
721 if (argv != argStorage) {
722 ckfree((char *) argv);
723 }
724 iPtr->numLevels--;
725 if (iPtr->numLevels == 0) {
726 if (result == TCL_RETURN) {
727 result = TCL_OK;
728 }
729 if ((result != TCL_OK) && (result != TCL_ERROR)) {
730 Tcl_ResetResult(interp);
731 if (result == TCL_BREAK) {
732 iPtr->result = "invoked \"break\" outside of a loop";
733 } else if (result == TCL_CONTINUE) {
734 iPtr->result = "invoked \"continue\" outside of a loop";
735 } else {
736 iPtr->result = iPtr->resultSpace;
737 sprintf(iPtr->resultSpace, "command returned bad code: %d",
738 result);
739 }
740 result = TCL_ERROR;
741 }
742 if (iPtr->flags & DELETED) {
743 Tcl_DeleteInterp(interp);
744 }
745 }
746
747 /*
748 * If an error occurred, record information about what was being
749 * executed when the error occurred.
750 */
751
752 if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
753 int numChars;
754 register char *p;
755
756 /*
757 * Compute the line number where the error occurred.
758 */
759
760 iPtr->errorLine = 1;
761 for (p = cmd; p != cmdStart; p++) {
762 if (*p == '\n') {
763 iPtr->errorLine++;
764 }
765 }
766 for ( ; isspace(*p) || (*p == ';'); p++) {
767 if (*p == '\n') {
768 iPtr->errorLine++;
769 }
770 }
771
772 /*
773 * Figure out how much of the command to print in the error
774 * message (up to a certain number of characters, or up to
775 * the first new-line).
776 */
777
778 numChars = src - cmdStart;
779 if (numChars > (NUM_CHARS-50)) {
780 numChars = NUM_CHARS-50;
781 ellipsis = " ...";
782 }
783
784 if (!(iPtr->flags & ERR_IN_PROGRESS)) {
785 sprintf(copyStorage, "\n while executing\n\"%.*s%s\"",
786 numChars, cmdStart, ellipsis);
787 } else {
788 sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"",
789 numChars, cmdStart, ellipsis);
790 }
791 Tcl_AddErrorInfo(interp, copyStorage);
792 iPtr->flags &= ~ERR_ALREADY_LOGGED;
793 } else {
794 iPtr->flags &= ~ERR_ALREADY_LOGGED;
795 }
796 return result;
797 }
798 \f
799 /*
800 *----------------------------------------------------------------------
801 *
802 * Tcl_CreateTrace --
803 *
804 * Arrange for a procedure to be called to trace command execution.
805 *
806 * Results:
807 * The return value is a token for the trace, which may be passed
808 * to Tcl_DeleteTrace to eliminate the trace.
809 *
810 * Side effects:
811 * From now on, proc will be called just before a command procedure
812 * is called to execute a Tcl command. Calls to proc will have the
813 * following form:
814 *
815 * void
816 * proc(clientData, interp, level, command, cmdProc, cmdClientData,
817 * argc, argv)
818 * ClientData clientData;
819 * Tcl_Interp *interp;
820 * int level;
821 * char *command;
822 * int (*cmdProc)();
823 * ClientData cmdClientData;
824 * int argc;
825 * char **argv;
826 * {
827 * }
828 *
829 * The clientData and interp arguments to proc will be the same
830 * as the corresponding arguments to this procedure. Level gives
831 * the nesting level of command interpretation for this interpreter
832 * (0 corresponds to top level). Command gives the ASCII text of
833 * the raw command, cmdProc and cmdClientData give the procedure that
834 * will be called to process the command and the ClientData value it
835 * will receive, and argc and argv give the arguments to the
836 * command, after any argument parsing and substitution. Proc
837 * does not return a value.
838 *
839 *----------------------------------------------------------------------
840 */
841
842 Tcl_Trace
843 Tcl_CreateTrace(interp, level, proc, clientData)
844 Tcl_Interp *interp; /* Interpreter in which to create the trace. */
845 int level; /* Only call proc for commands at nesting level
846 * <= level (1 => top level). */
847 Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
848 * command. */
849 ClientData clientData; /* Arbitrary one-word value to pass to proc. */
850 {
851 register Trace *tracePtr;
852 register Interp *iPtr = (Interp *) interp;
853
854 tracePtr = (Trace *) ckalloc(sizeof(Trace));
855 tracePtr->level = level;
856 tracePtr->proc = proc;
857 tracePtr->clientData = clientData;
858 tracePtr->nextPtr = iPtr->tracePtr;
859 iPtr->tracePtr = tracePtr;
860
861 return (Tcl_Trace) tracePtr;
862 }
863 \f
864 /*
865 *----------------------------------------------------------------------
866 *
867 * Tcl_DeleteTrace --
868 *
869 * Remove a trace.
870 *
871 * Results:
872 * None.
873 *
874 * Side effects:
875 * From now on there will be no more calls to the procedure given
876 * in trace.
877 *
878 *----------------------------------------------------------------------
879 */
880
881 void
882 Tcl_DeleteTrace(interp, trace)
883 Tcl_Interp *interp; /* Interpreter that contains trace. */
884 Tcl_Trace trace; /* Token for trace (returned previously by
885 * Tcl_CreateTrace). */
886 {
887 register Interp *iPtr = (Interp *) interp;
888 register Trace *tracePtr = (Trace *) trace;
889 register Trace *tracePtr2;
890
891 if (iPtr->tracePtr == tracePtr) {
892 iPtr->tracePtr = tracePtr->nextPtr;
893 ckfree((char *) tracePtr);
894 } else {
895 for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
896 tracePtr2 = tracePtr2->nextPtr) {
897 if (tracePtr2->nextPtr == tracePtr) {
898 tracePtr2->nextPtr = tracePtr->nextPtr;
899 ckfree((char *) tracePtr);
900 return;
901 }
902 }
903 }
904 }
905 \f
906 /*
907 *----------------------------------------------------------------------
908 *
909 * Tcl_AddErrorInfo --
910 *
911 * Add information to a message being accumulated that describes
912 * the current error.
913 *
914 * Results:
915 * None.
916 *
917 * Side effects:
918 * The contents of message are added to the "errorInfo" variable.
919 * If Tcl_Eval has been called since the current value of errorInfo
920 * was set, errorInfo is cleared before adding the new message.
921 *
922 *----------------------------------------------------------------------
923 */
924
925 void
926 Tcl_AddErrorInfo(interp, message)
927 Tcl_Interp *interp; /* Interpreter to which error information
928 * pertains. */
929 char *message; /* Message to record. */
930 {
931 register Interp *iPtr = (Interp *) interp;
932
933 /*
934 * If an error is already being logged, then the new errorInfo
935 * is the concatenation of the old info and the new message.
936 * If this is the first piece of info for the error, then the
937 * new errorInfo is the concatenation of the message in
938 * interp->result and the new message.
939 */
940
941 if (!(iPtr->flags & ERR_IN_PROGRESS)) {
942 Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
943 TCL_GLOBAL_ONLY);
944 iPtr->flags |= ERR_IN_PROGRESS;
945
946 /*
947 * If the errorCode variable wasn't set by the code that generated
948 * the error, set it to "NONE".
949 */
950
951 if (!(iPtr->flags & ERROR_CODE_SET)) {
952 (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
953 TCL_GLOBAL_ONLY);
954 }
955 }
956 Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
957 TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
958 }
959 \f
960 /*
961 *----------------------------------------------------------------------
962 *
963 * Tcl_VarEval --
964 *
965 * Given a variable number of string arguments, concatenate them
966 * all together and execute the result as a Tcl command.
967 *
968 * Results:
969 * A standard Tcl return result. An error message or other
970 * result may be left in interp->result.
971 *
972 * Side effects:
973 * Depends on what was done by the command.
974 *
975 *----------------------------------------------------------------------
976 */
977 int
978 Tcl_VarEval(Tcl_Interp *interp, ...)
979 {
980 va_list argList;
981 #define FIXED_SIZE 200
982 char fixedSpace[FIXED_SIZE+1];
983 int spaceAvl, spaceUsed, length;
984 char *string, *cmd;
985 int result;
986
987 /*
988 * Copy the strings one after the other into a single larger
989 * string. Use stack-allocated space for small commands, but if
990 * the commands gets too large than call ckalloc to create the
991 * space.
992 */
993
994 va_start(argList, interp);
995 spaceAvl = FIXED_SIZE;
996 spaceUsed = 0;
997 cmd = fixedSpace;
998 while (1) {
999 string = va_arg(argList, char *);
1000 if (string == NULL) {
1001 break;
1002 }
1003 length = strlen(string);
1004 if ((spaceUsed + length) > spaceAvl) {
1005 char *new;
1006
1007 spaceAvl = spaceUsed + length;
1008 spaceAvl += spaceAvl/2;
1009 new = ckalloc((unsigned) spaceAvl);
1010 memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
1011 if (cmd != fixedSpace) {
1012 ckfree(cmd);
1013 }
1014 cmd = new;
1015 }
1016 strcpy(cmd + spaceUsed, string);
1017 spaceUsed += length;
1018 }
1019 va_end(argList);
1020 cmd[spaceUsed] = '\0';
1021
1022 result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
1023 if (cmd != fixedSpace) {
1024 ckfree(cmd);
1025 }
1026 return result;
1027 }
1028 \f
1029 /*
1030 *----------------------------------------------------------------------
1031 *
1032 * Tcl_GlobalEval --
1033 *
1034 * Evaluate a command at global level in an interpreter.
1035 *
1036 * Results:
1037 * A standard Tcl result is returned, and interp->result is
1038 * modified accordingly.
1039 *
1040 * Side effects:
1041 * The command string is executed in interp, and the execution
1042 * is carried out in the variable context of global level (no
1043 * procedures active), just as if an "uplevel #0" command were
1044 * being executed.
1045 *
1046 *----------------------------------------------------------------------
1047 */
1048
1049 int
1050 Tcl_GlobalEval(interp, command)
1051 Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
1052 char *command; /* Command to evaluate. */
1053 {
1054 register Interp *iPtr = (Interp *) interp;
1055 int result;
1056 CallFrame *savedVarFramePtr;
1057
1058 savedVarFramePtr = iPtr->varFramePtr;
1059 iPtr->varFramePtr = NULL;
1060 result = Tcl_Eval(interp, command, 0, (char **) NULL);
1061 iPtr->varFramePtr = savedVarFramePtr;
1062 return result;
1063 }
Impressum, Datenschutz