![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclcmdmz.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 tclcmdmz.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 ! root 1: /* ! 2: * tclCmdMZ.c -- ! 3: * ! 4: * This file contains the top-level command routines for most of ! 5: * the Tcl built-in commands whose names begin with the letters ! 6: * M to Z. It contains only commands in the generic core (i.e. ! 7: * those that don't depend much upon UNIX facilities). ! 8: * ! 9: * Copyright 1987-1991 Regents of the University of California ! 10: * Permission to use, copy, modify, and distribute this ! 11: * software and its documentation for any purpose and without ! 12: * fee is hereby granted, provided that the above copyright ! 13: * notice appear in all copies. The University of California ! 14: * makes no representations about the suitability of this ! 15: * software for any purpose. It is provided "as is" without ! 16: * express or implied warranty. ! 17: */ ! 18: ! 19: #ifndef lint ! 20: static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.13 92/04/23 11:07:54 ouster Exp $ SPRITE (Berkeley)"; ! 21: #endif ! 22: ! 23: #include "tclint.h" ! 24: ! 25: /* ! 26: * Structure used to hold information about variable traces: ! 27: */ ! 28: ! 29: typedef struct { ! 30: int flags; /* Operations for which Tcl command is ! 31: * to be invoked. */ ! 32: int length; /* Number of non-NULL chars. in command. */ ! 33: char command[4]; /* Space for Tcl command to invoke. Actual ! 34: * size will be as large as necessary to ! 35: * hold command. This field must be the ! 36: * last in the structure, so that it can ! 37: * be larger than 4 bytes. */ ! 38: } TraceVarInfo; ! 39: ! 40: /* ! 41: * Forward declarations for procedures defined in this file: ! 42: */ ! 43: ! 44: static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, ! 45: Tcl_Interp *interp, char *name1, char *name2, ! 46: int flags)); ! 47: ! 48: /* ! 49: *---------------------------------------------------------------------- ! 50: * ! 51: * Tcl_RegexpCmd -- ! 52: * ! 53: * This procedure is invoked to process the "regexp" Tcl command. ! 54: * See the user documentation for details on what it does. ! 55: * ! 56: * Results: ! 57: * A standard Tcl result. ! 58: * ! 59: * Side effects: ! 60: * See the user documentation. ! 61: * ! 62: *---------------------------------------------------------------------- ! 63: */ ! 64: ! 65: /* ARGSUSED */ ! 66: int ! 67: Tcl_RegexpCmd(dummy, interp, argc, argv) ! 68: ClientData dummy; /* Not used. */ ! 69: Tcl_Interp *interp; /* Current interpreter. */ ! 70: int argc; /* Number of arguments. */ ! 71: char **argv; /* Argument strings. */ ! 72: { ! 73: int noCase = 0; ! 74: int indices = 0; ! 75: regexp *regexpPtr; ! 76: char **argPtr, *string; ! 77: int match, i; ! 78: ! 79: if (argc < 3) { ! 80: wrongNumArgs: ! 81: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 82: " ?-nocase? exp string ?matchVar? ?subMatchVar ", ! 83: "subMatchVar ...?\"", (char *) NULL); ! 84: return TCL_ERROR; ! 85: } ! 86: argPtr = argv+1; ! 87: argc--; ! 88: while ((argc > 0) && (argPtr[0][0] == '-')) { ! 89: if (strcmp(argPtr[0], "-indices") == 0) { ! 90: argPtr++; ! 91: argc--; ! 92: indices = 1; ! 93: } else if (strcmp(argPtr[0], "-nocase") == 0) { ! 94: argPtr++; ! 95: argc--; ! 96: noCase = 1; ! 97: } else { ! 98: break; ! 99: } ! 100: } ! 101: if (argc < 2) { ! 102: goto wrongNumArgs; ! 103: } ! 104: regexpPtr = TclCompileRegexp(interp, argPtr[0]); ! 105: if (regexpPtr == NULL) { ! 106: return TCL_ERROR; ! 107: } ! 108: ! 109: /* ! 110: * Convert the string to lower case, if desired, and perform ! 111: * the match. ! 112: */ ! 113: ! 114: if (noCase) { ! 115: register char *dst, *src; ! 116: ! 117: string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1)); ! 118: for (src = argPtr[1], dst = string; *src != 0; src++, dst++) { ! 119: if (isupper(*src)) { ! 120: *dst = tolower(*src); ! 121: } else { ! 122: *dst = *src; ! 123: } ! 124: } ! 125: *dst = 0; ! 126: } else { ! 127: string = argPtr[1]; ! 128: } ! 129: tclRegexpError = NULL; ! 130: match = regexec(regexpPtr, string); ! 131: if (string != argPtr[1]) { ! 132: ckfree(string); ! 133: } ! 134: if (tclRegexpError != NULL) { ! 135: Tcl_AppendResult(interp, "error while matching pattern: ", ! 136: tclRegexpError, (char *) NULL); ! 137: return TCL_ERROR; ! 138: } ! 139: if (!match) { ! 140: interp->result = "0"; ! 141: return TCL_OK; ! 142: } ! 143: ! 144: /* ! 145: * If additional variable names have been specified, return ! 146: * index information in those variables. ! 147: */ ! 148: ! 149: argc -= 2; ! 150: if (argc > NSUBEXP) { ! 151: interp->result = "too many substring variables"; ! 152: return TCL_ERROR; ! 153: } ! 154: for (i = 0; i < argc; i++) { ! 155: char *result, info[50]; ! 156: ! 157: if (regexpPtr->startp[i] == NULL) { ! 158: if (indices) { ! 159: result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); ! 160: } else { ! 161: result = Tcl_SetVar(interp, argPtr[i+2], "", 0); ! 162: } ! 163: } else { ! 164: if (indices) { ! 165: sprintf(info, "%d %d", regexpPtr->startp[i] - string, ! 166: regexpPtr->endp[i] - string - 1); ! 167: result = Tcl_SetVar(interp, argPtr[i+2], info, 0); ! 168: } else { ! 169: char savedChar, *first, *last; ! 170: ! 171: first = argPtr[1] + (regexpPtr->startp[i] - string); ! 172: last = argPtr[1] + (regexpPtr->endp[i] - string); ! 173: savedChar = *last; ! 174: *last = 0; ! 175: result = Tcl_SetVar(interp, argPtr[i+2], first, 0); ! 176: *last = savedChar; ! 177: } ! 178: } ! 179: if (result == NULL) { ! 180: Tcl_AppendResult(interp, "couldn't set variable \"", ! 181: argPtr[i+2], "\"", (char *) NULL); ! 182: return TCL_ERROR; ! 183: } ! 184: } ! 185: interp->result = "1"; ! 186: return TCL_OK; ! 187: } ! 188: ! 189: /* ! 190: *---------------------------------------------------------------------- ! 191: * ! 192: * Tcl_RegsubCmd -- ! 193: * ! 194: * This procedure is invoked to process the "regsub" Tcl command. ! 195: * See the user documentation for details on what it does. ! 196: * ! 197: * Results: ! 198: * A standard Tcl result. ! 199: * ! 200: * Side effects: ! 201: * See the user documentation. ! 202: * ! 203: *---------------------------------------------------------------------- ! 204: */ ! 205: ! 206: /* ARGSUSED */ ! 207: int ! 208: Tcl_RegsubCmd(dummy, interp, argc, argv) ! 209: ClientData dummy; /* Not used. */ ! 210: Tcl_Interp *interp; /* Current interpreter. */ ! 211: int argc; /* Number of arguments. */ ! 212: char **argv; /* Argument strings. */ ! 213: { ! 214: int noCase = 0, all = 0; ! 215: regexp *regexpPtr; ! 216: char *string, *p, *firstChar, *newValue, **argPtr; ! 217: int match, result, flags; ! 218: register char *src, c; ! 219: ! 220: if (argc < 5) { ! 221: wrongNumArgs: ! 222: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 223: " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL); ! 224: return TCL_ERROR; ! 225: } ! 226: argPtr = argv+1; ! 227: argc--; ! 228: while (argPtr[0][0] == '-') { ! 229: if (strcmp(argPtr[0], "-nocase") == 0) { ! 230: argPtr++; ! 231: argc--; ! 232: noCase = 1; ! 233: } else if (strcmp(argPtr[0], "-all") == 0) { ! 234: argPtr++; ! 235: argc--; ! 236: all = 1; ! 237: } else { ! 238: break; ! 239: } ! 240: } ! 241: if (argc != 4) { ! 242: goto wrongNumArgs; ! 243: } ! 244: regexpPtr = TclCompileRegexp(interp, argPtr[0]); ! 245: if (regexpPtr == NULL) { ! 246: return TCL_ERROR; ! 247: } ! 248: ! 249: /* ! 250: * Convert the string to lower case, if desired. ! 251: */ ! 252: ! 253: if (noCase) { ! 254: register char *dst; ! 255: ! 256: string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1)); ! 257: for (src = argPtr[1], dst = string; *src != 0; src++, dst++) { ! 258: if (isupper(*src)) { ! 259: *dst = tolower(*src); ! 260: } else { ! 261: *dst = *src; ! 262: } ! 263: } ! 264: *dst = 0; ! 265: } else { ! 266: string = argPtr[1]; ! 267: } ! 268: ! 269: /* ! 270: * The following loop is to handle multiple matches within the ! 271: * same source string; each iteration handles one match and its ! 272: * corresponding substitution. If "-all" hasn't been specified ! 273: * then the loop body only gets executed once. ! 274: */ ! 275: ! 276: flags = 0; ! 277: for (p = string; *p != 0; ) { ! 278: tclRegexpError = NULL; ! 279: match = regexec(regexpPtr, p); ! 280: if (tclRegexpError != NULL) { ! 281: Tcl_AppendResult(interp, "error while matching pattern: ", ! 282: tclRegexpError, (char *) NULL); ! 283: result = TCL_ERROR; ! 284: goto done; ! 285: } ! 286: if (!match) { ! 287: break; ! 288: } ! 289: ! 290: /* ! 291: * Copy the portion of the source string before the match to the ! 292: * result variable. ! 293: */ ! 294: ! 295: src = argPtr[1] + (regexpPtr->startp[0] - string); ! 296: c = *src; ! 297: *src = 0; ! 298: newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), ! 299: flags); ! 300: *src = c; ! 301: flags = TCL_APPEND_VALUE; ! 302: if (newValue == NULL) { ! 303: cantSet: ! 304: Tcl_AppendResult(interp, "couldn't set variable \"", ! 305: argPtr[3], "\"", (char *) NULL); ! 306: result = TCL_ERROR; ! 307: goto done; ! 308: } ! 309: ! 310: /* ! 311: * Append the subSpec argument to the variable, making appropriate ! 312: * substitutions. This code is a bit hairy because of the backslash ! 313: * conventions and because the code saves up ranges of characters in ! 314: * subSpec to reduce the number of calls to Tcl_SetVar. ! 315: */ ! 316: ! 317: for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { ! 318: int index; ! 319: ! 320: if (c == '&') { ! 321: index = 0; ! 322: } else if (c == '\\') { ! 323: c = src[1]; ! 324: if ((c >= '0') && (c <= '9')) { ! 325: index = c - '0'; ! 326: } else if ((c == '\\') || (c == '&')) { ! 327: *src = c; ! 328: src[1] = 0; ! 329: newValue = Tcl_SetVar(interp, argPtr[3], firstChar, ! 330: TCL_APPEND_VALUE); ! 331: *src = '\\'; ! 332: src[1] = c; ! 333: if (newValue == NULL) { ! 334: goto cantSet; ! 335: } ! 336: firstChar = src+2; ! 337: src++; ! 338: continue; ! 339: } else { ! 340: continue; ! 341: } ! 342: } else { ! 343: continue; ! 344: } ! 345: if (firstChar != src) { ! 346: c = *src; ! 347: *src = 0; ! 348: newValue = Tcl_SetVar(interp, argPtr[3], firstChar, ! 349: TCL_APPEND_VALUE); ! 350: *src = c; ! 351: if (newValue == NULL) { ! 352: goto cantSet; ! 353: } ! 354: } ! 355: if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL) ! 356: && (regexpPtr->endp[index] != NULL)) { ! 357: char *first, *last, saved; ! 358: ! 359: first = argPtr[1] + (regexpPtr->startp[index] - string); ! 360: last = argPtr[1] + (regexpPtr->endp[index] - string); ! 361: saved = *last; ! 362: *last = 0; ! 363: newValue = Tcl_SetVar(interp, argPtr[3], first, ! 364: TCL_APPEND_VALUE); ! 365: *last = saved; ! 366: if (newValue == NULL) { ! 367: goto cantSet; ! 368: } ! 369: } ! 370: if (*src == '\\') { ! 371: src++; ! 372: } ! 373: firstChar = src+1; ! 374: } ! 375: if (firstChar != src) { ! 376: if (Tcl_SetVar(interp, argPtr[3], firstChar, ! 377: TCL_APPEND_VALUE) == NULL) { ! 378: goto cantSet; ! 379: } ! 380: } ! 381: p = regexpPtr->endp[0]; ! 382: if (!all) { ! 383: break; ! 384: } ! 385: } ! 386: ! 387: /* ! 388: * If there were no matches at all, then return a "0" result. ! 389: */ ! 390: ! 391: if (p == string) { ! 392: interp->result = "0"; ! 393: result = TCL_OK; ! 394: goto done; ! 395: } ! 396: ! 397: /* ! 398: * Copy the portion of the source string after the last match to the ! 399: * result variable. ! 400: */ ! 401: ! 402: if (*p != 0) { ! 403: if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) { ! 404: goto cantSet; ! 405: } ! 406: } ! 407: interp->result = "1"; ! 408: result = TCL_OK; ! 409: ! 410: done: ! 411: if (string != argPtr[1]) { ! 412: ckfree(string); ! 413: } ! 414: return result; ! 415: } ! 416: ! 417: /* ! 418: *---------------------------------------------------------------------- ! 419: * ! 420: * Tcl_RenameCmd -- ! 421: * ! 422: * This procedure is invoked to process the "rename" Tcl command. ! 423: * See the user documentation for details on what it does. ! 424: * ! 425: * Results: ! 426: * A standard Tcl result. ! 427: * ! 428: * Side effects: ! 429: * See the user documentation. ! 430: * ! 431: *---------------------------------------------------------------------- ! 432: */ ! 433: ! 434: /* ARGSUSED */ ! 435: int ! 436: Tcl_RenameCmd(dummy, interp, argc, argv) ! 437: ClientData dummy; /* Not used. */ ! 438: Tcl_Interp *interp; /* Current interpreter. */ ! 439: int argc; /* Number of arguments. */ ! 440: char **argv; /* Argument strings. */ ! 441: { ! 442: register Command *cmdPtr; ! 443: Interp *iPtr = (Interp *) interp; ! 444: Tcl_HashEntry *hPtr; ! 445: int new; ! 446: ! 447: if (argc != 3) { ! 448: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 449: " oldName newName\"", (char *) NULL); ! 450: return TCL_ERROR; ! 451: } ! 452: if (argv[2][0] == '\0') { ! 453: if (Tcl_DeleteCommand(interp, argv[1]) != 0) { ! 454: Tcl_AppendResult(interp, "can't delete \"", argv[1], ! 455: "\": command doesn't exist", (char *) NULL); ! 456: return TCL_ERROR; ! 457: } ! 458: return TCL_OK; ! 459: } ! 460: hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]); ! 461: if (hPtr != NULL) { ! 462: Tcl_AppendResult(interp, "can't rename to \"", argv[2], ! 463: "\": command already exists", (char *) NULL); ! 464: return TCL_ERROR; ! 465: } ! 466: hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]); ! 467: if (hPtr == NULL) { ! 468: Tcl_AppendResult(interp, "can't rename \"", argv[1], ! 469: "\": command doesn't exist", (char *) NULL); ! 470: return TCL_ERROR; ! 471: } ! 472: cmdPtr = (Command *) Tcl_GetHashValue(hPtr); ! 473: Tcl_DeleteHashEntry(hPtr); ! 474: hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new); ! 475: Tcl_SetHashValue(hPtr, cmdPtr); ! 476: return TCL_OK; ! 477: } ! 478: ! 479: /* ! 480: *---------------------------------------------------------------------- ! 481: * ! 482: * Tcl_ReturnCmd -- ! 483: * ! 484: * This procedure is invoked to process the "return" Tcl command. ! 485: * See the user documentation for details on what it does. ! 486: * ! 487: * Results: ! 488: * A standard Tcl result. ! 489: * ! 490: * Side effects: ! 491: * See the user documentation. ! 492: * ! 493: *---------------------------------------------------------------------- ! 494: */ ! 495: ! 496: /* ARGSUSED */ ! 497: int ! 498: Tcl_ReturnCmd(dummy, interp, argc, argv) ! 499: ClientData dummy; /* Not used. */ ! 500: Tcl_Interp *interp; /* Current interpreter. */ ! 501: int argc; /* Number of arguments. */ ! 502: char **argv; /* Argument strings. */ ! 503: { ! 504: if (argc > 2) { ! 505: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 506: " ?value?\"", (char *) NULL); ! 507: return TCL_ERROR; ! 508: } ! 509: if (argc == 2) { ! 510: Tcl_SetResult(interp, argv[1], TCL_VOLATILE); ! 511: } ! 512: return TCL_RETURN; ! 513: } ! 514: ! 515: /* ! 516: *---------------------------------------------------------------------- ! 517: * ! 518: * Tcl_ScanCmd -- ! 519: * ! 520: * This procedure is invoked to process the "scan" Tcl command. ! 521: * See the user documentation for details on what it does. ! 522: * ! 523: * Results: ! 524: * A standard Tcl result. ! 525: * ! 526: * Side effects: ! 527: * See the user documentation. ! 528: * ! 529: *---------------------------------------------------------------------- ! 530: */ ! 531: ! 532: /* ARGSUSED */ ! 533: int ! 534: Tcl_ScanCmd(dummy, interp, argc, argv) ! 535: ClientData dummy; /* Not used. */ ! 536: Tcl_Interp *interp; /* Current interpreter. */ ! 537: int argc; /* Number of arguments. */ ! 538: char **argv; /* Argument strings. */ ! 539: { ! 540: int arg1Length; /* Number of bytes in argument to be ! 541: * scanned. This gives an upper limit ! 542: * on string field sizes. */ ! 543: # define MAX_FIELDS 20 ! 544: typedef struct { ! 545: char fmt; /* Format for field. */ ! 546: int size; /* How many bytes to allow for ! 547: * field. */ ! 548: char *location; /* Where field will be stored. */ ! 549: } Field; ! 550: Field fields[MAX_FIELDS]; /* Info about all the fields in the ! 551: * format string. */ ! 552: register Field *curField; ! 553: int numFields = 0; /* Number of fields actually ! 554: * specified. */ ! 555: int suppress; /* Current field is assignment- ! 556: * suppressed. */ ! 557: int totalSize = 0; /* Number of bytes needed to store ! 558: * all results combined. */ ! 559: char *results; /* Where scanned output goes. */ ! 560: int numScanned; /* sscanf's result. */ ! 561: register char *fmt; ! 562: int i, widthSpecified; ! 563: ! 564: if (argc < 3) { ! 565: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 566: " string format ?varName varName ...?\"", (char *) NULL); ! 567: return TCL_ERROR; ! 568: } ! 569: ! 570: /* ! 571: * This procedure operates in four stages: ! 572: * 1. Scan the format string, collecting information about each field. ! 573: * 2. Allocate an array to hold all of the scanned fields. ! 574: * 3. Call sscanf to do all the dirty work, and have it store the ! 575: * parsed fields in the array. ! 576: * 4. Pick off the fields from the array and assign them to variables. ! 577: */ ! 578: ! 579: arg1Length = (strlen(argv[1]) + 4) & ~03; ! 580: for (fmt = argv[2]; *fmt != 0; fmt++) { ! 581: if (*fmt != '%') { ! 582: continue; ! 583: } ! 584: fmt++; ! 585: if (*fmt == '*') { ! 586: suppress = 1; ! 587: fmt++; ! 588: } else { ! 589: suppress = 0; ! 590: } ! 591: widthSpecified = 0; ! 592: while (isdigit(*fmt)) { ! 593: widthSpecified = 1; ! 594: fmt++; ! 595: } ! 596: if (suppress) { ! 597: continue; ! 598: } ! 599: if (numFields == MAX_FIELDS) { ! 600: interp->result = "too many fields to scan"; ! 601: return TCL_ERROR; ! 602: } ! 603: curField = &fields[numFields]; ! 604: numFields++; ! 605: switch (*fmt) { ! 606: case 'D': ! 607: case 'O': ! 608: case 'X': ! 609: case 'd': ! 610: case 'o': ! 611: case 'x': ! 612: curField->fmt = 'd'; ! 613: curField->size = sizeof(int); ! 614: break; ! 615: ! 616: case 's': ! 617: curField->fmt = 's'; ! 618: curField->size = arg1Length; ! 619: break; ! 620: ! 621: case 'c': ! 622: if (widthSpecified) { ! 623: interp->result = ! 624: "field width may not be specified in %c conversion"; ! 625: return TCL_ERROR; ! 626: } ! 627: curField->fmt = 'c'; ! 628: curField->size = sizeof(int); ! 629: break; ! 630: ! 631: case 'E': ! 632: case 'F': ! 633: curField->fmt = 'F'; ! 634: curField->size = sizeof(double); ! 635: break; ! 636: ! 637: case 'e': ! 638: case 'f': ! 639: curField->fmt = 'f'; ! 640: curField->size = sizeof(float); ! 641: break; ! 642: ! 643: case '[': ! 644: curField->fmt = 's'; ! 645: curField->size = arg1Length; ! 646: do { ! 647: fmt++; ! 648: } while (*fmt != ']'); ! 649: break; ! 650: ! 651: default: ! 652: sprintf(interp->result, "bad scan conversion character \"%c\"", ! 653: *fmt); ! 654: return TCL_ERROR; ! 655: } ! 656: totalSize += curField->size; ! 657: } ! 658: ! 659: if (numFields != (argc-3)) { ! 660: interp->result = ! 661: "different numbers of variable names and field specifiers"; ! 662: return TCL_ERROR; ! 663: } ! 664: ! 665: /* ! 666: * Step 2: ! 667: */ ! 668: ! 669: results = (char *) ckalloc((unsigned) totalSize); ! 670: for (i = 0, totalSize = 0, curField = fields; ! 671: i < numFields; i++, curField++) { ! 672: curField->location = results + totalSize; ! 673: totalSize += curField->size; ! 674: } ! 675: ! 676: /* ! 677: * Step 3: ! 678: */ ! 679: ! 680: numScanned = sscanf(argv[1], argv[2], ! 681: fields[0].location, fields[1].location, fields[2].location, ! 682: fields[3].location, fields[4].location, fields[5].location, ! 683: fields[6].location, fields[7].location, fields[8].location, ! 684: fields[9].location, fields[10].location, fields[11].location, ! 685: fields[12].location, fields[13].location, fields[14].location, ! 686: fields[15].location, fields[16].location, fields[17].location, ! 687: fields[18].location, fields[19].location); ! 688: ! 689: /* ! 690: * Step 4: ! 691: */ ! 692: ! 693: if (numScanned < numFields) { ! 694: numFields = numScanned; ! 695: } ! 696: for (i = 0, curField = fields; i < numFields; i++, curField++) { ! 697: switch (curField->fmt) { ! 698: char string[120]; ! 699: ! 700: case 'd': ! 701: sprintf(string, "%d", *((int *) curField->location)); ! 702: if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { ! 703: storeError: ! 704: Tcl_AppendResult(interp, ! 705: "couldn't set variable \"", argv[i+3], "\"", ! 706: (char *) NULL); ! 707: ckfree((char *) results); ! 708: return TCL_ERROR; ! 709: } ! 710: break; ! 711: ! 712: case 'c': ! 713: sprintf(string, "%d", *((char *) curField->location) & 0xff); ! 714: if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { ! 715: goto storeError; ! 716: } ! 717: break; ! 718: ! 719: case 's': ! 720: if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) ! 721: == NULL) { ! 722: goto storeError; ! 723: } ! 724: break; ! 725: ! 726: case 'F': ! 727: sprintf(string, "%g", *((double *) curField->location)); ! 728: if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { ! 729: goto storeError; ! 730: } ! 731: break; ! 732: ! 733: case 'f': ! 734: sprintf(string, "%g", *((float *) curField->location)); ! 735: if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { ! 736: goto storeError; ! 737: } ! 738: break; ! 739: } ! 740: } ! 741: ckfree(results); ! 742: sprintf(interp->result, "%d", numScanned); ! 743: return TCL_OK; ! 744: } ! 745: ! 746: /* ! 747: *---------------------------------------------------------------------- ! 748: * ! 749: * Tcl_SplitCmd -- ! 750: * ! 751: * This procedure is invoked to process the "split" Tcl command. ! 752: * See the user documentation for details on what it does. ! 753: * ! 754: * Results: ! 755: * A standard Tcl result. ! 756: * ! 757: * Side effects: ! 758: * See the user documentation. ! 759: * ! 760: *---------------------------------------------------------------------- ! 761: */ ! 762: ! 763: /* ARGSUSED */ ! 764: int ! 765: Tcl_SplitCmd(dummy, interp, argc, argv) ! 766: ClientData dummy; /* Not used. */ ! 767: Tcl_Interp *interp; /* Current interpreter. */ ! 768: int argc; /* Number of arguments. */ ! 769: char **argv; /* Argument strings. */ ! 770: { ! 771: char *splitChars; ! 772: register char *p, *p2; ! 773: char *elementStart; ! 774: ! 775: if (argc == 2) { ! 776: splitChars = " \n\t\r"; ! 777: } else if (argc == 3) { ! 778: splitChars = argv[2]; ! 779: } else { ! 780: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 781: " string ?splitChars?\"", (char *) NULL); ! 782: return TCL_ERROR; ! 783: } ! 784: ! 785: /* ! 786: * Handle the special case of splitting on every character. ! 787: */ ! 788: ! 789: if (*splitChars == 0) { ! 790: char string[2]; ! 791: string[1] = 0; ! 792: for (p = argv[1]; *p != 0; p++) { ! 793: string[0] = *p; ! 794: Tcl_AppendElement(interp, string, 0); ! 795: } ! 796: return TCL_OK; ! 797: } ! 798: ! 799: /* ! 800: * Normal case: split on any of a given set of characters. ! 801: * Discard instances of the split characters. ! 802: */ ! 803: ! 804: for (p = elementStart = argv[1]; *p != 0; p++) { ! 805: char c = *p; ! 806: for (p2 = splitChars; *p2 != 0; p2++) { ! 807: if (*p2 == c) { ! 808: *p = 0; ! 809: Tcl_AppendElement(interp, elementStart, 0); ! 810: *p = c; ! 811: elementStart = p+1; ! 812: break; ! 813: } ! 814: } ! 815: } ! 816: if (p != argv[1]) { ! 817: Tcl_AppendElement(interp, elementStart, 0); ! 818: } ! 819: return TCL_OK; ! 820: } ! 821: ! 822: /* ! 823: *---------------------------------------------------------------------- ! 824: * ! 825: * Tcl_StringCmd -- ! 826: * ! 827: * This procedure is invoked to process the "string" Tcl command. ! 828: * See the user documentation for details on what it does. ! 829: * ! 830: * Results: ! 831: * A standard Tcl result. ! 832: * ! 833: * Side effects: ! 834: * See the user documentation. ! 835: * ! 836: *---------------------------------------------------------------------- ! 837: */ ! 838: ! 839: /* ARGSUSED */ ! 840: int ! 841: Tcl_StringCmd(dummy, interp, argc, argv) ! 842: ClientData dummy; /* Not used. */ ! 843: Tcl_Interp *interp; /* Current interpreter. */ ! 844: int argc; /* Number of arguments. */ ! 845: char **argv; /* Argument strings. */ ! 846: { ! 847: int length; ! 848: register char *p, c; ! 849: int match; ! 850: int first; ! 851: int left = 0, right = 0; ! 852: ! 853: if (argc < 2) { ! 854: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 855: " option arg ?arg ...?\"", (char *) NULL); ! 856: return TCL_ERROR; ! 857: } ! 858: c = argv[1][0]; ! 859: length = strlen(argv[1]); ! 860: if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) { ! 861: if (argc != 4) { ! 862: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 863: " compare string1 string2\"", (char *) NULL); ! 864: return TCL_ERROR; ! 865: } ! 866: match = strcmp(argv[2], argv[3]); ! 867: if (match > 0) { ! 868: interp->result = "1"; ! 869: } else if (match < 0) { ! 870: interp->result = "-1"; ! 871: } else { ! 872: interp->result = "0"; ! 873: } ! 874: return TCL_OK; ! 875: } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) { ! 876: if (argc != 4) { ! 877: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 878: " first string1 string2\"", (char *) NULL); ! 879: return TCL_ERROR; ! 880: } ! 881: first = 1; ! 882: ! 883: firstLast: ! 884: match = -1; ! 885: c = *argv[2]; ! 886: length = strlen(argv[2]); ! 887: for (p = argv[3]; *p != 0; p++) { ! 888: if (*p != c) { ! 889: continue; ! 890: } ! 891: if (strncmp(argv[2], p, length) == 0) { ! 892: match = p-argv[3]; ! 893: if (first) { ! 894: break; ! 895: } ! 896: } ! 897: } ! 898: sprintf(interp->result, "%d", match); ! 899: return TCL_OK; ! 900: } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) { ! 901: int index; ! 902: ! 903: if (argc != 4) { ! 904: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 905: " index string charIndex\"", (char *) NULL); ! 906: return TCL_ERROR; ! 907: } ! 908: if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { ! 909: return TCL_ERROR; ! 910: } ! 911: if ((index >= 0) && (index < strlen(argv[2]))) { ! 912: interp->result[0] = argv[2][index]; ! 913: interp->result[1] = 0; ! 914: } ! 915: return TCL_OK; ! 916: } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0) ! 917: && (length >= 2)) { ! 918: if (argc != 4) { ! 919: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 920: " last string1 string2\"", (char *) NULL); ! 921: return TCL_ERROR; ! 922: } ! 923: first = 0; ! 924: goto firstLast; ! 925: } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0) ! 926: && (length >= 2)) { ! 927: if (argc != 3) { ! 928: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 929: " length string\"", (char *) NULL); ! 930: return TCL_ERROR; ! 931: } ! 932: sprintf(interp->result, "%d", strlen(argv[2])); ! 933: return TCL_OK; ! 934: } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) { ! 935: if (argc != 4) { ! 936: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 937: " match pattern string\"", (char *) NULL); ! 938: return TCL_ERROR; ! 939: } ! 940: if (Tcl_StringMatch(argv[3], argv[2]) != 0) { ! 941: interp->result = "1"; ! 942: } else { ! 943: interp->result = "0"; ! 944: } ! 945: return TCL_OK; ! 946: } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) { ! 947: int first, last, stringLength; ! 948: ! 949: if (argc != 5) { ! 950: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 951: " range string first last\"", (char *) NULL); ! 952: return TCL_ERROR; ! 953: } ! 954: stringLength = strlen(argv[2]); ! 955: if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { ! 956: return TCL_ERROR; ! 957: } ! 958: if ((*argv[4] == 'e') ! 959: && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) { ! 960: last = stringLength-1; ! 961: } else { ! 962: if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) { ! 963: Tcl_ResetResult(interp); ! 964: Tcl_AppendResult(interp, ! 965: "expected integer or \"end\" but got \"", ! 966: argv[4], "\"", (char *) NULL); ! 967: return TCL_ERROR; ! 968: } ! 969: } ! 970: if (first < 0) { ! 971: first = 0; ! 972: } ! 973: if (last >= stringLength) { ! 974: last = stringLength-1; ! 975: } ! 976: if (last >= first) { ! 977: char saved, *p; ! 978: ! 979: p = argv[2] + last + 1; ! 980: saved = *p; ! 981: *p = 0; ! 982: Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE); ! 983: *p = saved; ! 984: } ! 985: return TCL_OK; ! 986: } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0) ! 987: && (length >= 3)) { ! 988: register char *p; ! 989: ! 990: if (argc != 3) { ! 991: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 992: " tolower string\"", (char *) NULL); ! 993: return TCL_ERROR; ! 994: } ! 995: Tcl_SetResult(interp, argv[2], TCL_VOLATILE); ! 996: for (p = interp->result; *p != 0; p++) { ! 997: if (isupper(*p)) { ! 998: *p = tolower(*p); ! 999: } ! 1000: } ! 1001: return TCL_OK; ! 1002: } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0) ! 1003: && (length >= 3)) { ! 1004: register char *p; ! 1005: ! 1006: if (argc != 3) { ! 1007: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 1008: " toupper string\"", (char *) NULL); ! 1009: return TCL_ERROR; ! 1010: } ! 1011: Tcl_SetResult(interp, argv[2], TCL_VOLATILE); ! 1012: for (p = interp->result; *p != 0; p++) { ! 1013: if (islower(*p)) { ! 1014: *p = toupper(*p); ! 1015: } ! 1016: } ! 1017: return TCL_OK; ! 1018: } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0) ! 1019: && (length == 4)) { ! 1020: char *trimChars; ! 1021: register char *p, *checkPtr; ! 1022: ! 1023: left = right = 1; ! 1024: ! 1025: trim: ! 1026: if (argc == 4) { ! 1027: trimChars = argv[3]; ! 1028: } else if (argc == 3) { ! 1029: trimChars = " \t\n\r"; ! 1030: } else { ! 1031: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 1032: " ", argv[1], " string ?chars?\"", (char *) NULL); ! 1033: return TCL_ERROR; ! 1034: } ! 1035: p = argv[2]; ! 1036: if (left) { ! 1037: for (c = *p; c != 0; p++, c = *p) { ! 1038: for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { ! 1039: if (*checkPtr == 0) { ! 1040: goto doneLeft; ! 1041: } ! 1042: } ! 1043: } ! 1044: } ! 1045: doneLeft: ! 1046: Tcl_SetResult(interp, p, TCL_VOLATILE); ! 1047: if (right) { ! 1048: char *donePtr; ! 1049: ! 1050: p = interp->result + strlen(interp->result) - 1; ! 1051: donePtr = &interp->result[-1]; ! 1052: for (c = *p; p != donePtr; p--, c = *p) { ! 1053: for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { ! 1054: if (*checkPtr == 0) { ! 1055: goto doneRight; ! 1056: } ! 1057: } ! 1058: } ! 1059: doneRight: ! 1060: p[1] = 0; ! 1061: } ! 1062: return TCL_OK; ! 1063: } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0) ! 1064: && (length > 4)) { ! 1065: left = 1; ! 1066: argv[1] = "trimleft"; ! 1067: goto trim; ! 1068: } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0) ! 1069: && (length > 4)) { ! 1070: right = 1; ! 1071: argv[1] = "trimright"; ! 1072: goto trim; ! 1073: } else { ! 1074: Tcl_AppendResult(interp, "bad option \"", argv[1], ! 1075: "\": should be compare, first, index, last, length, match, ", ! 1076: "range, tolower, toupper, trim, trimleft, or trimright", ! 1077: (char *) NULL); ! 1078: return TCL_ERROR; ! 1079: } ! 1080: } ! 1081: ! 1082: /* ! 1083: *---------------------------------------------------------------------- ! 1084: * ! 1085: * Tcl_TraceCmd -- ! 1086: * ! 1087: * This procedure is invoked to process the "trace" Tcl command. ! 1088: * See the user documentation for details on what it does. ! 1089: * ! 1090: * Results: ! 1091: * A standard Tcl result. ! 1092: * ! 1093: * Side effects: ! 1094: * See the user documentation. ! 1095: * ! 1096: *---------------------------------------------------------------------- ! 1097: */ ! 1098: ! 1099: /* ARGSUSED */ ! 1100: int ! 1101: Tcl_TraceCmd(dummy, interp, argc, argv) ! 1102: ClientData dummy; /* Not used. */ ! 1103: Tcl_Interp *interp; /* Current interpreter. */ ! 1104: int argc; /* Number of arguments. */ ! 1105: char **argv; /* Argument strings. */ ! 1106: { ! 1107: char c; ! 1108: int length; ! 1109: ! 1110: if (argc < 2) { ! 1111: Tcl_AppendResult(interp, "too few args: should be \"", ! 1112: argv[0], " option [arg arg ...]\"", (char *) NULL); ! 1113: return TCL_ERROR; ! 1114: } ! 1115: c = argv[1][1]; ! 1116: length = strlen(argv[1]); ! 1117: if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) ! 1118: && (length >= 2)) { ! 1119: char *p; ! 1120: int flags, length; ! 1121: TraceVarInfo *tvarPtr; ! 1122: ! 1123: if (argc != 5) { ! 1124: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 1125: argv[0], " variable name ops command\"", (char *) NULL); ! 1126: return TCL_ERROR; ! 1127: } ! 1128: ! 1129: flags = 0; ! 1130: for (p = argv[3] ; *p != 0; p++) { ! 1131: if (*p == 'r') { ! 1132: flags |= TCL_TRACE_READS; ! 1133: } else if (*p == 'w') { ! 1134: flags |= TCL_TRACE_WRITES; ! 1135: } else if (*p == 'u') { ! 1136: flags |= TCL_TRACE_UNSETS; ! 1137: } else { ! 1138: goto badOps; ! 1139: } ! 1140: } ! 1141: if (flags == 0) { ! 1142: goto badOps; ! 1143: } ! 1144: ! 1145: length = strlen(argv[4]); ! 1146: tvarPtr = (TraceVarInfo *) ckalloc((unsigned) ! 1147: (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); ! 1148: tvarPtr->flags = flags; ! 1149: tvarPtr->length = length; ! 1150: flags |= TCL_TRACE_UNSETS; ! 1151: strcpy(tvarPtr->command, argv[4]); ! 1152: if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, ! 1153: (ClientData) tvarPtr) != TCL_OK) { ! 1154: ckfree((char *) tvarPtr); ! 1155: return TCL_ERROR; ! 1156: } ! 1157: } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) ! 1158: && (length >= 2)) == 0) { ! 1159: char *p; ! 1160: int flags, length; ! 1161: TraceVarInfo *tvarPtr; ! 1162: ClientData clientData; ! 1163: ! 1164: if (argc != 5) { ! 1165: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 1166: argv[0], " vdelete name ops command\"", (char *) NULL); ! 1167: return TCL_ERROR; ! 1168: } ! 1169: ! 1170: flags = 0; ! 1171: for (p = argv[3] ; *p != 0; p++) { ! 1172: if (*p == 'r') { ! 1173: flags |= TCL_TRACE_READS; ! 1174: } else if (*p == 'w') { ! 1175: flags |= TCL_TRACE_WRITES; ! 1176: } else if (*p == 'u') { ! 1177: flags |= TCL_TRACE_UNSETS; ! 1178: } else { ! 1179: goto badOps; ! 1180: } ! 1181: } ! 1182: if (flags == 0) { ! 1183: goto badOps; ! 1184: } ! 1185: ! 1186: /* ! 1187: * Search through all of our traces on this variable to ! 1188: * see if there's one with the given command. If so, then ! 1189: * delete the first one that matches. ! 1190: */ ! 1191: ! 1192: length = strlen(argv[4]); ! 1193: clientData = 0; ! 1194: while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, ! 1195: TraceVarProc, clientData)) != 0) { ! 1196: tvarPtr = (TraceVarInfo *) clientData; ! 1197: if ((tvarPtr->length == length) && (tvarPtr->flags == flags) ! 1198: && (strncmp(argv[4], tvarPtr->command, length) == 0)) { ! 1199: Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, ! 1200: TraceVarProc, clientData); ! 1201: ckfree((char *) tvarPtr); ! 1202: break; ! 1203: } ! 1204: } ! 1205: } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) ! 1206: && (length >= 2)) { ! 1207: ClientData clientData; ! 1208: char ops[4], *p; ! 1209: char *prefix = "{"; ! 1210: ! 1211: if (argc != 3) { ! 1212: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 1213: argv[0], " vinfo name\"", (char *) NULL); ! 1214: return TCL_ERROR; ! 1215: } ! 1216: clientData = 0; ! 1217: while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, ! 1218: TraceVarProc, clientData)) != 0) { ! 1219: TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; ! 1220: p = ops; ! 1221: if (tvarPtr->flags & TCL_TRACE_READS) { ! 1222: *p = 'r'; ! 1223: p++; ! 1224: } ! 1225: if (tvarPtr->flags & TCL_TRACE_WRITES) { ! 1226: *p = 'w'; ! 1227: p++; ! 1228: } ! 1229: if (tvarPtr->flags & TCL_TRACE_UNSETS) { ! 1230: *p = 'u'; ! 1231: p++; ! 1232: } ! 1233: *p = '\0'; ! 1234: Tcl_AppendResult(interp, prefix, (char *) NULL); ! 1235: Tcl_AppendElement(interp, ops, 1); ! 1236: Tcl_AppendElement(interp, tvarPtr->command, 0); ! 1237: Tcl_AppendResult(interp, "}", (char *) NULL); ! 1238: prefix = " {"; ! 1239: } ! 1240: } else { ! 1241: Tcl_AppendResult(interp, "bad option \"", argv[1], ! 1242: "\": should be variable, vdelete, or vinfo", ! 1243: (char *) NULL); ! 1244: return TCL_ERROR; ! 1245: } ! 1246: return TCL_OK; ! 1247: ! 1248: badOps: ! 1249: Tcl_AppendResult(interp, "bad operations \"", argv[3], ! 1250: "\": should be one or more of rwu", (char *) NULL); ! 1251: return TCL_ERROR; ! 1252: } ! 1253: ! 1254: /* ! 1255: *---------------------------------------------------------------------- ! 1256: * ! 1257: * TraceVarProc -- ! 1258: * ! 1259: * This procedure is called to handle variable accesses that have ! 1260: * been traced using the "trace" command. ! 1261: * ! 1262: * Results: ! 1263: * Normally returns NULL. If the trace command returns an error, ! 1264: * then this procedure returns an error string. ! 1265: * ! 1266: * Side effects: ! 1267: * Depends on the command associated with the trace. ! 1268: * ! 1269: *---------------------------------------------------------------------- ! 1270: */ ! 1271: ! 1272: /* ARGSUSED */ ! 1273: static char * ! 1274: TraceVarProc(clientData, interp, name1, name2, flags) ! 1275: ClientData clientData; /* Information about the variable trace. */ ! 1276: Tcl_Interp *interp; /* Interpreter containing variable. */ ! 1277: char *name1; /* Name of variable or array. */ ! 1278: char *name2; /* Name of element within array; NULL means ! 1279: * scalar variable is being referenced. */ ! 1280: int flags; /* OR-ed bits giving operation and other ! 1281: * information. */ ! 1282: { ! 1283: TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; ! 1284: char *result; ! 1285: int code, cmdLength, flags1, flags2; ! 1286: Interp dummy; ! 1287: #define STATIC_SIZE 199 ! 1288: char staticSpace[STATIC_SIZE+1]; ! 1289: char *cmdPtr, *p; ! 1290: ! 1291: result = NULL; ! 1292: if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { ! 1293: ! 1294: /* ! 1295: * Generate a command to execute by appending list elements ! 1296: * for the two variable names and the operation. The five ! 1297: * extra characters are for three space, the opcode character, ! 1298: * and the terminating null. ! 1299: */ ! 1300: ! 1301: if (name2 == NULL) { ! 1302: name2 = ""; ! 1303: } ! 1304: cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) + ! 1305: Tcl_ScanElement(name2, &flags2) + 5; ! 1306: if (cmdLength < STATIC_SIZE) { ! 1307: cmdPtr = staticSpace; ! 1308: } else { ! 1309: cmdPtr = (char *) ckalloc((unsigned) cmdLength); ! 1310: } ! 1311: p = cmdPtr; ! 1312: strcpy(p, tvarPtr->command); ! 1313: p += tvarPtr->length; ! 1314: *p = ' '; ! 1315: p++; ! 1316: p += Tcl_ConvertElement(name1, p, flags1); ! 1317: *p = ' '; ! 1318: p++; ! 1319: p += Tcl_ConvertElement(name2, p, flags2); ! 1320: *p = ' '; ! 1321: if (flags & TCL_TRACE_READS) { ! 1322: p[1] = 'r'; ! 1323: } else if (flags & TCL_TRACE_WRITES) { ! 1324: p[1] = 'w'; ! 1325: } else if (flags & TCL_TRACE_UNSETS) { ! 1326: p[1] = 'u'; ! 1327: } ! 1328: p[2] = '\0'; ! 1329: ! 1330: /* ! 1331: * Execute the command. Be careful to save and restore the ! 1332: * result from the interpreter used for the command. ! 1333: */ ! 1334: ! 1335: dummy.freeProc = interp->freeProc; ! 1336: if (interp->freeProc == 0) { ! 1337: Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE); ! 1338: } else { ! 1339: dummy.result = interp->result; ! 1340: } ! 1341: code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL); ! 1342: if (cmdPtr != staticSpace) { ! 1343: ckfree(cmdPtr); ! 1344: } ! 1345: if (code != TCL_OK) { ! 1346: result = "access disallowed by trace command"; ! 1347: Tcl_ResetResult(interp); /* Must clear error state. */ ! 1348: } ! 1349: Tcl_FreeResult(interp); ! 1350: interp->result = dummy.result; ! 1351: interp->freeProc = dummy.freeProc; ! 1352: } ! 1353: if (flags & TCL_TRACE_DESTROYED) { ! 1354: ckfree((char *) tvarPtr); ! 1355: } ! 1356: return result; ! 1357: } ! 1358: ! 1359: /* ! 1360: *---------------------------------------------------------------------- ! 1361: * ! 1362: * Tcl_WhileCmd -- ! 1363: * ! 1364: * This procedure is invoked to process the "while" Tcl command. ! 1365: * See the user documentation for details on what it does. ! 1366: * ! 1367: * Results: ! 1368: * A standard Tcl result. ! 1369: * ! 1370: * Side effects: ! 1371: * See the user documentation. ! 1372: * ! 1373: *---------------------------------------------------------------------- ! 1374: */ ! 1375: ! 1376: /* ARGSUSED */ ! 1377: int ! 1378: Tcl_WhileCmd(dummy, interp, argc, argv) ! 1379: ClientData dummy; /* Not used. */ ! 1380: Tcl_Interp *interp; /* Current interpreter. */ ! 1381: int argc; /* Number of arguments. */ ! 1382: char **argv; /* Argument strings. */ ! 1383: { ! 1384: int result, value; ! 1385: ! 1386: if (argc != 3) { ! 1387: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 1388: argv[0], " test command\"", (char *) NULL); ! 1389: return TCL_ERROR; ! 1390: } ! 1391: ! 1392: while (1) { ! 1393: result = Tcl_ExprBoolean(interp, argv[1], &value); ! 1394: if (result != TCL_OK) { ! 1395: return result; ! 1396: } ! 1397: if (!value) { ! 1398: break; ! 1399: } ! 1400: result = Tcl_Eval(interp, argv[2], 0, (char **) NULL); ! 1401: if (result == TCL_CONTINUE) { ! 1402: result = TCL_OK; ! 1403: } else if (result != TCL_OK) { ! 1404: if (result == TCL_ERROR) { ! 1405: char msg[60]; ! 1406: sprintf(msg, "\n (\"while\" body line %d)", ! 1407: interp->errorLine); ! 1408: Tcl_AddErrorInfo(interp, msg); ! 1409: } ! 1410: break; ! 1411: } ! 1412: } ! 1413: if (result == TCL_BREAK) { ! 1414: result = TCL_OK; ! 1415: } ! 1416: if (result == TCL_OK) { ! 1417: Tcl_ResetResult(interp); ! 1418: } ! 1419: return result; ! 1420: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.