![[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 [Research Unix] / researchv10no / cmd / worm / scsi / tcl|
Return to tclBasic.c CVS log | Up to [Research Unix] / researchv10no / cmd / worm / scsi / 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, 1990 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: /sprite/src/lib/tcl/RCS/tclBasic.c,v 1.72 90/03/29 10:36:39 ouster Exp $ SPRITE (Berkeley)";
20: #pragma ref rcsid
21: #endif not lint
22:
23: #define _POSIX_SOURCE
24:
25: #include <stdio.h>
26: #include <ctype.h>
27: #include <stdlib.h>
28: #include <string.h>
29: #include "tclInt.h"
30:
31: /*
32: * Built-in commands, and the procedures associated with them:
33: */
34:
35: static char *builtInCmds[] = {
36: "break",
37: "case",
38: "catch",
39: "concat",
40: "continue",
41: "error",
42: "eval",
43: "exec",
44: "expr",
45: "file",
46: "for",
47: "foreach",
48: "format",
49: "glob",
50: "global",
51: "if",
52: "index",
53: "info",
54: "length",
55: "list",
56: "print",
57: "proc",
58: "range",
59: "rename",
60: "return",
61: "scan",
62: "set",
63: "source",
64: "string",
65: "time",
66: "uplevel",
67: NULL
68: };
69:
70: static int (*(builtInProcs[]))(ClientData , Tcl_Interp *, int , char **) = {
71: Tcl_BreakCmd,
72: Tcl_CaseCmd,
73: Tcl_CatchCmd,
74: Tcl_ConcatCmd,
75: Tcl_ContinueCmd,
76: Tcl_ErrorCmd,
77: Tcl_EvalCmd,
78: Tcl_ExecCmd,
79: Tcl_ExprCmd,
80: Tcl_FileCmd,
81: Tcl_ForCmd,
82: Tcl_ForeachCmd,
83: Tcl_FormatCmd,
84: Tcl_GlobCmd,
85: Tcl_GlobalCmd,
86: Tcl_IfCmd,
87: Tcl_IndexCmd,
88: Tcl_InfoCmd,
89: Tcl_LengthCmd,
90: Tcl_ListCmd,
91: Tcl_PrintCmd,
92: Tcl_ProcCmd,
93: Tcl_RangeCmd,
94: Tcl_RenameCmd,
95: Tcl_ReturnCmd,
96: Tcl_ScanCmd,
97: Tcl_SetCmd,
98: Tcl_SourceCmd,
99: Tcl_StringCmd,
100: Tcl_TimeCmd,
101: Tcl_UplevelCmd,
102: NULL
103: };
104:
105: /*
106: *----------------------------------------------------------------------
107: *
108: * Tcl_CreateInterp --
109: *
110: * Create a new TCL command interpreter.
111: *
112: * Results:
113: * The return value is a token for the interpreter, which may be
114: * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
115: * Tcl_DeleteInterp.
116: *
117: * Side effects:
118: * The command interpreter is initialized with an empty variable
119: * table and the built-in commands.
120: *
121: *----------------------------------------------------------------------
122: */
123:
124: Tcl_Interp *
125: Tcl_CreateInterp()
126: {
127: register Interp *iPtr;
128: register char **namePtr;
129: register int (**procPtr)();
130: register Command *cmdPtr;
131:
132: iPtr = (Interp *) malloc(sizeof(Interp));
133: iPtr->result = iPtr->resultSpace;
134: iPtr->dynamic = 0;
135: iPtr->errorLine = 0;
136: iPtr->commandPtr = NULL;
137: iPtr->globalPtr = NULL;
138: iPtr->numLevels = 0;
139: iPtr->framePtr = NULL;
140: iPtr->varFramePtr = NULL;
141: iPtr->numEvents = 0;
142: iPtr->events = NULL;
143: iPtr->curEvent = 0;
144: iPtr->curEventNum = 0;
145: iPtr->revPtr = NULL;
146: iPtr->historyFirst = NULL;
147: iPtr->evalFirst = iPtr->evalLast = NULL;
148: iPtr->cmdCount = 0;
149: iPtr->noEval = 0;
150: iPtr->flags = 0;
151: iPtr->tracePtr = NULL;
152: iPtr->callbackPtr = NULL;
153: iPtr->resultSpace[0] = 0;
154:
155: /*
156: * Create the built-in commands. Do it here, rather than calling
157: * Tcl_CreateCommand, because it's faster (there's no need to
158: * check for a pre-existing command by the same name).
159: */
160:
161: for (namePtr = builtInCmds, procPtr = builtInProcs;
162: *namePtr != NULL; namePtr++, procPtr++) {
163: cmdPtr = (Command *) malloc(CMD_SIZE(strlen(*namePtr)));
164: cmdPtr->proc = *procPtr;
165: cmdPtr->clientData = (ClientData) NULL;
166: cmdPtr->deleteProc = NULL;
167: cmdPtr->nextPtr = iPtr->commandPtr;
168: iPtr->commandPtr = cmdPtr;
169: strcpy(cmdPtr->name, *namePtr);
170: }
171:
172: return (Tcl_Interp *) iPtr;
173: }
174:
175: /*
176: *--------------------------------------------------------------
177: *
178: * Tcl_WatchInterp --
179: *
180: * Arrange for a procedure to be called before a given
181: * interpreter is deleted.
182: *
183: * Results:
184: * None.
185: *
186: * Side effects:
187: * When Tcl_DeleteInterp is invoked to delete interp,
188: * proc will be invoked. See the manual entry for
189: * details.
190: *
191: *--------------------------------------------------------------
192: */
193:
194: void
195: Tcl_WatchInterp(interp, proc, clientData)
196: Tcl_Interp *interp; /* Interpreter to watch. */
197: void (*proc)(); /* Procedure to call when interpreter
198: * is about to be deleted. */
199: ClientData clientData; /* One-word value to pass to proc. */
200: {
201: register InterpCallback *icPtr;
202: Interp *iPtr = (Interp *) interp;
203:
204: icPtr = (InterpCallback *) malloc(sizeof(InterpCallback));
205: icPtr->proc = proc;
206: icPtr->clientData = clientData;
207: icPtr->nextPtr = iPtr->callbackPtr;
208: iPtr->callbackPtr = icPtr;
209: }
210:
211: /*
212: *----------------------------------------------------------------------
213: *
214: * Tcl_DeleteInterp --
215: *
216: * Delete an interpreter and free up all of the resources associated
217: * with it.
218: *
219: * Results:
220: * None.
221: *
222: * Side effects:
223: * The interpreter is destroyed. The caller should never again
224: * use the interp token.
225: *
226: *----------------------------------------------------------------------
227: */
228:
229: void
230: Tcl_DeleteInterp(interp)
231: Tcl_Interp *interp; /* Token for command interpreter (returned
232: * by a previous call to Tcl_CreateInterp). */
233: {
234: Interp *iPtr = (Interp *) interp;
235: register Command *cmdPtr;
236: register Trace *tracePtr;
237: register InterpCallback *icPtr;
238:
239: /*
240: * If the interpreter is in use, delay the deletion until later.
241: */
242:
243: iPtr->flags |= DELETED;
244: if (iPtr->numLevels != 0) {
245: return;
246: }
247:
248: /*
249: * Invoke callbacks, if there's anyone who wants to know about
250: * the interpreter deletion.
251: */
252:
253: for (icPtr = iPtr->callbackPtr; icPtr != NULL;
254: icPtr = icPtr->nextPtr) {
255: (*icPtr->proc)(icPtr->clientData, interp);
256: free((char *) icPtr);
257: }
258:
259: /*
260: * Free up any remaining resources associated with the
261: * interpreter.
262: */
263:
264: for (cmdPtr = iPtr->commandPtr; cmdPtr != NULL;
265: cmdPtr = cmdPtr->nextPtr) {
266: if (cmdPtr->deleteProc != NULL) {
267: (*cmdPtr->deleteProc)(cmdPtr->clientData);
268: }
269: free((char *) cmdPtr);
270: }
271: iPtr->commandPtr = NULL;
272: TclDeleteVars(iPtr);
273: if (iPtr->events != NULL) {
274: free((char *) iPtr->events);
275: }
276: while (iPtr->revPtr != NULL) {
277: free((char *) iPtr->revPtr);
278: iPtr->revPtr = iPtr->revPtr->nextPtr;
279: }
280: for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
281: tracePtr = tracePtr->nextPtr) {
282: free((char *) tracePtr);
283: }
284: free((char *) iPtr);
285: }
286:
287: /*
288: *----------------------------------------------------------------------
289: *
290: * Tcl_CreateCommand --
291: *
292: * Define a new command in a command table.
293: *
294: * Results:
295: * None.
296: *
297: * Side effects:
298: * If a command named cmdName already exists for interp, it is
299: * deleted. In the future, when cmdName is seen as the name of
300: * a command by Tcl_Eval, proc will be called with the following
301: * syntax:
302: *
303: * int
304: * proc(clientData, interp, argc, argv)
305: * ClientData clientData;
306: * Tcl_Interp *interp;
307: * int argc;
308: * char **argv;
309: * {
310: * }
311: *
312: * The clientData and interp arguments are the same as the corresponding
313: * arguments passed to this procedure. Argc and argv describe the
314: * arguments to the command, in the usual UNIX fashion. Proc must
315: * return a code like TCL_OK or TCL_ERROR. It can also set interp->result
316: * ("" is the default value if proc doesn't set it) and interp->dynamic (0
317: * is the default). See tcl.h for more information on these variables.
318: *
319: * When the command is deleted from the table, deleteProc will be called
320: * in the following way:
321: *
322: * void
323: * deleteProc(clientData)
324: * ClientData clientData;
325: * {
326: * }
327: *
328: * DeleteProc allows command implementors to perform their own cleanup
329: * when commands (or interpreters) are deleted.
330: *
331: *----------------------------------------------------------------------
332: */
333:
334: void
335: Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
336: Tcl_Interp *interp; /* Token for command interpreter (returned
337: * by a previous call to Tcl_CreateInterp). */
338: char *cmdName; /* Name of command. */
339: int (*proc)(); /* Command procedure to associate with
340: * cmdName. */
341: ClientData clientData; /* Arbitrary one-word value to pass to proc. */
342: void (*deleteProc)(); /* If not NULL, gives a procedure to call when
343: * this command is deleted. */
344: {
345: Interp *iPtr = (Interp *) interp;
346: register Command *cmdPtr;
347:
348: Tcl_DeleteCommand(interp, cmdName);
349: cmdPtr = (Command *) malloc(CMD_SIZE(strlen(cmdName)));
350: cmdPtr->proc = proc;
351: cmdPtr->clientData = clientData;
352: cmdPtr->deleteProc = deleteProc;
353: cmdPtr->nextPtr = iPtr->commandPtr;
354: iPtr->commandPtr = cmdPtr;
355: strcpy(cmdPtr->name, cmdName);
356: }
357:
358: /*
359: *----------------------------------------------------------------------
360: *
361: * Tcl_DeleteCommand --
362: *
363: * Remove the given command from the given interpreter.
364: *
365: * Results:
366: * None.
367: *
368: * Side effects:
369: * CmdName will no longer be recognized as a valid command for
370: * interp.
371: *
372: *----------------------------------------------------------------------
373: */
374:
375: void
376: Tcl_DeleteCommand(interp, cmdName)
377: Tcl_Interp *interp; /* Token for command interpreter (returned
378: * by a previous call to Tcl_CreateInterp). */
379: char *cmdName; /* Name of command to remove. */
380: {
381: Interp *iPtr = (Interp *) interp;
382: Command *cmdPtr;
383:
384: cmdPtr = TclFindCmd(iPtr, cmdName, 0);
385: if (cmdPtr != NULL) {
386: if (cmdPtr->deleteProc != NULL) {
387: (*cmdPtr->deleteProc)(cmdPtr->clientData);
388: }
389: iPtr->commandPtr = cmdPtr->nextPtr;
390: free((char *) cmdPtr);
391: }
392: }
393:
394: /*
395: *-----------------------------------------------------------------
396: *
397: * Tcl_Eval --
398: *
399: * Parse and execute a command in the Tcl language.
400: *
401: * Results:
402: * The return value is one of the return codes defined in
403: * tcl.h (such as TCL_OK), and interp->result contains a string
404: * value to supplement the return code. The value of interp->result
405: * will persist only until the next call to Tcl_Eval: copy it
406: * or lose it!
407: *
408: * Side effects:
409: * Almost certainly; depends on the command.
410: *
411: *-----------------------------------------------------------------
412: */
413:
414: int
415: Tcl_Eval(interp, cmd, flags, termPtr)
416: Tcl_Interp *interp; /* Token for command interpreter (returned
417: * by a previous call to Tcl_CreateInterp). */
418: char *cmd; /* Pointer to TCL command to interpret. */
419: int flags; /* OR-ed combination of flags like
420: * TCL_BRACKET_TERM and TCL_RECORD_BOUNDS. */
421: char **termPtr; /* If non-NULL, fill in the address it points
422: * to with the address of the char. just after
423: * the last one that was part of cmd. See
424: * the man page for details on this. */
425: {
426: /*
427: * While processing the command, make a local copy of
428: * the command characters. This is needed in order to
429: * terminate each argument with a null character, replace
430: * backslashed-characters, etc. The copy starts out in
431: * a static string (for speed) but gets expanded into
432: * dynamically-allocated strings if necessary. The constant
433: * BUFFER indicates how much space there must be in the copy
434: * in order to pass through the main loop below (e.g., must
435: * have space to copy both a backslash and its following
436: * characters).
437: */
438:
439: # define NUM_CHARS 200
440: # define BUFFER 5
441: char copyStorage[NUM_CHARS];
442: char *copy = copyStorage; /* Pointer to current copy. */
443: int copySize = NUM_CHARS; /* Size of current copy. */
444: register char *dst; /* Points to next place to copy
445: * a character. */
446: char *limit; /* When dst gets here, must make
447: * the copy larger. */
448:
449: /*
450: * This procedure generates an (argv, argc) array for the command,
451: * It starts out with stack-allocated space but uses dynamically-
452: * allocated storage to increase it if needed.
453: */
454:
455: # define NUM_ARGS 10
456: char *(argStorage[NUM_ARGS]);
457: char **argv = argStorage;
458: int argc;
459: int argSize = NUM_ARGS;
460:
461: int openBraces = 0; /* Curent brace nesting level. */
462: int openQuote = 0; /* Non-zero means quoted arg
463: * in progress. */
464:
465: register char *src; /* Points to current character
466: * in cmd. */
467: char termChar; /* Return when this character is found
468: * (either ']' or '\0'). Zero means
469: * that newlines terminate commands. */
470: char *argStart; /* Location in cmd of first * non-separator character in
471: * current argument; it's
472: * used to eliminate multiple
473: * separators between args and
474: * extra separators after last
475: * arg in command. */
476: int result = TCL_OK; /* Return value. */
477: int i;
478: register Interp *iPtr = (Interp *) interp;
479: Command *cmdPtr;
480: char *tmp;
481: char *dummy; /* Make termPtr point here if it was
482: * originally NULL. */
483: char *syntaxMsg;
484: char *syntaxPtr; /* Points to "relevant" character
485: * for syntax violations. */
486: char *cmdStart; /* Points to first non-blank char. in
487: * command (used in calling trace
488: * procedures). */
489: register Trace *tracePtr;
490:
491: /*
492: * Set up the result so that if there's no command at all in
493: * the string then this procedure will return TCL_OK.
494: */
495:
496: if (iPtr->dynamic) {
497: free((char *) iPtr->result);
498: iPtr->dynamic = 0;
499: }
500: iPtr->result = iPtr->resultSpace;
501: iPtr->resultSpace[0] = 0;
502:
503: /*
504: * Check depth of nested calls to Tcl_Eval: if this gets too large,
505: * it's probably because of an infinite loop somewhere (e.g. self-
506: * recursive history invocation).
507: */
508:
509: iPtr->numLevels++;
510: if (iPtr->numLevels > MAX_NESTING_DEPTH) {
511: iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
512: return TCL_ERROR;
513: }
514:
515: src = cmd;
516: result = TCL_OK;
517: if (flags & TCL_BRACKET_TERM) {
518: termChar = ']';
519: } else {
520: termChar = 0;
521: }
522: if (termPtr == NULL) {
523: termPtr = &dummy;
524: }
525:
526: /*
527: * There can be many sub-commands (separated by semi-colons or
528: * newlines) in one command string. This outer loop iterates over
529: * the inner commands.
530: */
531:
532: for (*termPtr = src; *src != termChar; *termPtr = src) {
533:
534: /*
535: * Skim off leading white space and semi-colons, and skip comments.
536: */
537:
538: while (isspace(*src) || (*src == ';')) {
539: src += 1;
540: }
541: if (*src == '#') {
542: for (src++; *src != 0; src++) {
543: if (*src == '\n') {
544: src++;
545: break;
546: }
547: }
548: continue;
549: }
550:
551: /*
552: * Set up the first argument (the command name). Note that
553: * the arg pointer gets set up BEFORE the first real character
554: * of the argument has been found.
555: */
556:
557: dst = copy;
558: argc = 0;
559: limit = copy + copySize - BUFFER;
560: argv[0] = dst;
561: argStart = cmdStart = src;
562:
563: /*
564: * Skim off the command name and arguments by looping over
565: * characters and processing each one according to its type.
566: */
567:
568: while (1) {
569: switch (*src) {
570:
571: /*
572: * All braces are treated as normal characters
573: * unless the first character of the argument is an
574: * open brace. In that case, braces nest and
575: * the argument terminates when all braces are matched.
576: * Internal braces are also copied like normal chars.
577: */
578:
579: case '{': {
580: if (!openBraces && !openQuote && (dst == argv[argc])) {
581: syntaxPtr = src;
582: openBraces = 1;
583: break;
584: }
585: *dst = '{'; dst++;
586: if (openBraces > 0) {
587: openBraces++;
588: }
589: break;
590: }
591:
592: case '}': {
593: if (openBraces == 1) {
594: openBraces = 0;
595: if (!isspace(src[1]) && (src[1] != termChar) &&
596: (src[1] != 0) && (src[1] != ';')) {
597: syntaxPtr = src;
598: syntaxMsg = "extra characters after close-brace";
599: goto syntaxError;
600: }
601: } else {
602: *dst = '}'; dst++;
603: if (openBraces > 0) {
604: openBraces--;
605: }
606: }
607: break;
608: }
609:
610: case '"': {
611: if (!openQuote) {
612: if (openBraces || (dst != argv[argc])) {
613: *dst = '"'; dst++;
614: break;
615: }
616: syntaxPtr = src;
617: openQuote = 1;
618: } else {
619: openQuote = 0;
620: if (!isspace(src[1]) && (src[1] != termChar) &&
621: (src[1] != 0) && (src[1] != ';')) {
622: syntaxPtr = src;
623: syntaxMsg = "extra characters after close-quote";
624: goto syntaxError;
625: }
626: }
627: break;
628: }
629:
630: case '[': {
631:
632: /*
633: * Open bracket: if not in middle of braces, then execute
634: * following command and substitute result into argument.
635: */
636:
637: if (openBraces != 0) {
638: *dst = '['; dst++;
639: } else {
640: int length;
641:
642: result = Tcl_Eval(interp, src+1,
643: TCL_BRACKET_TERM | (flags & TCL_RECORD_BOUNDS),
644: &tmp);
645: src = tmp;
646: if (result != TCL_OK) {
647: goto done;
648: }
649:
650: /*
651: * Copy the return value into the current argument.
652: * May have to enlarge the argument storage. When
653: * enlarging, get more than enough to reduce the
654: * likelihood of having to enlarge again. This code
655: * is used for $-processing also.
656: */
657:
658: copyResult:
659: length = strlen(iPtr->result);
660: if ((limit - dst) < length) {
661: char *newCopy;
662: int delta;
663:
664: copySize = length + 10 + dst - copy;
665: newCopy = (char *) malloc((unsigned) copySize);
666: bcopy(copy, newCopy, (dst-copy));
667: delta = newCopy - copy;
668: dst += delta;
669: for (i = 0; i <= argc; i++) {
670: argv[i] += delta;
671: }
672: if (copy != copyStorage) {
673: free((char *) copy);
674: }
675: copy = newCopy;
676: limit = newCopy + copySize - BUFFER;
677: }
678: bcopy(iPtr->result, dst, length);
679: dst += length;
680: }
681: break;
682: }
683:
684: case '$': {
685: if (openBraces != 0) {
686: *dst = '$'; dst++;
687: } else {
688: char *value;
689:
690: /*
691: * Parse off a variable name and copy its value.
692: */
693:
694: value = Tcl_ParseVar(interp, src, &tmp);
695: if (value == NULL) {
696: result = TCL_ERROR;
697: goto done;
698: }
699: if (iPtr->dynamic) {
700: free((char *) iPtr->result);
701: iPtr->dynamic = 0;
702: }
703: iPtr->result = value;
704: src = tmp-1;
705: goto copyResult;
706: }
707: break;
708: }
709:
710: case ']': {
711: if ((openBraces == 0) && (termChar == ']')) {
712: goto cmdComplete;
713: }
714: *dst = ']'; dst++;
715: break;
716: }
717:
718: case ';': {
719: if (!openBraces && !openQuote) {
720: goto cmdComplete;
721: }
722: *dst = *src; dst++;
723: break;
724: }
725:
726: case '\n': {
727:
728: /*
729: * A newline can be either a command terminator
730: * or a space character. If it's a space character,
731: * just fall through to the space code below.
732: */
733:
734: if (!openBraces && !openQuote && (termChar == 0)) {
735: goto cmdComplete;
736: }
737: }
738:
739: case '\r':
740: case ' ':
741: case '\t': {
742: if (openBraces || openQuote) {
743:
744: /*
745: * Quoted space. Copy it into the argument.
746: */
747:
748: *dst = *src; dst++;
749: } else {
750:
751: /*
752: * Argument separator. If there are many
753: * separators in a row (src == argStart) just
754: * ignore this separator. Otherwise,
755: * Null-terminate the current argument and
756: * set up for the next one.
757: */
758:
759: if (src == argStart) {
760: argStart = src+1;
761: break;
762: }
763: argStart = src+1;
764: *dst = 0;
765: dst++; argc++;
766:
767: /*
768: * Make sure that the argument array is large enough
769: * for the next argument plus a final NULL argument
770: * pointer to terminate the list.
771: */
772:
773: if (argc >= argSize-1) {
774: char **newArgs;
775:
776: argSize *= 2;
777: newArgs = (char **)
778: malloc((unsigned) argSize * sizeof(char *));
779: for (i = 0; i < argc; i++) {
780: newArgs[i] = argv[i];
781: }
782: if (argv != argStorage) {
783: free((char *) argv);
784: }
785: argv = newArgs;
786: }
787: argv[argc] = dst;
788: break;
789: }
790: break;
791: }
792:
793: case '\\': {
794: int numRead;
795:
796: /*
797: * First of all, make the special check for
798: * backslash followed by newline. This can't
799: * be processed in the normal fashion of
800: * Tcl_Backslash because is maps to "nothing",
801: * rather than to a character.
802: */
803:
804: if (src[1] == '\n') {
805: if (argStart == src) {
806: argStart += 2;
807: }
808: src++;
809: break;
810: }
811:
812: /*
813: * If we're in an argument in braces then the
814: * backslash doesn't get collapsed. However,
815: * whether we're in braces or not the characters
816: * inside the backslash sequence must not receive
817: * any additional processing: make src point to
818: * the last character of the sequence.
819: */
820:
821: *dst = Tcl_Backslash(src, &numRead);
822: if (openBraces > 0) {
823: for ( ; numRead > 0; src++, dst++, numRead--) {
824: *dst = *src;
825: }
826: src--;
827: } else {
828: src += numRead-1;
829: dst++;
830: }
831: break;
832: }
833:
834: case 0: {
835:
836: /*
837: * End of string. Make sure that braces/quotes
838: * were properly matched. Also, it's only legal
839: * to terminate a command by a null character if
840: * termChar is zero.
841: */
842:
843: if (openQuote != 0) {
844: syntaxMsg = "unmatched quote";
845: goto syntaxError;
846: }
847: if (openBraces != 0) {
848: syntaxMsg = "unmatched brace";
849: goto syntaxError;
850: }
851: if (termChar == ']') {
852: syntaxPtr = cmd;
853: syntaxMsg = "missing close-bracket";
854: goto syntaxError;
855: }
856: goto cmdComplete;
857: }
858:
859: default: {
860: *dst = *src; dst++;
861: break;
862: }
863: }
864: src += 1;
865:
866: /*
867: * Make sure that we're not running out of space in the
868: * string copy area. If we are, allocate a larger area
869: * and copy the string. Be sure to update all of the
870: * relevant pointers too.
871: */
872:
873: if (dst >= limit) {
874: char *newCopy;
875: int delta;
876:
877: copySize *= 2;
878: newCopy = (char *) malloc((unsigned) copySize);
879: bcopy(copy, newCopy, (dst-copy));
880: delta = newCopy - copy;
881: dst += delta;
882: for (i = 0; i <= argc; i++) {
883: argv[i] += delta;
884: }
885: if (copy != copyStorage) {
886: free((char *) copy);
887: }
888: copy = newCopy;
889: limit = newCopy + copySize - BUFFER;
890: }
891:
892: }
893:
894: /*
895: * Terminate the last argument and add a final NULL argument. If
896: * the interpreter has been deleted then return; if there's no
897: * command, then go on to the next iteration.
898: */
899:
900: cmdComplete:
901: if (iPtr->flags & DELETED) {
902: goto done;
903: }
904: if (src != argStart) {
905: *dst = 0;
906: argc++;
907: }
908: if ((argc == 0) || iPtr->noEval) {
909: continue;
910: }
911: argv[argc] = NULL;
912:
913: cmdPtr = TclFindCmd(iPtr, argv[0], 1);
914: if (cmdPtr == NULL) {
915: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
916: sprintf(iPtr->result,
917: "\"%.50s\" is an invalid command name %s",
918: argv[0], "or ambiguous abbreviation");
919: result = TCL_ERROR;
920: goto done;
921: }
922:
923: /*
924: * Replace argv[0] with the full name of the command (in case
925: * argv[0] was an abbreviation).
926: */
927:
928: argv[0] = cmdPtr->name;
929:
930: /*
931: * Call trace procedures, if any.
932: */
933:
934: for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
935: tracePtr = tracePtr->nextPtr) {
936: char saved;
937:
938: if (tracePtr->level < iPtr->numLevels) {
939: continue;
940: }
941: saved = *src;
942: *src = 0;
943: (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
944: cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
945: *src = saved;
946: }
947:
948: /*
949: * Save information for the history module, if needed.
950: */
951:
952: if (flags & TCL_RECORD_BOUNDS) {
953: iPtr->evalFirst = cmdStart;
954: iPtr->evalLast = src;
955: } else {
956: iPtr->evalFirst = NULL;
957: }
958:
959: /*
960: * At long last, invoke the command procedure. Reset the
961: * result to its default empty value first.
962: */
963:
964: iPtr->cmdCount++;
965: iPtr->flags &= ~ERR_IN_PROGRESS;
966: if (iPtr->dynamic) {
967: free((char *) iPtr->result);
968: iPtr->dynamic = 0;
969: }
970: iPtr->result = iPtr->resultSpace;
971: iPtr->resultSpace[0] = 0;
972: result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
973: if (result != TCL_OK) {
974: break;
975: }
976: }
977:
978: /*
979: * Free up any extra resources that were allocated.
980: */
981:
982: done:
983: if (copy != copyStorage) {
984: free((char *) copy);
985: }
986: if (argv != argStorage) {
987: free((char *) argv);
988: }
989: iPtr->numLevels--;
990: if (iPtr->numLevels == 0) {
991: if (result == TCL_RETURN) {
992: result = TCL_OK;
993: }
994: if ((result != TCL_OK) && (result != TCL_ERROR)) {
995: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
996: if (result == TCL_BREAK) {
997: iPtr->result = "invoked \"break\" outside of a loop";
998: } else if (result == TCL_CONTINUE) {
999: iPtr->result = "invoked \"continue\" outside of a loop";
1000: } else {
1001: iPtr->result = iPtr->resultSpace;
1002: sprintf(iPtr->resultSpace, "command returned bad code: %d",
1003: result);
1004: }
1005: result = TCL_ERROR;
1006: }
1007: if (iPtr->flags & DELETED) {
1008: Tcl_DeleteInterp(interp);
1009: }
1010: }
1011:
1012: /*
1013: * If an error occurred, record information about what was being
1014: * executed when the error occurred.
1015: */
1016:
1017: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
1018: int numChars;
1019: register char *p;
1020: char *ellipsis;
1021:
1022: /*
1023: * Compute the line number where the error occurred.
1024: */
1025:
1026: iPtr->errorLine = 1;
1027: for (p = cmd; p != cmdStart; p++) {
1028: if (*p == '\n') {
1029: iPtr->errorLine++;
1030: }
1031: }
1032: for ( ; isspace(*p) || (*p == ';'); p++) {
1033: if (*p == '\n') {
1034: iPtr->errorLine++;
1035: }
1036: }
1037:
1038: /*
1039: * Figure out how much of the command to print in the error
1040: * message (up to a certain number of characters, or up to
1041: * the first new-line).
1042: */
1043:
1044: ellipsis = "";
1045: p = strchr(cmdStart, '\n');
1046: if (p == NULL) {
1047: numChars = strlen(cmdStart);
1048: } else {
1049: numChars = p - cmdStart;
1050: if (p[1] != 0) {
1051: ellipsis = " ...";
1052: }
1053: }
1054: if (numChars > 40) {
1055: numChars = 40;
1056: ellipsis = " ...";
1057: }
1058:
1059: if (!(iPtr->flags & ERR_IN_PROGRESS)) {
1060: /*
1061: * This is the first piece of information being recorded
1062: * for this error. Log the error message as well as the
1063: * command being executed.
1064: */
1065:
1066: if (strlen(iPtr->result) < 50) {
1067: sprintf(copyStorage,
1068: "%s, while executing\n\"%.*s%s\"",
1069: iPtr->result, numChars, cmdStart, ellipsis);
1070: } else {
1071: sprintf(copyStorage,
1072: "%.50s..., while executing\n\"%.*s%s\"",
1073: iPtr->result, numChars, cmdStart, ellipsis);
1074: }
1075: } else {
1076: sprintf(copyStorage, ", invoked from within\n\"%.*s%s\"",
1077: numChars, cmdStart, ellipsis);
1078: }
1079: Tcl_AddErrorInfo(interp, copyStorage);
1080: iPtr->flags &= ~ERR_ALREADY_LOGGED;
1081: } else {
1082: iPtr->flags &= ~ERR_ALREADY_LOGGED;
1083: }
1084: return result;
1085:
1086: /*
1087: * Syntax error: generate an error message.
1088: */
1089:
1090: syntaxError: {
1091: char *first, *last;
1092:
1093: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
1094: for (first = syntaxPtr; ((first != cmd) && (first[-1] != '\n'));
1095: first--) {
1096: /* Null loop body. */
1097: }
1098: for (last = syntaxPtr; ((*last != 0) && (*last!= '\n')); last++) {
1099: /* Null loop body. */
1100: }
1101: if ((syntaxPtr - first) > 60) {
1102: first = syntaxPtr - 60;
1103: }
1104: if ((last - first) > 70) {
1105: last = first + 70;
1106: }
1107: if (last == first) {
1108: sprintf(iPtr->result, "%s", syntaxMsg);
1109: } else {
1110: sprintf(iPtr->result, "%s: '%.*s => %.*s'", syntaxMsg,
1111: syntaxPtr-first, first, last-syntaxPtr, syntaxPtr);
1112: }
1113: result = TCL_ERROR;
1114: }
1115:
1116: goto done;
1117: }
1118:
1119: /*
1120: *----------------------------------------------------------------------
1121: *
1122: * Tcl_CreateTrace --
1123: *
1124: * Arrange for a procedure to be called to trace command execution.
1125: *
1126: * Results:
1127: * The return value is a token for the trace, which may be passed
1128: * to Tcl_DeleteTrace to eliminate the trace.
1129: *
1130: * Side effects:
1131: * From now on, proc will be called just before a command procedure
1132: * is called to execute a Tcl command. Calls to proc will have the
1133: * following form:
1134: *
1135: * void
1136: * proc(clientData, interp, level, command, cmdProc, cmdClientData,
1137: * argc, argv)
1138: * ClientData clientData;
1139: * Tcl_Interp *interp;
1140: * int level;
1141: * char *command;
1142: * int (*cmdProc)();
1143: * ClientData cmdClientData;
1144: * int argc;
1145: * char **argv;
1146: * {
1147: * }
1148: *
1149: * The clientData and interp arguments to proc will be the same
1150: * as the corresponding arguments to this procedure. Level gives
1151: * the nesting level of command interpretation for this interpreter
1152: * (0 corresponds to top level). Command gives the ASCII text of
1153: * the raw command, cmdProc and cmdClientData give the procedure that
1154: * will be called to process the command and the ClientData value it
1155: * will receive, and argc and argv give the arguments to the
1156: * command, after any argument parsing and substitution. Proc
1157: * does not return a value.
1158: *
1159: *----------------------------------------------------------------------
1160: */
1161:
1162: Tcl_Trace
1163: Tcl_CreateTrace(interp, level, proc, clientData)
1164: Tcl_Interp *interp; /* Interpreter in which to create the trace. */
1165: int level; /* Only call proc for commands at nesting level
1166: * <= level (1 => top level). */
1167: void (*proc)(); /* Procedure to call before executing each
1168: * command. */
1169: ClientData clientData; /* Arbitrary one-word value to pass to proc. */
1170: {
1171: register Trace *tracePtr;
1172: register Interp *iPtr = (Interp *) interp;
1173:
1174: tracePtr = (Trace *) malloc(sizeof(Trace));
1175: tracePtr->level = level;
1176: tracePtr->proc = proc;
1177: tracePtr->clientData = clientData;
1178: tracePtr->nextPtr = iPtr->tracePtr;
1179: iPtr->tracePtr = tracePtr;
1180:
1181: return (Tcl_Trace) tracePtr;
1182: }
1183:
1184: /*
1185: *----------------------------------------------------------------------
1186: *
1187: * Tcl_DeleteTrace --
1188: *
1189: * Remove a trace.
1190: *
1191: * Results:
1192: * None.
1193: *
1194: * Side effects:
1195: * From now on there will be no more calls to the procedure given
1196: * in trace.
1197: *
1198: *----------------------------------------------------------------------
1199: */
1200:
1201: void
1202: Tcl_DeleteTrace(interp, trace)
1203: Tcl_Interp *interp; /* Interpreter that contains trace. */
1204: Tcl_Trace trace; /* Token for trace (returned previously by
1205: * Tcl_CreateTrace). */
1206: {
1207: register Interp *iPtr = (Interp *) interp;
1208: register Trace *tracePtr = (Trace *) trace;
1209: register Trace *tracePtr2;
1210:
1211: if (iPtr->tracePtr == tracePtr) {
1212: iPtr->tracePtr = tracePtr->nextPtr;
1213: free((char *) tracePtr);
1214: } else {
1215: for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
1216: tracePtr2 = tracePtr2->nextPtr) {
1217: if (tracePtr2->nextPtr == tracePtr) {
1218: tracePtr2->nextPtr = tracePtr->nextPtr;
1219: free((char *) tracePtr);
1220: return;
1221: }
1222: }
1223: }
1224: }
1225:
1226: /*
1227: *----------------------------------------------------------------------
1228: *
1229: * Tcl_AddErrorInfo --
1230: *
1231: * Add information to a message being accumulated that describes
1232: * the current error.
1233: *
1234: * Results:
1235: * None.
1236: *
1237: * Side effects:
1238: * The contents of message are added to the "errorInfo" variable.
1239: * If Tcl_Eval has been called since the current value of errorInfo
1240: * was set, errorInfo is cleared before adding the new message.
1241: *
1242: *----------------------------------------------------------------------
1243: */
1244:
1245: void
1246: Tcl_AddErrorInfo(interp, message)
1247: Tcl_Interp *interp; /* Interpreter to which error information
1248: * pertains. */
1249: char *message; /* Message to record. */
1250: {
1251: register Interp *iPtr = (Interp *) interp;
1252:
1253: if (iPtr->flags & ERR_IN_PROGRESS) {
1254: int length;
1255: char *buffer, *oldVar;
1256:
1257: oldVar = Tcl_GetVar(interp, "errorInfo", 1);
1258: if (oldVar == NULL) {
1259: oldVar = "";
1260: }
1261: length = strlen(oldVar);
1262: buffer = malloc((unsigned) (length + strlen(message) + 1));
1263: strcpy(buffer, oldVar);
1264: strcpy(buffer+length, message);
1265: Tcl_SetVar(interp, "errorInfo", buffer, 1);
1266: } else {
1267: iPtr->flags |= ERR_IN_PROGRESS;
1268: Tcl_SetVar(interp, "errorInfo", message, 1);
1269: }
1270: }
1271:
1272: /*
1273: *----------------------------------------------------------------------
1274: *
1275: * TclFindCmd --
1276: *
1277: * Find a particular command in an interpreter.
1278: *
1279: * Results:
1280: * If the command doesn't exist in the table, or if it is an
1281: * ambiguous abbreviation, then NULL is returned. Otherwise
1282: * the return value is a pointer to the command. Unique
1283: * abbreviations are allowed if abbrevOK is non-zero, but
1284: * abbreviations take longer to look up (must scan the whole
1285: * table twice).
1286: *
1287: * Side effects:
1288: * If the command is found and is an exact match, it is relinked
1289: * at the front of iPtr's command list so it will be found more
1290: * quickly in the future.
1291: *
1292: *----------------------------------------------------------------------
1293: */
1294:
1295: Command *
1296: TclFindCmd(iPtr, cmdName, abbrevOK)
1297: Interp *iPtr; /* Interpreter in which to search. */
1298: char *cmdName; /* Desired command. */
1299: int abbrevOK; /* Non-zero means permit abbreviations, if
1300: * not disallowed by "noAbbrevs" variable.
1301: * Zero means exact matches only. */
1302: {
1303: register Command *prev;
1304: register Command *cur;
1305: register char c;
1306: Command *match;
1307: int length;
1308: char *varValue;
1309:
1310: /*
1311: * First check for an exact match.
1312: */
1313:
1314: c = *cmdName;
1315: for (prev = NULL, cur = iPtr->commandPtr; cur != NULL;
1316: prev = cur, cur = cur->nextPtr) {
1317:
1318: /*
1319: * Check the first character here before wasting time calling
1320: * strcmp.
1321: */
1322:
1323: if ((cur->name[0] == c) && (strcmp(cur->name, cmdName) == 0)) {
1324: if (prev != NULL) {
1325: prev->nextPtr = cur->nextPtr;
1326: cur->nextPtr = iPtr->commandPtr;
1327: iPtr->commandPtr = cur;
1328: }
1329: return cur;
1330: }
1331: }
1332: if (!abbrevOK) {
1333: return NULL;
1334: }
1335: varValue = Tcl_GetVar((Tcl_Interp *) iPtr, "noAbbrev", 1);
1336: if ((varValue != NULL) && (*varValue == '1')) {
1337: return NULL;
1338: }
1339:
1340: /*
1341: * No exact match. Make a second pass to check for a unique
1342: * abbreviation. Don't bother to pull the matching entry to
1343: * the front of the list, since we have to search the whole list
1344: * for abbreviations anyway.
1345: */
1346:
1347: length = strlen(cmdName);
1348: match = NULL;
1349: for (prev = NULL, cur = iPtr->commandPtr; cur != NULL;
1350: prev = cur, cur = cur->nextPtr) {
1351: if ((cur->name[0] == c) && (strncmp(cur->name, cmdName, length) == 0)) {
1352: if (match != NULL) {
1353: return NULL;
1354: }
1355: match = cur;
1356: }
1357: }
1358: return match;
1359: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.