![[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.