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