![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclbasic.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tcl|
Return to tclbasic.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 root 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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.