![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclutil.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 tclutil.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 ! root 1: /* ! 2: * tclUtil.c -- ! 3: * ! 4: * This file contains utility procedures that are used by many Tcl ! 5: * commands. ! 6: * ! 7: * Copyright 1987-1991 Regents of the University of California ! 8: * Permission to use, copy, modify, and distribute this ! 9: * software and its documentation for any purpose and without ! 10: * fee is hereby granted, provided that the above copyright ! 11: * notice appear in all copies. The University of California ! 12: * makes no representations about the suitability of this ! 13: * software for any purpose. It is provided "as is" without ! 14: * express or implied warranty. ! 15: */ ! 16: ! 17: #ifndef lint ! 18: static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.63 92/07/02 08:50:54 ouster Exp $ SPRITE (Berkeley)"; ! 19: #endif ! 20: ! 21: #include "tclint.h" ! 22: ! 23: /* ! 24: * The following values are used in the flags returned by Tcl_ScanElement ! 25: * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also ! 26: * defined in tcl.h; make sure its value doesn't overlap with any of the ! 27: * values below. ! 28: * ! 29: * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in ! 30: * braces (e.g. it contains unmatched braces, ! 31: * or ends in a backslash character, or user ! 32: * just doesn't want braces); handle all ! 33: * special characters by adding backslashes. ! 34: * USE_BRACES - 1 means the string contains a special ! 35: * character that can be handled simply by ! 36: * enclosing the entire argument in braces. ! 37: * BRACES_UNMATCHED - 1 means that braces aren't properly matched ! 38: * in the argument. ! 39: */ ! 40: ! 41: #define USE_BRACES 2 ! 42: #define BRACES_UNMATCHED 4 ! 43: ! 44: /* ! 45: * The variable below is set to NULL before invoking regexp functions ! 46: * and checked after those functions. If an error occurred then regerror ! 47: * will set the variable to point to a (static) error message. This ! 48: * mechanism unfortunately does not support multi-threading, but then ! 49: * neither does the rest of the regexp facilities. ! 50: */ ! 51: ! 52: char *tclRegexpError = NULL; ! 53: ! 54: /* ! 55: * Function prototypes for local procedures in this file: ! 56: */ ! 57: ! 58: static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, ! 59: int newSpace)); ! 60: ! 61: /* ! 62: *---------------------------------------------------------------------- ! 63: * ! 64: * TclFindElement -- ! 65: * ! 66: * Given a pointer into a Tcl list, locate the first (or next) ! 67: * element in the list. ! 68: * ! 69: * Results: ! 70: * The return value is normally TCL_OK, which means that the ! 71: * element was successfully located. If TCL_ERROR is returned ! 72: * it means that list didn't have proper list structure; ! 73: * interp->result contains a more detailed error message. ! 74: * ! 75: * If TCL_OK is returned, then *elementPtr will be set to point ! 76: * to the first element of list, and *nextPtr will be set to point ! 77: * to the character just after any white space following the last ! 78: * character that's part of the element. If this is the last argument ! 79: * in the list, then *nextPtr will point to the NULL character at the ! 80: * end of list. If sizePtr is non-NULL, *sizePtr is filled in with ! 81: * the number of characters in the element. If the element is in ! 82: * braces, then *elementPtr will point to the character after the ! 83: * opening brace and *sizePtr will not include either of the braces. ! 84: * If there isn't an element in the list, *sizePtr will be zero, and ! 85: * both *elementPtr and *termPtr will refer to the null character at ! 86: * the end of list. Note: this procedure does NOT collapse backslash ! 87: * sequences. ! 88: * ! 89: * Side effects: ! 90: * None. ! 91: * ! 92: *---------------------------------------------------------------------- ! 93: */ ! 94: ! 95: int ! 96: TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) ! 97: Tcl_Interp *interp; /* Interpreter to use for error reporting. */ ! 98: register char *list; /* String containing Tcl list with zero ! 99: * or more elements (possibly in braces). */ ! 100: char **elementPtr; /* Fill in with location of first significant ! 101: * character in first element of list. */ ! 102: char **nextPtr; /* Fill in with location of character just ! 103: * after all white space following end of ! 104: * argument (i.e. next argument or end of ! 105: * list). */ ! 106: int *sizePtr; /* If non-zero, fill in with size of ! 107: * element. */ ! 108: int *bracePtr; /* If non-zero fill in with non-zero/zero ! 109: * to indicate that arg was/wasn't ! 110: * in braces. */ ! 111: { ! 112: register char *p; ! 113: int openBraces = 0; ! 114: int inQuotes = 0; ! 115: int size; ! 116: ! 117: /* ! 118: * Skim off leading white space and check for an opening brace or ! 119: * quote. Note: use of "isascii" below and elsewhere in this ! 120: * procedure is a temporary workaround (7/27/90) because Mx uses characters ! 121: * with the high-order bit set for some things. This should probably ! 122: * be changed back eventually, or all of Tcl should call isascii. ! 123: */ ! 124: ! 125: while (isascii(*list) && isspace(*list)) { ! 126: list++; ! 127: } ! 128: if (*list == '{') { ! 129: openBraces = 1; ! 130: list++; ! 131: } else if (*list == '"') { ! 132: inQuotes = 1; ! 133: list++; ! 134: } ! 135: if (bracePtr != 0) { ! 136: *bracePtr = openBraces; ! 137: } ! 138: p = list; ! 139: ! 140: /* ! 141: * Find the end of the element (either a space or a close brace or ! 142: * the end of the string). ! 143: */ ! 144: ! 145: while (1) { ! 146: switch (*p) { ! 147: ! 148: /* ! 149: * Open brace: don't treat specially unless the element is ! 150: * in braces. In this case, keep a nesting count. ! 151: */ ! 152: ! 153: case '{': ! 154: if (openBraces != 0) { ! 155: openBraces++; ! 156: } ! 157: break; ! 158: ! 159: /* ! 160: * Close brace: if element is in braces, keep nesting ! 161: * count and quit when the last close brace is seen. ! 162: */ ! 163: ! 164: case '}': ! 165: if (openBraces == 1) { ! 166: char *p2; ! 167: ! 168: size = p - list; ! 169: p++; ! 170: if ((isascii(*p) && isspace(*p)) || (*p == 0)) { ! 171: goto done; ! 172: } ! 173: for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20); ! 174: p2++) { ! 175: /* null body */ ! 176: } ! 177: Tcl_ResetResult(interp); ! 178: sprintf(interp->result, ! 179: "list element in braces followed by \"%.*s\" instead of space", ! 180: p2-p, p); ! 181: return TCL_ERROR; ! 182: } else if (openBraces != 0) { ! 183: openBraces--; ! 184: } ! 185: break; ! 186: ! 187: /* ! 188: * Backslash: skip over everything up to the end of the ! 189: * backslash sequence. ! 190: */ ! 191: ! 192: case '\\': { ! 193: int size; ! 194: ! 195: (void) Tcl_Backslash(p, &size); ! 196: p += size - 1; ! 197: break; ! 198: } ! 199: ! 200: /* ! 201: * Space: ignore if element is in braces or quotes; otherwise ! 202: * terminate element. ! 203: */ ! 204: ! 205: case ' ': ! 206: case '\f': ! 207: case '\n': ! 208: case '\r': ! 209: case '\t': ! 210: case '\v': ! 211: if ((openBraces == 0) && !inQuotes) { ! 212: size = p - list; ! 213: goto done; ! 214: } ! 215: break; ! 216: ! 217: /* ! 218: * Double-quote: if element is in quotes then terminate it. ! 219: */ ! 220: ! 221: case '"': ! 222: if (inQuotes) { ! 223: char *p2; ! 224: ! 225: size = p-list; ! 226: p++; ! 227: if ((isascii(*p) && isspace(*p)) || (*p == 0)) { ! 228: goto done; ! 229: } ! 230: for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20); ! 231: p2++) { ! 232: /* null body */ ! 233: } ! 234: Tcl_ResetResult(interp); ! 235: sprintf(interp->result, ! 236: "list element in quotes followed by \"%.*s\" %s", ! 237: p2-p, p, "instead of space"); ! 238: return TCL_ERROR; ! 239: } ! 240: break; ! 241: ! 242: /* ! 243: * End of list: terminate element. ! 244: */ ! 245: ! 246: case 0: ! 247: if (openBraces != 0) { ! 248: Tcl_SetResult(interp, "unmatched open brace in list", ! 249: TCL_STATIC); ! 250: return TCL_ERROR; ! 251: } else if (inQuotes) { ! 252: Tcl_SetResult(interp, "unmatched open quote in list", ! 253: TCL_STATIC); ! 254: return TCL_ERROR; ! 255: } ! 256: size = p - list; ! 257: goto done; ! 258: ! 259: } ! 260: p++; ! 261: } ! 262: ! 263: done: ! 264: while (isascii(*p) && isspace(*p)) { ! 265: p++; ! 266: } ! 267: *elementPtr = list; ! 268: *nextPtr = p; ! 269: if (sizePtr != 0) { ! 270: *sizePtr = size; ! 271: } ! 272: return TCL_OK; ! 273: } ! 274: ! 275: /* ! 276: *---------------------------------------------------------------------- ! 277: * ! 278: * TclCopyAndCollapse -- ! 279: * ! 280: * Copy a string and eliminate any backslashes that aren't in braces. ! 281: * ! 282: * Results: ! 283: * There is no return value. Count chars. get copied from src ! 284: * to dst. Along the way, if backslash sequences are found outside ! 285: * braces, the backslashes are eliminated in the copy. ! 286: * After scanning count chars. from source, a null character is ! 287: * placed at the end of dst. ! 288: * ! 289: * Side effects: ! 290: * None. ! 291: * ! 292: *---------------------------------------------------------------------- ! 293: */ ! 294: ! 295: void ! 296: TclCopyAndCollapse(count, src, dst) ! 297: int count; /* Total number of characters to copy ! 298: * from src. */ ! 299: register char *src; /* Copy from here... */ ! 300: register char *dst; /* ... to here. */ ! 301: { ! 302: register char c; ! 303: int numRead; ! 304: ! 305: for (c = *src; count > 0; src++, c = *src, count--) { ! 306: if (c == '\\') { ! 307: *dst = Tcl_Backslash(src, &numRead); ! 308: if (*dst != 0) { ! 309: dst++; ! 310: } ! 311: src += numRead-1; ! 312: count -= numRead-1; ! 313: } else { ! 314: *dst = c; ! 315: dst++; ! 316: } ! 317: } ! 318: *dst = 0; ! 319: } ! 320: ! 321: /* ! 322: *---------------------------------------------------------------------- ! 323: * ! 324: * Tcl_SplitList -- ! 325: * ! 326: * Splits a list up into its constituent fields. ! 327: * ! 328: * Results ! 329: * The return value is normally TCL_OK, which means that ! 330: * the list was successfully split up. If TCL_ERROR is ! 331: * returned, it means that "list" didn't have proper list ! 332: * structure; interp->result will contain a more detailed ! 333: * error message. ! 334: * ! 335: * *argvPtr will be filled in with the address of an array ! 336: * whose elements point to the elements of list, in order. ! 337: * *argcPtr will get filled in with the number of valid elements ! 338: * in the array. A single block of memory is dynamically allocated ! 339: * to hold both the argv array and a copy of the list (with ! 340: * backslashes and braces removed in the standard way). ! 341: * The caller must eventually free this memory by calling free() ! 342: * on *argvPtr. Note: *argvPtr and *argcPtr are only modified ! 343: * if the procedure returns normally. ! 344: * ! 345: * Side effects: ! 346: * Memory is allocated. ! 347: * ! 348: *---------------------------------------------------------------------- ! 349: */ ! 350: ! 351: int ! 352: Tcl_SplitList(interp, list, argcPtr, argvPtr) ! 353: Tcl_Interp *interp; /* Interpreter to use for error reporting. */ ! 354: char *list; /* Pointer to string with list structure. */ ! 355: int *argcPtr; /* Pointer to location to fill in with ! 356: * the number of elements in the list. */ ! 357: char ***argvPtr; /* Pointer to place to store pointer to array ! 358: * of pointers to list elements. */ ! 359: { ! 360: char **argv; ! 361: register char *p; ! 362: int size, i, result, elSize, brace; ! 363: char *element; ! 364: ! 365: /* ! 366: * Figure out how much space to allocate. There must be enough ! 367: * space for both the array of pointers and also for a copy of ! 368: * the list. To estimate the number of pointers needed, count ! 369: * the number of space characters in the list. ! 370: */ ! 371: ! 372: for (size = 1, p = list; *p != 0; p++) { ! 373: if (isspace(*p)) { ! 374: size++; ! 375: } ! 376: } ! 377: size++; /* Leave space for final NULL pointer. */ ! 378: argv = (char **) ckalloc((unsigned) ! 379: ((size * sizeof(char *)) + (p - list) + 1)); ! 380: for (i = 0, p = ((char *) argv) + size*sizeof(char *); ! 381: *list != 0; i++) { ! 382: result = TclFindElement(interp, list, &element, &list, &elSize, &brace); ! 383: if (result != TCL_OK) { ! 384: ckfree((char *) argv); ! 385: return result; ! 386: } ! 387: if (*element == 0) { ! 388: break; ! 389: } ! 390: if (i >= size) { ! 391: ckfree((char *) argv); ! 392: Tcl_SetResult(interp, "internal error in Tcl_SplitList", ! 393: TCL_STATIC); ! 394: return TCL_ERROR; ! 395: } ! 396: argv[i] = p; ! 397: if (brace) { ! 398: strncpy(p, element, elSize); ! 399: p += elSize; ! 400: *p = 0; ! 401: p++; ! 402: } else { ! 403: TclCopyAndCollapse(elSize, element, p); ! 404: p += elSize+1; ! 405: } ! 406: } ! 407: ! 408: argv[i] = NULL; ! 409: *argvPtr = argv; ! 410: *argcPtr = i; ! 411: return TCL_OK; ! 412: } ! 413: ! 414: /* ! 415: *---------------------------------------------------------------------- ! 416: * ! 417: * Tcl_ScanElement -- ! 418: * ! 419: * This procedure is a companion procedure to Tcl_ConvertElement. ! 420: * It scans a string to see what needs to be done to it (e.g. ! 421: * add backslashes or enclosing braces) to make the string into ! 422: * a valid Tcl list element. ! 423: * ! 424: * Results: ! 425: * The return value is an overestimate of the number of characters ! 426: * that will be needed by Tcl_ConvertElement to produce a valid ! 427: * list element from string. The word at *flagPtr is filled in ! 428: * with a value needed by Tcl_ConvertElement when doing the actual ! 429: * conversion. ! 430: * ! 431: * Side effects: ! 432: * None. ! 433: * ! 434: *---------------------------------------------------------------------- ! 435: */ ! 436: ! 437: int ! 438: Tcl_ScanElement(string, flagPtr) ! 439: char *string; /* String to convert to Tcl list element. */ ! 440: int *flagPtr; /* Where to store information to guide ! 441: * Tcl_ConvertElement. */ ! 442: { ! 443: int flags, nestingLevel; ! 444: register char *p; ! 445: ! 446: /* ! 447: * This procedure and Tcl_ConvertElement together do two things: ! 448: * ! 449: * 1. They produce a proper list, one that will yield back the ! 450: * argument strings when evaluated or when disassembled with ! 451: * Tcl_SplitList. This is the most important thing. ! 452: * ! 453: * 2. They try to produce legible output, which means minimizing the ! 454: * use of backslashes (using braces instead). However, there are ! 455: * some situations where backslashes must be used (e.g. an element ! 456: * like "{abc": the leading brace will have to be backslashed. For ! 457: * each element, one of three things must be done: ! 458: * ! 459: * (a) Use the element as-is (it doesn't contain anything special ! 460: * characters). This is the most desirable option. ! 461: * ! 462: * (b) Enclose the element in braces, but leave the contents alone. ! 463: * This happens if the element contains embedded space, or if it ! 464: * contains characters with special interpretation ($, [, ;, or \), ! 465: * or if it starts with a brace or double-quote, or if there are ! 466: * no characters in the element. ! 467: * ! 468: * (c) Don't enclose the element in braces, but add backslashes to ! 469: * prevent special interpretation of special characters. This is a ! 470: * last resort used when the argument would normally fall under case ! 471: * (b) but contains unmatched braces. It also occurs if the last ! 472: * character of the argument is a backslash. ! 473: * ! 474: * The procedure figures out how many bytes will be needed to store ! 475: * the result (actually, it overestimates). It also collects information ! 476: * about the element in the form of a flags word. ! 477: */ ! 478: ! 479: nestingLevel = 0; ! 480: flags = 0; ! 481: p = string; ! 482: if ((*p == '{') || (*p == '"') || (*p == 0)) { ! 483: flags |= USE_BRACES; ! 484: } ! 485: for ( ; *p != 0; p++) { ! 486: switch (*p) { ! 487: case '{': ! 488: nestingLevel++; ! 489: break; ! 490: case '}': ! 491: nestingLevel--; ! 492: if (nestingLevel < 0) { ! 493: flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; ! 494: } ! 495: break; ! 496: case '[': ! 497: case '$': ! 498: case ';': ! 499: case ' ': ! 500: case '\f': ! 501: case '\n': ! 502: case '\r': ! 503: case '\t': ! 504: case '\v': ! 505: flags |= USE_BRACES; ! 506: break; ! 507: case '\\': ! 508: if (p[1] == 0) { ! 509: flags = TCL_DONT_USE_BRACES; ! 510: } else { ! 511: int size; ! 512: ! 513: (void) Tcl_Backslash(p, &size); ! 514: p += size-1; ! 515: flags |= USE_BRACES; ! 516: } ! 517: break; ! 518: } ! 519: } ! 520: if (nestingLevel != 0) { ! 521: flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; ! 522: } ! 523: *flagPtr = flags; ! 524: ! 525: /* ! 526: * Allow enough space to backslash every character plus leave ! 527: * two spaces for braces. ! 528: */ ! 529: ! 530: return 2*(p-string) + 2; ! 531: } ! 532: ! 533: /* ! 534: *---------------------------------------------------------------------- ! 535: * ! 536: * Tcl_ConvertElement -- ! 537: * ! 538: * This is a companion procedure to Tcl_ScanElement. Given the ! 539: * information produced by Tcl_ScanElement, this procedure converts ! 540: * a string to a list element equal to that string. ! 541: * ! 542: * Results: ! 543: * Information is copied to *dst in the form of a list element ! 544: * identical to src (i.e. if Tcl_SplitList is applied to dst it ! 545: * will produce a string identical to src). The return value is ! 546: * a count of the number of characters copied (not including the ! 547: * terminating NULL character). ! 548: * ! 549: * Side effects: ! 550: * None. ! 551: * ! 552: *---------------------------------------------------------------------- ! 553: */ ! 554: ! 555: int ! 556: Tcl_ConvertElement(src, dst, flags) ! 557: register char *src; /* Source information for list element. */ ! 558: char *dst; /* Place to put list-ified element. */ ! 559: int flags; /* Flags produced by Tcl_ScanElement. */ ! 560: { ! 561: register char *p = dst; ! 562: ! 563: /* ! 564: * See the comment block at the beginning of the Tcl_ScanElement ! 565: * code for details of how this works. ! 566: */ ! 567: ! 568: if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { ! 569: *p = '{'; ! 570: p++; ! 571: for ( ; *src != 0; src++, p++) { ! 572: *p = *src; ! 573: } ! 574: *p = '}'; ! 575: p++; ! 576: } else if (*src == 0) { ! 577: /* ! 578: * If string is empty but can't use braces, then use special ! 579: * backslash sequence that maps to empty string. ! 580: */ ! 581: ! 582: p[0] = '\\'; ! 583: p[1] = '0'; ! 584: p += 2; ! 585: } else { ! 586: for (; *src != 0 ; src++) { ! 587: switch (*src) { ! 588: case ']': ! 589: case '[': ! 590: case '$': ! 591: case ';': ! 592: case ' ': ! 593: case '\\': ! 594: case '"': ! 595: *p = '\\'; ! 596: p++; ! 597: break; ! 598: case '{': ! 599: case '}': ! 600: if (flags & BRACES_UNMATCHED) { ! 601: *p = '\\'; ! 602: p++; ! 603: } ! 604: break; ! 605: case '\f': ! 606: *p = '\\'; ! 607: p++; ! 608: *p = 'f'; ! 609: p++; ! 610: continue; ! 611: case '\n': ! 612: *p = '\\'; ! 613: p++; ! 614: *p = 'n'; ! 615: p++; ! 616: continue; ! 617: case '\r': ! 618: *p = '\\'; ! 619: p++; ! 620: *p = 'r'; ! 621: p++; ! 622: continue; ! 623: case '\t': ! 624: *p = '\\'; ! 625: p++; ! 626: *p = 't'; ! 627: p++; ! 628: continue; ! 629: case '\v': ! 630: *p = '\\'; ! 631: p++; ! 632: *p = 'v'; ! 633: p++; ! 634: continue; ! 635: } ! 636: *p = *src; ! 637: p++; ! 638: } ! 639: } ! 640: *p = '\0'; ! 641: return p-dst; ! 642: } ! 643: ! 644: /* ! 645: *---------------------------------------------------------------------- ! 646: * ! 647: * Tcl_Merge -- ! 648: * ! 649: * Given a collection of strings, merge them together into a ! 650: * single string that has proper Tcl list structured (i.e. ! 651: * Tcl_SplitList may be used to retrieve strings equal to the ! 652: * original elements, and Tcl_Eval will parse the string back ! 653: * into its original elements). ! 654: * ! 655: * Results: ! 656: * The return value is the address of a dynamically-allocated ! 657: * string containing the merged list. ! 658: * ! 659: * Side effects: ! 660: * None. ! 661: * ! 662: *---------------------------------------------------------------------- ! 663: */ ! 664: ! 665: char * ! 666: Tcl_Merge(argc, argv) ! 667: int argc; /* How many strings to merge. */ ! 668: char **argv; /* Array of string values. */ ! 669: { ! 670: # define LOCAL_SIZE 20 ! 671: int localFlags[LOCAL_SIZE], *flagPtr; ! 672: int numChars; ! 673: char *result; ! 674: register char *dst; ! 675: int i; ! 676: ! 677: /* ! 678: * Pass 1: estimate space, gather flags. ! 679: */ ! 680: ! 681: if (argc <= LOCAL_SIZE) { ! 682: flagPtr = localFlags; ! 683: } else { ! 684: flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); ! 685: } ! 686: numChars = 1; ! 687: for (i = 0; i < argc; i++) { ! 688: numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; ! 689: } ! 690: ! 691: /* ! 692: * Pass two: copy into the result area. ! 693: */ ! 694: ! 695: result = (char *) ckalloc((unsigned) numChars); ! 696: dst = result; ! 697: for (i = 0; i < argc; i++) { ! 698: numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); ! 699: dst += numChars; ! 700: *dst = ' '; ! 701: dst++; ! 702: } ! 703: if (dst == result) { ! 704: *dst = 0; ! 705: } else { ! 706: dst[-1] = 0; ! 707: } ! 708: ! 709: if (flagPtr != localFlags) { ! 710: ckfree((char *) flagPtr); ! 711: } ! 712: return result; ! 713: } ! 714: ! 715: /* ! 716: *---------------------------------------------------------------------- ! 717: * ! 718: * Tcl_Concat -- ! 719: * ! 720: * Concatenate a set of strings into a single large string. ! 721: * ! 722: * Results: ! 723: * The return value is dynamically-allocated string containing ! 724: * a concatenation of all the strings in argv, with spaces between ! 725: * the original argv elements. ! 726: * ! 727: * Side effects: ! 728: * Memory is allocated for the result; the caller is responsible ! 729: * for freeing the memory. ! 730: * ! 731: *---------------------------------------------------------------------- ! 732: */ ! 733: ! 734: char * ! 735: Tcl_Concat(argc, argv) ! 736: int argc; /* Number of strings to concatenate. */ ! 737: char **argv; /* Array of strings to concatenate. */ ! 738: { ! 739: int totalSize, i; ! 740: register char *p; ! 741: char *result; ! 742: ! 743: for (totalSize = 1, i = 0; i < argc; i++) { ! 744: totalSize += strlen(argv[i]) + 1; ! 745: } ! 746: result = (char *) ckalloc((unsigned) totalSize); ! 747: if (argc == 0) { ! 748: *result = '\0'; ! 749: return result; ! 750: } ! 751: for (p = result, i = 0; i < argc; i++) { ! 752: char *element; ! 753: int length; ! 754: ! 755: /* ! 756: * Clip white space off the front and back of the string ! 757: * to generate a neater result, and ignore any empty ! 758: * elements. ! 759: */ ! 760: ! 761: element = argv[i]; ! 762: while (isspace(*element)) { ! 763: element++; ! 764: } ! 765: for (length = strlen(element); ! 766: (length > 0) && (isspace(element[length-1])); ! 767: length--) { ! 768: /* Null loop body. */ ! 769: } ! 770: if (length == 0) { ! 771: continue; ! 772: } ! 773: (void) strncpy(p, element, length); ! 774: p += length; ! 775: *p = ' '; ! 776: p++; ! 777: } ! 778: if (p != result) { ! 779: p[-1] = 0; ! 780: } else { ! 781: *p = 0; ! 782: } ! 783: return result; ! 784: } ! 785: ! 786: /* ! 787: *---------------------------------------------------------------------- ! 788: * ! 789: * Tcl_StringMatch -- ! 790: * ! 791: * See if a particular string matches a particular pattern. ! 792: * ! 793: * Results: ! 794: * The return value is 1 if string matches pattern, and ! 795: * 0 otherwise. The matching operation permits the following ! 796: * special characters in the pattern: *?\[] (see the manual ! 797: * entry for details on what these mean). ! 798: * ! 799: * Side effects: ! 800: * None. ! 801: * ! 802: *---------------------------------------------------------------------- ! 803: */ ! 804: ! 805: int ! 806: Tcl_StringMatch(string, pattern) ! 807: register char *string; /* String. */ ! 808: register char *pattern; /* Pattern, which may contain ! 809: * special characters. */ ! 810: { ! 811: char c2; ! 812: ! 813: while (1) { ! 814: /* See if we're at the end of both the pattern and the string. ! 815: * If so, we succeeded. If we're at the end of the pattern ! 816: * but not at the end of the string, we failed. ! 817: */ ! 818: ! 819: if (*pattern == 0) { ! 820: if (*string == 0) { ! 821: return 1; ! 822: } else { ! 823: return 0; ! 824: } ! 825: } ! 826: if ((*string == 0) && (*pattern != '*')) { ! 827: return 0; ! 828: } ! 829: ! 830: /* Check for a "*" as the next pattern character. It matches ! 831: * any substring. We handle this by calling ourselves ! 832: * recursively for each postfix of string, until either we ! 833: * match or we reach the end of the string. ! 834: */ ! 835: ! 836: if (*pattern == '*') { ! 837: pattern += 1; ! 838: if (*pattern == 0) { ! 839: return 1; ! 840: } ! 841: while (1) { ! 842: if (Tcl_StringMatch(string, pattern)) { ! 843: return 1; ! 844: } ! 845: if (*string == 0) { ! 846: return 0; ! 847: } ! 848: string += 1; ! 849: } ! 850: } ! 851: ! 852: /* Check for a "?" as the next pattern character. It matches ! 853: * any single character. ! 854: */ ! 855: ! 856: if (*pattern == '?') { ! 857: goto thisCharOK; ! 858: } ! 859: ! 860: /* Check for a "[" as the next pattern character. It is followed ! 861: * by a list of characters that are acceptable, or by a range ! 862: * (two characters separated by "-"). ! 863: */ ! 864: ! 865: if (*pattern == '[') { ! 866: pattern += 1; ! 867: while (1) { ! 868: if ((*pattern == ']') || (*pattern == 0)) { ! 869: return 0; ! 870: } ! 871: if (*pattern == *string) { ! 872: break; ! 873: } ! 874: if (pattern[1] == '-') { ! 875: c2 = pattern[2]; ! 876: if (c2 == 0) { ! 877: return 0; ! 878: } ! 879: if ((*pattern <= *string) && (c2 >= *string)) { ! 880: break; ! 881: } ! 882: if ((*pattern >= *string) && (c2 <= *string)) { ! 883: break; ! 884: } ! 885: pattern += 2; ! 886: } ! 887: pattern += 1; ! 888: } ! 889: while ((*pattern != ']') && (*pattern != 0)) { ! 890: pattern += 1; ! 891: } ! 892: goto thisCharOK; ! 893: } ! 894: ! 895: /* If the next pattern character is '/', just strip off the '/' ! 896: * so we do exact matching on the character that follows. ! 897: */ ! 898: ! 899: if (*pattern == '\\') { ! 900: pattern += 1; ! 901: if (*pattern == 0) { ! 902: return 0; ! 903: } ! 904: } ! 905: ! 906: /* There's no special character. Just make sure that the next ! 907: * characters of each string match. ! 908: */ ! 909: ! 910: if (*pattern != *string) { ! 911: return 0; ! 912: } ! 913: ! 914: thisCharOK: pattern += 1; ! 915: string += 1; ! 916: } ! 917: } ! 918: ! 919: /* ! 920: *---------------------------------------------------------------------- ! 921: * ! 922: * Tcl_SetResult -- ! 923: * ! 924: * Arrange for "string" to be the Tcl return value. ! 925: * ! 926: * Results: ! 927: * None. ! 928: * ! 929: * Side effects: ! 930: * interp->result is left pointing either to "string" (if "copy" is 0) ! 931: * or to a copy of string. ! 932: * ! 933: *---------------------------------------------------------------------- ! 934: */ ! 935: ! 936: void ! 937: Tcl_SetResult(interp, string, freeProc) ! 938: Tcl_Interp *interp; /* Interpreter with which to associate the ! 939: * return value. */ ! 940: char *string; /* Value to be returned. If NULL, ! 941: * the result is set to an empty string. */ ! 942: Tcl_FreeProc *freeProc; /* Gives information about the string: ! 943: * TCL_STATIC, TCL_VOLATILE, or the address ! 944: * of a Tcl_FreeProc such as free. */ ! 945: { ! 946: register Interp *iPtr = (Interp *) interp; ! 947: int length; ! 948: Tcl_FreeProc *oldFreeProc = iPtr->freeProc; ! 949: char *oldResult = iPtr->result; ! 950: ! 951: iPtr->freeProc = freeProc; ! 952: if (string == NULL) { ! 953: iPtr->resultSpace[0] = 0; ! 954: iPtr->result = iPtr->resultSpace; ! 955: iPtr->freeProc = 0; ! 956: } else if (freeProc == TCL_VOLATILE) { ! 957: length = strlen(string); ! 958: if (length > TCL_RESULT_SIZE) { ! 959: iPtr->result = (char *) ckalloc((unsigned) length+1); ! 960: iPtr->freeProc = (Tcl_FreeProc *) free; ! 961: } else { ! 962: iPtr->result = iPtr->resultSpace; ! 963: iPtr->freeProc = 0; ! 964: } ! 965: strcpy(iPtr->result, string); ! 966: } else { ! 967: iPtr->result = string; ! 968: } ! 969: ! 970: /* ! 971: * If the old result was dynamically-allocated, free it up. Do it ! 972: * here, rather than at the beginning, in case the new result value ! 973: * was part of the old result value. ! 974: */ ! 975: ! 976: if (oldFreeProc != 0) { ! 977: (*oldFreeProc)(oldResult); ! 978: } ! 979: } ! 980: ! 981: /* ! 982: *---------------------------------------------------------------------- ! 983: * ! 984: * Tcl_AppendResult -- ! 985: * ! 986: * Append a variable number of strings onto the result already ! 987: * present for an interpreter. ! 988: * ! 989: * Results: ! 990: * None. ! 991: * ! 992: * Side effects: ! 993: * The result in the interpreter given by the first argument ! 994: * is extended by the strings given by the second and following ! 995: * arguments (up to a terminating NULL argument). ! 996: * ! 997: *---------------------------------------------------------------------- ! 998: */ ! 999: ! 1000: void ! 1001: Tcl_AppendResult(Tcl_Interp *interp, ...) ! 1002: { ! 1003: va_list argList; ! 1004: register Interp *iPtr; ! 1005: char *string; ! 1006: int newSpace; ! 1007: ! 1008: /* ! 1009: * First, scan through all the arguments to see how much space is ! 1010: * needed. ! 1011: */ ! 1012: ! 1013: va_start(argList, interp); ! 1014: iPtr = (Interp *)interp; ! 1015: newSpace = 0; ! 1016: while (1) { ! 1017: string = va_arg(argList, char *); ! 1018: if (string == NULL) { ! 1019: break; ! 1020: } ! 1021: newSpace += strlen(string); ! 1022: } ! 1023: va_end(argList); ! 1024: ! 1025: /* ! 1026: * If the append buffer isn't already setup and large enough ! 1027: * to hold the new data, set it up. ! 1028: */ ! 1029: ! 1030: if ((iPtr->result != iPtr->appendResult) ! 1031: || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { ! 1032: SetupAppendBuffer(iPtr, newSpace); ! 1033: } ! 1034: ! 1035: /* ! 1036: * Final step: go through all the argument strings again, copying ! 1037: * them into the buffer. ! 1038: */ ! 1039: ! 1040: va_start(argList, interp); ! 1041: while (1) { ! 1042: string = va_arg(argList, char *); ! 1043: if (string == NULL) { ! 1044: break; ! 1045: } ! 1046: strcpy(iPtr->appendResult + iPtr->appendUsed, string); ! 1047: iPtr->appendUsed += strlen(string); ! 1048: } ! 1049: va_end(argList); ! 1050: } ! 1051: ! 1052: /* ! 1053: *---------------------------------------------------------------------- ! 1054: * ! 1055: * Tcl_AppendElement -- ! 1056: * ! 1057: * Convert a string to a valid Tcl list element and append it ! 1058: * to the current result (which is ostensibly a list). ! 1059: * ! 1060: * Results: ! 1061: * None. ! 1062: * ! 1063: * Side effects: ! 1064: * The result in the interpreter given by the first argument ! 1065: * is extended with a list element converted from string. If ! 1066: * the original result wasn't empty, then a blank is added before ! 1067: * the converted list element. ! 1068: * ! 1069: *---------------------------------------------------------------------- ! 1070: */ ! 1071: ! 1072: void ! 1073: Tcl_AppendElement(interp, string, noSep) ! 1074: Tcl_Interp *interp; /* Interpreter whose result is to be ! 1075: * extended. */ ! 1076: char *string; /* String to convert to list element and ! 1077: * add to result. */ ! 1078: int noSep; /* If non-zero, then don't output a ! 1079: * space character before this element, ! 1080: * even if the element isn't the first ! 1081: * thing in the output buffer. */ ! 1082: { ! 1083: register Interp *iPtr = (Interp *) interp; ! 1084: int size, flags; ! 1085: char *dst; ! 1086: ! 1087: /* ! 1088: * See how much space is needed, and grow the append buffer if ! 1089: * needed to accommodate the list element. ! 1090: */ ! 1091: ! 1092: size = Tcl_ScanElement(string, &flags) + 1; ! 1093: if ((iPtr->result != iPtr->appendResult) ! 1094: || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { ! 1095: SetupAppendBuffer(iPtr, size+iPtr->appendUsed); ! 1096: } ! 1097: ! 1098: /* ! 1099: * Convert the string into a list element and copy it to the ! 1100: * buffer that's forming. ! 1101: */ ! 1102: ! 1103: dst = iPtr->appendResult + iPtr->appendUsed; ! 1104: if (!noSep && (iPtr->appendUsed != 0)) { ! 1105: iPtr->appendUsed++; ! 1106: *dst = ' '; ! 1107: dst++; ! 1108: } ! 1109: iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); ! 1110: } ! 1111: ! 1112: /* ! 1113: *---------------------------------------------------------------------- ! 1114: * ! 1115: * SetupAppendBuffer -- ! 1116: * ! 1117: * This procedure makes sure that there is an append buffer ! 1118: * properly initialized for interp, and that it has at least ! 1119: * enough room to accommodate newSpace new bytes of information. ! 1120: * ! 1121: * Results: ! 1122: * None. ! 1123: * ! 1124: * Side effects: ! 1125: * None. ! 1126: * ! 1127: *---------------------------------------------------------------------- ! 1128: */ ! 1129: ! 1130: static void ! 1131: SetupAppendBuffer(iPtr, newSpace) ! 1132: register Interp *iPtr; /* Interpreter whose result is being set up. */ ! 1133: int newSpace; /* Make sure that at least this many bytes ! 1134: * of new information may be added. */ ! 1135: { ! 1136: int totalSpace; ! 1137: ! 1138: /* ! 1139: * Make the append buffer larger, if that's necessary, then ! 1140: * copy the current result into the append buffer and make the ! 1141: * append buffer the official Tcl result. ! 1142: */ ! 1143: ! 1144: if (iPtr->result != iPtr->appendResult) { ! 1145: /* ! 1146: * If an oversized buffer was used recently, then free it up ! 1147: * so we go back to a smaller buffer. This avoids tying up ! 1148: * memory forever after a large operation. ! 1149: */ ! 1150: ! 1151: if (iPtr->appendAvl > 500) { ! 1152: ckfree(iPtr->appendResult); ! 1153: iPtr->appendResult = NULL; ! 1154: iPtr->appendAvl = 0; ! 1155: } ! 1156: iPtr->appendUsed = strlen(iPtr->result); ! 1157: } ! 1158: totalSpace = newSpace + iPtr->appendUsed; ! 1159: if (totalSpace >= iPtr->appendAvl) { ! 1160: char *new; ! 1161: ! 1162: if (totalSpace < 100) { ! 1163: totalSpace = 200; ! 1164: } else { ! 1165: totalSpace *= 2; ! 1166: } ! 1167: new = (char *) ckalloc((unsigned) totalSpace); ! 1168: strcpy(new, iPtr->result); ! 1169: if (iPtr->appendResult != NULL) { ! 1170: ckfree(iPtr->appendResult); ! 1171: } ! 1172: iPtr->appendResult = new; ! 1173: iPtr->appendAvl = totalSpace; ! 1174: } else if (iPtr->result != iPtr->appendResult) { ! 1175: strcpy(iPtr->appendResult, iPtr->result); ! 1176: } ! 1177: Tcl_FreeResult(iPtr); ! 1178: iPtr->result = iPtr->appendResult; ! 1179: } ! 1180: ! 1181: /* ! 1182: *---------------------------------------------------------------------- ! 1183: * ! 1184: * Tcl_ResetResult -- ! 1185: * ! 1186: * This procedure restores the result area for an interpreter ! 1187: * to its default initialized state, freeing up any memory that ! 1188: * may have been allocated for the result and clearing any ! 1189: * error information for the interpreter. ! 1190: * ! 1191: * Results: ! 1192: * None. ! 1193: * ! 1194: * Side effects: ! 1195: * None. ! 1196: * ! 1197: *---------------------------------------------------------------------- ! 1198: */ ! 1199: ! 1200: void ! 1201: Tcl_ResetResult(interp) ! 1202: Tcl_Interp *interp; /* Interpreter for which to clear result. */ ! 1203: { ! 1204: register Interp *iPtr = (Interp *) interp; ! 1205: ! 1206: Tcl_FreeResult(iPtr); ! 1207: iPtr->result = iPtr->resultSpace; ! 1208: iPtr->resultSpace[0] = 0; ! 1209: iPtr->flags &= ! 1210: ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); ! 1211: } ! 1212: ! 1213: /* ! 1214: *---------------------------------------------------------------------- ! 1215: * ! 1216: * Tcl_SetErrorCode -- ! 1217: * ! 1218: * This procedure is called to record machine-readable information ! 1219: * about an error that is about to be returned. ! 1220: * ! 1221: * Results: ! 1222: * None. ! 1223: * ! 1224: * Side effects: ! 1225: * The errorCode global variable is modified to hold all of the ! 1226: * arguments to this procedure, in a list form with each argument ! 1227: * becoming one element of the list. A flag is set internally ! 1228: * to remember that errorCode has been set, so the variable doesn't ! 1229: * get set automatically when the error is returned. ! 1230: * ! 1231: *---------------------------------------------------------------------- ! 1232: */ ! 1233: void ! 1234: Tcl_SetErrorCode(Tcl_Interp *interp, ...) ! 1235: { ! 1236: va_list argList; ! 1237: char *string; ! 1238: int flags; ! 1239: Interp *iPtr; ! 1240: ! 1241: /* ! 1242: * Scan through the arguments one at a time, appending them to ! 1243: * $errorCode as list elements. ! 1244: */ ! 1245: ! 1246: va_start(argList, interp); ! 1247: iPtr = (Interp *)interp; ! 1248: flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; ! 1249: while (1) { ! 1250: string = va_arg(argList, char *); ! 1251: if (string == NULL) { ! 1252: break; ! 1253: } ! 1254: (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", ! 1255: (char *) NULL, string, flags); ! 1256: flags |= TCL_APPEND_VALUE; ! 1257: } ! 1258: va_end(argList); ! 1259: iPtr->flags |= ERROR_CODE_SET; ! 1260: } ! 1261: ! 1262: /* ! 1263: *---------------------------------------------------------------------- ! 1264: * ! 1265: * TclGetListIndex -- ! 1266: * ! 1267: * Parse a list index, which may be either an integer or the ! 1268: * value "end". ! 1269: * ! 1270: * Results: ! 1271: * The return value is either TCL_OK or TCL_ERROR. If it is ! 1272: * TCL_OK, then the index corresponding to string is left in ! 1273: * *indexPtr. If the return value is TCL_ERROR, then string ! 1274: * was bogus; an error message is returned in interp->result. ! 1275: * If a negative index is specified, it is rounded up to 0. ! 1276: * The index value may be larger than the size of the list ! 1277: * (this happens when "end" is specified). ! 1278: * ! 1279: * Side effects: ! 1280: * None. ! 1281: * ! 1282: *---------------------------------------------------------------------- ! 1283: */ ! 1284: ! 1285: int ! 1286: TclGetListIndex(interp, string, indexPtr) ! 1287: Tcl_Interp *interp; /* Interpreter for error reporting. */ ! 1288: char *string; /* String containing list index. */ ! 1289: int *indexPtr; /* Where to store index. */ ! 1290: { ! 1291: if (isdigit(*string) || (*string == '-')) { ! 1292: if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { ! 1293: return TCL_ERROR; ! 1294: } ! 1295: if (*indexPtr < 0) { ! 1296: *indexPtr = 0; ! 1297: } ! 1298: } else if (strncmp(string, "end", strlen(string)) == 0) { ! 1299: *indexPtr = 1<<30; ! 1300: } else { ! 1301: Tcl_AppendResult(interp, "bad index \"", string, ! 1302: "\": must be integer or \"end\"", (char *) NULL); ! 1303: return TCL_ERROR; ! 1304: } ! 1305: return TCL_OK; ! 1306: } ! 1307: ! 1308: /* ! 1309: *---------------------------------------------------------------------- ! 1310: * ! 1311: * TclCompileRegexp -- ! 1312: * ! 1313: * Compile a regular expression into a form suitable for fast ! 1314: * matching. This procedure retains a small cache of pre-compiled ! 1315: * regular expressions in the interpreter, in order to avoid ! 1316: * compilation costs as much as possible. ! 1317: * ! 1318: * Results: ! 1319: * The return value is a pointer to the compiled form of string, ! 1320: * suitable for passing to regexec. If an error occurred while ! 1321: * compiling the pattern, then NULL is returned and an error ! 1322: * message is left in interp->result. ! 1323: * ! 1324: * Side effects: ! 1325: * The cache of compiled regexp's in interp will be modified to ! 1326: * hold information for string, if such information isn't already ! 1327: * present in the cache. ! 1328: * ! 1329: *---------------------------------------------------------------------- ! 1330: */ ! 1331: ! 1332: regexp * ! 1333: TclCompileRegexp(interp, string) ! 1334: Tcl_Interp *interp; /* For use in error reporting. */ ! 1335: char *string; /* String for which to produce ! 1336: * compiled regular expression. */ ! 1337: { ! 1338: register Interp *iPtr = (Interp *) interp; ! 1339: int i, length; ! 1340: regexp *result; ! 1341: ! 1342: length = strlen(string); ! 1343: for (i = 0; i < NUM_REGEXPS; i++) { ! 1344: if ((length == iPtr->patLengths[i]) ! 1345: && (strcmp(string, iPtr->patterns[i]) == 0)) { ! 1346: /* ! 1347: * Move the matched pattern to the first slot in the ! 1348: * cache and shift the other patterns down one position. ! 1349: */ ! 1350: ! 1351: if (i != 0) { ! 1352: int j; ! 1353: char *cachedString; ! 1354: ! 1355: cachedString = iPtr->patterns[i]; ! 1356: result = iPtr->regexps[i]; ! 1357: for (j = i-1; j >= 0; j--) { ! 1358: iPtr->patterns[j+1] = iPtr->patterns[j]; ! 1359: iPtr->patLengths[j+1] = iPtr->patLengths[j]; ! 1360: iPtr->regexps[j+1] = iPtr->regexps[j]; ! 1361: } ! 1362: iPtr->patterns[0] = cachedString; ! 1363: iPtr->patLengths[0] = length; ! 1364: iPtr->regexps[0] = result; ! 1365: } ! 1366: return iPtr->regexps[0]; ! 1367: } ! 1368: } ! 1369: ! 1370: /* ! 1371: * No match in the cache. Compile the string and add it to the ! 1372: * cache. ! 1373: */ ! 1374: ! 1375: tclRegexpError = NULL; ! 1376: result = regcomp(string); ! 1377: if (tclRegexpError != NULL) { ! 1378: Tcl_AppendResult(interp, ! 1379: "couldn't compile regular expression pattern: ", ! 1380: tclRegexpError, (char *) NULL); ! 1381: return NULL; ! 1382: } ! 1383: if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { ! 1384: ckfree(iPtr->patterns[NUM_REGEXPS-1]); ! 1385: ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); ! 1386: } ! 1387: for (i = NUM_REGEXPS - 2; i >= 0; i--) { ! 1388: iPtr->patterns[i+1] = iPtr->patterns[i]; ! 1389: iPtr->patLengths[i+1] = iPtr->patLengths[i]; ! 1390: iPtr->regexps[i+1] = iPtr->regexps[i]; ! 1391: } ! 1392: iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); ! 1393: strcpy(iPtr->patterns[0], string); ! 1394: iPtr->patLengths[0] = length; ! 1395: iPtr->regexps[0] = result; ! 1396: return result; ! 1397: } ! 1398: ! 1399: /* ! 1400: *---------------------------------------------------------------------- ! 1401: * ! 1402: * regerror -- ! 1403: * ! 1404: * This procedure is invoked by the Henry Spencer's regexp code ! 1405: * when an error occurs. It saves the error message so it can ! 1406: * be seen by the code that called Spencer's code. ! 1407: * ! 1408: * Results: ! 1409: * None. ! 1410: * ! 1411: * Side effects: ! 1412: * The value of "string" is saved in "tclRegexpError". ! 1413: * ! 1414: *---------------------------------------------------------------------- ! 1415: */ ! 1416: ! 1417: void ! 1418: regerror(string) ! 1419: char *string; /* Error message. */ ! 1420: { ! 1421: tclRegexpError = string; ! 1422: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.