1/* 2 * tclUtil.c -- 3 * 4 * This file contains utility procedures that are used by many Tcl 5 * commands. 6 * 7 * Copyright (c) 1987-1993 The Regents of the University of California. 8 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 9 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. 10 * 11 * See the file "license.terms" for information on usage and redistribution 12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id: tclUtil.c,v 1.36.2.8 2007/05/10 18:23:58 dgp Exp $ 15 */ 16 17#include "tclInt.h" 18#include "tclPort.h" 19 20/* 21 * The following variable holds the full path name of the binary 22 * from which this application was executed, or NULL if it isn't 23 * know. The value of the variable is set by the procedure 24 * Tcl_FindExecutable. The storage space is dynamically allocated. 25 */ 26 27char *tclExecutableName = NULL; 28char *tclNativeExecutableName = NULL; 29 30/* 31 * The following values are used in the flags returned by Tcl_ScanElement 32 * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also 33 * defined in tcl.h; make sure its value doesn't overlap with any of the 34 * values below. 35 * 36 * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in 37 * braces (e.g. it contains unmatched braces, 38 * or ends in a backslash character, or user 39 * just doesn't want braces); handle all 40 * special characters by adding backslashes. 41 * USE_BRACES - 1 means the string contains a special 42 * character that can be handled simply by 43 * enclosing the entire argument in braces. 44 * BRACES_UNMATCHED - 1 means that braces aren't properly matched 45 * in the argument. 46 */ 47 48#define USE_BRACES 2 49#define BRACES_UNMATCHED 4 50 51/* 52 * The following values determine the precision used when converting 53 * floating-point values to strings. This information is linked to all 54 * of the tcl_precision variables in all interpreters via the procedure 55 * TclPrecTraceProc. 56 */ 57 58static char precisionString[10] = "12"; 59 /* The string value of all the tcl_precision 60 * variables. */ 61static char precisionFormat[10] = "%.12g"; 62 /* The format string actually used in calls 63 * to sprintf. */ 64TCL_DECLARE_MUTEX(precisionMutex) 65 66/* 67 * Prototypes for procedures defined later in this file. 68 */ 69 70static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); 71static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, 72 Tcl_Obj* objPtr)); 73 74/* 75 * The following is the Tcl object type definition for an object 76 * that represents a list index in the form, "end-offset". It is 77 * used as a performance optimization in TclGetIntForIndex. The 78 * internal rep is an integer, so no memory management is required 79 * for it. 80 */ 81 82Tcl_ObjType tclEndOffsetType = { 83 "end-offset", /* name */ 84 (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ 85 (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ 86 UpdateStringOfEndOffset, /* updateStringProc */ 87 SetEndOffsetFromAny 88}; 89 90 91/* 92 *---------------------------------------------------------------------- 93 * 94 * TclFindElement -- 95 * 96 * Given a pointer into a Tcl list, locate the first (or next) 97 * element in the list. 98 * 99 * Results: 100 * The return value is normally TCL_OK, which means that the 101 * element was successfully located. If TCL_ERROR is returned 102 * it means that list didn't have proper list structure; 103 * the interp's result contains a more detailed error message. 104 * 105 * If TCL_OK is returned, then *elementPtr will be set to point to the 106 * first element of list, and *nextPtr will be set to point to the 107 * character just after any white space following the last character 108 * that's part of the element. If this is the last argument in the 109 * list, then *nextPtr will point just after the last character in the 110 * list (i.e., at the character at list+listLength). If sizePtr is 111 * non-NULL, *sizePtr is filled in with the number of characters in the 112 * element. If the element is in braces, then *elementPtr will point 113 * to the character after the opening brace and *sizePtr will not 114 * include either of the braces. If there isn't an element in the list, 115 * *sizePtr will be zero, and both *elementPtr and *termPtr will point 116 * just after the last character in the list. Note: this procedure does 117 * NOT collapse backslash sequences. 118 * 119 * Side effects: 120 * None. 121 * 122 *---------------------------------------------------------------------- 123 */ 124 125int 126TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, 127 bracePtr) 128 Tcl_Interp *interp; /* Interpreter to use for error reporting. 129 * If NULL, then no error message is left 130 * after errors. */ 131 CONST char *list; /* Points to the first byte of a string 132 * containing a Tcl list with zero or more 133 * elements (possibly in braces). */ 134 int listLength; /* Number of bytes in the list's string. */ 135 CONST char **elementPtr; /* Where to put address of first significant 136 * character in first element of list. */ 137 CONST char **nextPtr; /* Fill in with location of character just 138 * after all white space following end of 139 * argument (next arg or end of list). */ 140 int *sizePtr; /* If non-zero, fill in with size of 141 * element. */ 142 int *bracePtr; /* If non-zero, fill in with non-zero/zero 143 * to indicate that arg was/wasn't 144 * in braces. */ 145{ 146 CONST char *p = list; 147 CONST char *elemStart; /* Points to first byte of first element. */ 148 CONST char *limit; /* Points just after list's last byte. */ 149 int openBraces = 0; /* Brace nesting level during parse. */ 150 int inQuotes = 0; 151 int size = 0; /* lint. */ 152 int numChars; 153 CONST char *p2; 154 155 /* 156 * Skim off leading white space and check for an opening brace or 157 * quote. We treat embedded NULLs in the list as bytes belonging to 158 * a list element. 159 */ 160 161 limit = (list + listLength); 162 while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ 163 p++; 164 } 165 if (p == limit) { /* no element found */ 166 elemStart = limit; 167 goto done; 168 } 169 170 if (*p == '{') { 171 openBraces = 1; 172 p++; 173 } else if (*p == '"') { 174 inQuotes = 1; 175 p++; 176 } 177 elemStart = p; 178 if (bracePtr != 0) { 179 *bracePtr = openBraces; 180 } 181 182 /* 183 * Find element's end (a space, close brace, or the end of the string). 184 */ 185 186 while (p < limit) { 187 switch (*p) { 188 189 /* 190 * Open brace: don't treat specially unless the element is in 191 * braces. In this case, keep a nesting count. 192 */ 193 194 case '{': 195 if (openBraces != 0) { 196 openBraces++; 197 } 198 break; 199 200 /* 201 * Close brace: if element is in braces, keep nesting count and 202 * quit when the last close brace is seen. 203 */ 204 205 case '}': 206 if (openBraces > 1) { 207 openBraces--; 208 } else if (openBraces == 1) { 209 size = (p - elemStart); 210 p++; 211 if ((p >= limit) 212 || isspace(UCHAR(*p))) { /* INTL: ISO space. */ 213 goto done; 214 } 215 216 /* 217 * Garbage after the closing brace; return an error. 218 */ 219 220 if (interp != NULL) { 221 char buf[100]; 222 223 p2 = p; 224 while ((p2 < limit) 225 && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ 226 && (p2 < p+20)) { 227 p2++; 228 } 229 sprintf(buf, 230 "list element in braces followed by \"%.*s\" instead of space", 231 (int) (p2-p), p); 232 Tcl_SetResult(interp, buf, TCL_VOLATILE); 233 } 234 return TCL_ERROR; 235 } 236 break; 237 238 /* 239 * Backslash: skip over everything up to the end of the 240 * backslash sequence. 241 */ 242 243 case '\\': { 244 Tcl_UtfBackslash(p, &numChars, NULL); 245 p += (numChars - 1); 246 break; 247 } 248 249 /* 250 * Space: ignore if element is in braces or quotes; otherwise 251 * terminate element. 252 */ 253 254 case ' ': 255 case '\f': 256 case '\n': 257 case '\r': 258 case '\t': 259 case '\v': 260 if ((openBraces == 0) && !inQuotes) { 261 size = (p - elemStart); 262 goto done; 263 } 264 break; 265 266 /* 267 * Double-quote: if element is in quotes then terminate it. 268 */ 269 270 case '"': 271 if (inQuotes) { 272 size = (p - elemStart); 273 p++; 274 if ((p >= limit) 275 || isspace(UCHAR(*p))) { /* INTL: ISO space */ 276 goto done; 277 } 278 279 /* 280 * Garbage after the closing quote; return an error. 281 */ 282 283 if (interp != NULL) { 284 char buf[100]; 285 286 p2 = p; 287 while ((p2 < limit) 288 && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ 289 && (p2 < p+20)) { 290 p2++; 291 } 292 sprintf(buf, 293 "list element in quotes followed by \"%.*s\" %s", 294 (int) (p2-p), p, "instead of space"); 295 Tcl_SetResult(interp, buf, TCL_VOLATILE); 296 } 297 return TCL_ERROR; 298 } 299 break; 300 } 301 p++; 302 } 303 304 305 /* 306 * End of list: terminate element. 307 */ 308 309 if (p == limit) { 310 if (openBraces != 0) { 311 if (interp != NULL) { 312 Tcl_SetResult(interp, "unmatched open brace in list", 313 TCL_STATIC); 314 } 315 return TCL_ERROR; 316 } else if (inQuotes) { 317 if (interp != NULL) { 318 Tcl_SetResult(interp, "unmatched open quote in list", 319 TCL_STATIC); 320 } 321 return TCL_ERROR; 322 } 323 size = (p - elemStart); 324 } 325 326 done: 327 while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ 328 p++; 329 } 330 *elementPtr = elemStart; 331 *nextPtr = p; 332 if (sizePtr != 0) { 333 *sizePtr = size; 334 } 335 return TCL_OK; 336} 337 338/* 339 *---------------------------------------------------------------------- 340 * 341 * TclCopyAndCollapse -- 342 * 343 * Copy a string and eliminate any backslashes that aren't in braces. 344 * 345 * Results: 346 * Count characters get copied from src to dst. Along the way, if 347 * backslash sequences are found outside braces, the backslashes are 348 * eliminated in the copy. After scanning count chars from source, a 349 * null character is placed at the end of dst. Returns the number 350 * of characters that got copied. 351 * 352 * Side effects: 353 * None. 354 * 355 *---------------------------------------------------------------------- 356 */ 357 358int 359TclCopyAndCollapse(count, src, dst) 360 int count; /* Number of characters to copy from src. */ 361 CONST char *src; /* Copy from here... */ 362 char *dst; /* ... to here. */ 363{ 364 register char c; 365 int numRead; 366 int newCount = 0; 367 int backslashCount; 368 369 for (c = *src; count > 0; src++, c = *src, count--) { 370 if (c == '\\') { 371 backslashCount = Tcl_UtfBackslash(src, &numRead, dst); 372 dst += backslashCount; 373 newCount += backslashCount; 374 src += numRead-1; 375 count -= numRead-1; 376 } else { 377 *dst = c; 378 dst++; 379 newCount++; 380 } 381 } 382 *dst = 0; 383 return newCount; 384} 385 386/* 387 *---------------------------------------------------------------------- 388 * 389 * Tcl_SplitList -- 390 * 391 * Splits a list up into its constituent fields. 392 * 393 * Results 394 * The return value is normally TCL_OK, which means that 395 * the list was successfully split up. If TCL_ERROR is 396 * returned, it means that "list" didn't have proper list 397 * structure; the interp's result will contain a more detailed 398 * error message. 399 * 400 * *argvPtr will be filled in with the address of an array 401 * whose elements point to the elements of list, in order. 402 * *argcPtr will get filled in with the number of valid elements 403 * in the array. A single block of memory is dynamically allocated 404 * to hold both the argv array and a copy of the list (with 405 * backslashes and braces removed in the standard way). 406 * The caller must eventually free this memory by calling free() 407 * on *argvPtr. Note: *argvPtr and *argcPtr are only modified 408 * if the procedure returns normally. 409 * 410 * Side effects: 411 * Memory is allocated. 412 * 413 *---------------------------------------------------------------------- 414 */ 415 416int 417Tcl_SplitList(interp, list, argcPtr, argvPtr) 418 Tcl_Interp *interp; /* Interpreter to use for error reporting. 419 * If NULL, no error message is left. */ 420 CONST char *list; /* Pointer to string with list structure. */ 421 int *argcPtr; /* Pointer to location to fill in with 422 * the number of elements in the list. */ 423 CONST char ***argvPtr; /* Pointer to place to store pointer to 424 * array of pointers to list elements. */ 425{ 426 CONST char **argv; 427 CONST char *l; 428 char *p; 429 int length, size, i, result, elSize, brace; 430 CONST char *element; 431 432 /* 433 * Figure out how much space to allocate. There must be enough 434 * space for both the array of pointers and also for a copy of 435 * the list. To estimate the number of pointers needed, count 436 * the number of space characters in the list. 437 */ 438 439 for (size = 2, l = list; *l != 0; l++) { 440 if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ 441 size++; 442 /* Consecutive space can only count as a single list delimiter */ 443 while (1) { 444 char next = *(l + 1); 445 if (next == '\0') { 446 break; 447 } 448 ++l; 449 if (isspace(UCHAR(next))) { 450 continue; 451 } 452 break; 453 } 454 } 455 } 456 length = l - list; 457 argv = (CONST char **) ckalloc((unsigned) 458 ((size * sizeof(char *)) + length + 1)); 459 for (i = 0, p = ((char *) argv) + size*sizeof(char *); 460 *list != 0; i++) { 461 CONST char *prevList = list; 462 463 result = TclFindElement(interp, list, length, &element, 464 &list, &elSize, &brace); 465 length -= (list - prevList); 466 if (result != TCL_OK) { 467 ckfree((char *) argv); 468 return result; 469 } 470 if (*element == 0) { 471 break; 472 } 473 if (i >= size) { 474 ckfree((char *) argv); 475 if (interp != NULL) { 476 Tcl_SetResult(interp, "internal error in Tcl_SplitList", 477 TCL_STATIC); 478 } 479 return TCL_ERROR; 480 } 481 argv[i] = p; 482 if (brace) { 483 memcpy((VOID *) p, (VOID *) element, (size_t) elSize); 484 p += elSize; 485 *p = 0; 486 p++; 487 } else { 488 TclCopyAndCollapse(elSize, element, p); 489 p += elSize+1; 490 } 491 } 492 493 argv[i] = NULL; 494 *argvPtr = argv; 495 *argcPtr = i; 496 return TCL_OK; 497} 498 499/* 500 *---------------------------------------------------------------------- 501 * 502 * Tcl_ScanElement -- 503 * 504 * This procedure is a companion procedure to Tcl_ConvertElement. 505 * It scans a string to see what needs to be done to it (e.g. add 506 * backslashes or enclosing braces) to make the string into a 507 * valid Tcl list element. 508 * 509 * Results: 510 * The return value is an overestimate of the number of characters 511 * that will be needed by Tcl_ConvertElement to produce a valid 512 * list element from string. The word at *flagPtr is filled in 513 * with a value needed by Tcl_ConvertElement when doing the actual 514 * conversion. 515 * 516 * Side effects: 517 * None. 518 * 519 *---------------------------------------------------------------------- 520 */ 521 522int 523Tcl_ScanElement(string, flagPtr) 524 register CONST char *string; /* String to convert to list element. */ 525 register int *flagPtr; /* Where to store information to guide 526 * Tcl_ConvertCountedElement. */ 527{ 528 return Tcl_ScanCountedElement(string, -1, flagPtr); 529} 530 531/* 532 *---------------------------------------------------------------------- 533 * 534 * Tcl_ScanCountedElement -- 535 * 536 * This procedure is a companion procedure to 537 * Tcl_ConvertCountedElement. It scans a string to see what 538 * needs to be done to it (e.g. add backslashes or enclosing 539 * braces) to make the string into a valid Tcl list element. 540 * If length is -1, then the string is scanned up to the first 541 * null byte. 542 * 543 * Results: 544 * The return value is an overestimate of the number of characters 545 * that will be needed by Tcl_ConvertCountedElement to produce a 546 * valid list element from string. The word at *flagPtr is 547 * filled in with a value needed by Tcl_ConvertCountedElement 548 * when doing the actual conversion. 549 * 550 * Side effects: 551 * None. 552 * 553 *---------------------------------------------------------------------- 554 */ 555 556int 557Tcl_ScanCountedElement(string, length, flagPtr) 558 CONST char *string; /* String to convert to Tcl list element. */ 559 int length; /* Number of bytes in string, or -1. */ 560 int *flagPtr; /* Where to store information to guide 561 * Tcl_ConvertElement. */ 562{ 563 int flags, nestingLevel; 564 register CONST char *p, *lastChar; 565 566 /* 567 * This procedure and Tcl_ConvertElement together do two things: 568 * 569 * 1. They produce a proper list, one that will yield back the 570 * argument strings when evaluated or when disassembled with 571 * Tcl_SplitList. This is the most important thing. 572 * 573 * 2. They try to produce legible output, which means minimizing the 574 * use of backslashes (using braces instead). However, there are 575 * some situations where backslashes must be used (e.g. an element 576 * like "{abc": the leading brace will have to be backslashed. 577 * For each element, one of three things must be done: 578 * 579 * (a) Use the element as-is (it doesn't contain any special 580 * characters). This is the most desirable option. 581 * 582 * (b) Enclose the element in braces, but leave the contents alone. 583 * This happens if the element contains embedded space, or if it 584 * contains characters with special interpretation ($, [, ;, or \), 585 * or if it starts with a brace or double-quote, or if there are 586 * no characters in the element. 587 * 588 * (c) Don't enclose the element in braces, but add backslashes to 589 * prevent special interpretation of special characters. This is a 590 * last resort used when the argument would normally fall under case 591 * (b) but contains unmatched braces. It also occurs if the last 592 * character of the argument is a backslash or if the element contains 593 * a backslash followed by newline. 594 * 595 * The procedure figures out how many bytes will be needed to store 596 * the result (actually, it overestimates). It also collects information 597 * about the element in the form of a flags word. 598 * 599 * Note: list elements produced by this procedure and 600 * Tcl_ConvertCountedElement must have the property that they can be 601 * enclosing in curly braces to make sub-lists. This means, for 602 * example, that we must not leave unmatched curly braces in the 603 * resulting list element. This property is necessary in order for 604 * procedures like Tcl_DStringStartSublist to work. 605 */ 606 607 nestingLevel = 0; 608 flags = 0; 609 if (string == NULL) { 610 string = ""; 611 } 612 if (length == -1) { 613 length = strlen(string); 614 } 615 lastChar = string + length; 616 p = string; 617 if ((p == lastChar) || (*p == '{') || (*p == '"')) { 618 flags |= USE_BRACES; 619 } 620 for ( ; p < lastChar; p++) { 621 switch (*p) { 622 case '{': 623 nestingLevel++; 624 break; 625 case '}': 626 nestingLevel--; 627 if (nestingLevel < 0) { 628 flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; 629 } 630 break; 631 case '[': 632 case '$': 633 case ';': 634 case ' ': 635 case '\f': 636 case '\n': 637 case '\r': 638 case '\t': 639 case '\v': 640 flags |= USE_BRACES; 641 break; 642 case '\\': 643 if ((p+1 == lastChar) || (p[1] == '\n')) { 644 flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; 645 } else { 646 int size; 647 648 Tcl_UtfBackslash(p, &size, NULL); 649 p += size-1; 650 flags |= USE_BRACES; 651 } 652 break; 653 } 654 } 655 if (nestingLevel != 0) { 656 flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; 657 } 658 *flagPtr = flags; 659 660 /* 661 * Allow enough space to backslash every character plus leave 662 * two spaces for braces. 663 */ 664 665 return 2*(p-string) + 2; 666} 667 668/* 669 *---------------------------------------------------------------------- 670 * 671 * Tcl_ConvertElement -- 672 * 673 * This is a companion procedure to Tcl_ScanElement. Given 674 * the information produced by Tcl_ScanElement, this procedure 675 * converts a string to a list element equal to that string. 676 * 677 * Results: 678 * Information is copied to *dst in the form of a list element 679 * identical to src (i.e. if Tcl_SplitList is applied to dst it 680 * will produce a string identical to src). The return value is 681 * a count of the number of characters copied (not including the 682 * terminating NULL character). 683 * 684 * Side effects: 685 * None. 686 * 687 *---------------------------------------------------------------------- 688 */ 689 690int 691Tcl_ConvertElement(src, dst, flags) 692 register CONST char *src; /* Source information for list element. */ 693 register char *dst; /* Place to put list-ified element. */ 694 register int flags; /* Flags produced by Tcl_ScanElement. */ 695{ 696 return Tcl_ConvertCountedElement(src, -1, dst, flags); 697} 698 699/* 700 *---------------------------------------------------------------------- 701 * 702 * Tcl_ConvertCountedElement -- 703 * 704 * This is a companion procedure to Tcl_ScanCountedElement. Given 705 * the information produced by Tcl_ScanCountedElement, this 706 * procedure converts a string to a list element equal to that 707 * string. 708 * 709 * Results: 710 * Information is copied to *dst in the form of a list element 711 * identical to src (i.e. if Tcl_SplitList is applied to dst it 712 * will produce a string identical to src). The return value is 713 * a count of the number of characters copied (not including the 714 * terminating NULL character). 715 * 716 * Side effects: 717 * None. 718 * 719 *---------------------------------------------------------------------- 720 */ 721 722int 723Tcl_ConvertCountedElement(src, length, dst, flags) 724 register CONST char *src; /* Source information for list element. */ 725 int length; /* Number of bytes in src, or -1. */ 726 char *dst; /* Place to put list-ified element. */ 727 int flags; /* Flags produced by Tcl_ScanElement. */ 728{ 729 register char *p = dst; 730 register CONST char *lastChar; 731 732 /* 733 * See the comment block at the beginning of the Tcl_ScanElement 734 * code for details of how this works. 735 */ 736 737 if (src && length == -1) { 738 length = strlen(src); 739 } 740 if ((src == NULL) || (length == 0)) { 741 p[0] = '{'; 742 p[1] = '}'; 743 p[2] = 0; 744 return 2; 745 } 746 lastChar = src + length; 747 if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { 748 *p = '{'; 749 p++; 750 for ( ; src != lastChar; src++, p++) { 751 *p = *src; 752 } 753 *p = '}'; 754 p++; 755 } else { 756 if (*src == '{') { 757 /* 758 * Can't have a leading brace unless the whole element is 759 * enclosed in braces. Add a backslash before the brace. 760 * Furthermore, this may destroy the balance between open 761 * and close braces, so set BRACES_UNMATCHED. 762 */ 763 764 p[0] = '\\'; 765 p[1] = '{'; 766 p += 2; 767 src++; 768 flags |= BRACES_UNMATCHED; 769 } 770 for (; src != lastChar; src++) { 771 switch (*src) { 772 case ']': 773 case '[': 774 case '$': 775 case ';': 776 case ' ': 777 case '\\': 778 case '"': 779 *p = '\\'; 780 p++; 781 break; 782 case '{': 783 case '}': 784 /* 785 * It may not seem necessary to backslash braces, but 786 * it is. The reason for this is that the resulting 787 * list element may actually be an element of a sub-list 788 * enclosed in braces (e.g. if Tcl_DStringStartSublist 789 * has been invoked), so there may be a brace mismatch 790 * if the braces aren't backslashed. 791 */ 792 793 if (flags & BRACES_UNMATCHED) { 794 *p = '\\'; 795 p++; 796 } 797 break; 798 case '\f': 799 *p = '\\'; 800 p++; 801 *p = 'f'; 802 p++; 803 continue; 804 case '\n': 805 *p = '\\'; 806 p++; 807 *p = 'n'; 808 p++; 809 continue; 810 case '\r': 811 *p = '\\'; 812 p++; 813 *p = 'r'; 814 p++; 815 continue; 816 case '\t': 817 *p = '\\'; 818 p++; 819 *p = 't'; 820 p++; 821 continue; 822 case '\v': 823 *p = '\\'; 824 p++; 825 *p = 'v'; 826 p++; 827 continue; 828 } 829 *p = *src; 830 p++; 831 } 832 } 833 *p = '\0'; 834 return p-dst; 835} 836 837/* 838 *---------------------------------------------------------------------- 839 * 840 * Tcl_Merge -- 841 * 842 * Given a collection of strings, merge them together into a 843 * single string that has proper Tcl list structured (i.e. 844 * Tcl_SplitList may be used to retrieve strings equal to the 845 * original elements, and Tcl_Eval will parse the string back 846 * into its original elements). 847 * 848 * Results: 849 * The return value is the address of a dynamically-allocated 850 * string containing the merged list. 851 * 852 * Side effects: 853 * None. 854 * 855 *---------------------------------------------------------------------- 856 */ 857 858char * 859Tcl_Merge(argc, argv) 860 int argc; /* How many strings to merge. */ 861 CONST char * CONST *argv; /* Array of string values. */ 862{ 863# define LOCAL_SIZE 20 864 int localFlags[LOCAL_SIZE], *flagPtr; 865 int numChars; 866 char *result; 867 char *dst; 868 int i; 869 870 /* 871 * Pass 1: estimate space, gather flags. 872 */ 873 874 if (argc <= LOCAL_SIZE) { 875 flagPtr = localFlags; 876 } else { 877 flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); 878 } 879 numChars = 1; 880 for (i = 0; i < argc; i++) { 881 numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; 882 } 883 884 /* 885 * Pass two: copy into the result area. 886 */ 887 888 result = (char *) ckalloc((unsigned) numChars); 889 dst = result; 890 for (i = 0; i < argc; i++) { 891 numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); 892 dst += numChars; 893 *dst = ' '; 894 dst++; 895 } 896 if (dst == result) { 897 *dst = 0; 898 } else { 899 dst[-1] = 0; 900 } 901 902 if (flagPtr != localFlags) { 903 ckfree((char *) flagPtr); 904 } 905 return result; 906} 907 908/* 909 *---------------------------------------------------------------------- 910 * 911 * Tcl_Backslash -- 912 * 913 * Figure out how to handle a backslash sequence. 914 * 915 * Results: 916 * The return value is the character that should be substituted 917 * in place of the backslash sequence that starts at src. If 918 * readPtr isn't NULL then it is filled in with a count of the 919 * number of characters in the backslash sequence. 920 * 921 * Side effects: 922 * None. 923 * 924 *---------------------------------------------------------------------- 925 */ 926 927char 928Tcl_Backslash(src, readPtr) 929 CONST char *src; /* Points to the backslash character of 930 * a backslash sequence. */ 931 int *readPtr; /* Fill in with number of characters read 932 * from src, unless NULL. */ 933{ 934 char buf[TCL_UTF_MAX]; 935 Tcl_UniChar ch; 936 937 Tcl_UtfBackslash(src, readPtr, buf); 938 TclUtfToUniChar(buf, &ch); 939 return (char) ch; 940} 941 942/* 943 *---------------------------------------------------------------------- 944 * 945 * Tcl_Concat -- 946 * 947 * Concatenate a set of strings into a single large string. 948 * 949 * Results: 950 * The return value is dynamically-allocated string containing 951 * a concatenation of all the strings in argv, with spaces between 952 * the original argv elements. 953 * 954 * Side effects: 955 * Memory is allocated for the result; the caller is responsible 956 * for freeing the memory. 957 * 958 *---------------------------------------------------------------------- 959 */ 960 961char * 962Tcl_Concat(argc, argv) 963 int argc; /* Number of strings to concatenate. */ 964 CONST char * CONST *argv; /* Array of strings to concatenate. */ 965{ 966 int totalSize, i; 967 char *p; 968 char *result; 969 970 for (totalSize = 1, i = 0; i < argc; i++) { 971 totalSize += strlen(argv[i]) + 1; 972 } 973 result = (char *) ckalloc((unsigned) totalSize); 974 if (argc == 0) { 975 *result = '\0'; 976 return result; 977 } 978 for (p = result, i = 0; i < argc; i++) { 979 CONST char *element; 980 int length; 981 982 /* 983 * Clip white space off the front and back of the string 984 * to generate a neater result, and ignore any empty 985 * elements. 986 */ 987 988 element = argv[i]; 989 while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ 990 element++; 991 } 992 for (length = strlen(element); 993 (length > 0) 994 && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ 995 && ((length < 2) || (element[length-2] != '\\')); 996 length--) { 997 /* Null loop body. */ 998 } 999 if (length == 0) { 1000 continue; 1001 } 1002 memcpy((VOID *) p, (VOID *) element, (size_t) length); 1003 p += length; 1004 *p = ' '; 1005 p++; 1006 } 1007 if (p != result) { 1008 p[-1] = 0; 1009 } else { 1010 *p = 0; 1011 } 1012 return result; 1013} 1014 1015/* 1016 *---------------------------------------------------------------------- 1017 * 1018 * Tcl_ConcatObj -- 1019 * 1020 * Concatenate the strings from a set of objects into a single string 1021 * object with spaces between the original strings. 1022 * 1023 * Results: 1024 * The return value is a new string object containing a concatenation 1025 * of the strings in objv. Its ref count is zero. 1026 * 1027 * Side effects: 1028 * A new object is created. 1029 * 1030 *---------------------------------------------------------------------- 1031 */ 1032 1033Tcl_Obj * 1034Tcl_ConcatObj(objc, objv) 1035 int objc; /* Number of objects to concatenate. */ 1036 Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ 1037{ 1038 int allocSize, finalSize, length, elemLength, i; 1039 char *p; 1040 char *element; 1041 char *concatStr; 1042 Tcl_Obj *objPtr; 1043 1044 /* 1045 * Check first to see if all the items are of list type. If so, 1046 * we will concat them together as lists, and return a list object. 1047 * This is only valid when the lists have no current string 1048 * representation, since we don't know what the original type was. 1049 * An original string rep may have lost some whitespace info when 1050 * converted which could be important. 1051 */ 1052 for (i = 0; i < objc; i++) { 1053 objPtr = objv[i]; 1054 if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { 1055 break; 1056 } 1057 } 1058 if (i == objc) { 1059 Tcl_Obj **listv; 1060 int listc; 1061 1062 objPtr = Tcl_NewListObj(0, NULL); 1063 for (i = 0; i < objc; i++) { 1064 /* 1065 * Tcl_ListObjAppendList could be used here, but this saves 1066 * us a bit of type checking (since we've already done it) 1067 * Use of INT_MAX tells us to always put the new stuff on 1068 * the end. It will be set right in Tcl_ListObjReplace. 1069 */ 1070 Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); 1071 Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); 1072 } 1073 return objPtr; 1074 } 1075 1076 allocSize = 0; 1077 for (i = 0; i < objc; i++) { 1078 objPtr = objv[i]; 1079 element = Tcl_GetStringFromObj(objPtr, &length); 1080 if ((element != NULL) && (length > 0)) { 1081 allocSize += (length + 1); 1082 } 1083 } 1084 if (allocSize == 0) { 1085 allocSize = 1; /* enough for the NULL byte at end */ 1086 } 1087 1088 /* 1089 * Allocate storage for the concatenated result. Note that allocSize 1090 * is one more than the total number of characters, and so includes 1091 * room for the terminating NULL byte. 1092 */ 1093 1094 concatStr = (char *) ckalloc((unsigned) allocSize); 1095 1096 /* 1097 * Now concatenate the elements. Clip white space off the front and back 1098 * to generate a neater result, and ignore any empty elements. Also put 1099 * a null byte at the end. 1100 */ 1101 1102 finalSize = 0; 1103 if (objc == 0) { 1104 *concatStr = '\0'; 1105 } else { 1106 p = concatStr; 1107 for (i = 0; i < objc; i++) { 1108 objPtr = objv[i]; 1109 element = Tcl_GetStringFromObj(objPtr, &elemLength); 1110 while ((elemLength > 0) && (UCHAR(*element) < 127) 1111 && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ 1112 element++; 1113 elemLength--; 1114 } 1115 1116 /* 1117 * Trim trailing white space. But, be careful not to trim 1118 * a space character if it is preceded by a backslash: in 1119 * this case it could be significant. 1120 */ 1121 1122 while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) 1123 && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */ 1124 && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { 1125 elemLength--; 1126 } 1127 if (elemLength == 0) { 1128 continue; /* nothing left of this element */ 1129 } 1130 memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); 1131 p += elemLength; 1132 *p = ' '; 1133 p++; 1134 finalSize += (elemLength + 1); 1135 } 1136 if (p != concatStr) { 1137 p[-1] = 0; 1138 finalSize -= 1; /* we overwrote the final ' ' */ 1139 } else { 1140 *p = 0; 1141 } 1142 } 1143 1144 TclNewObj(objPtr); 1145 objPtr->bytes = concatStr; 1146 objPtr->length = finalSize; 1147 return objPtr; 1148} 1149 1150/* 1151 *---------------------------------------------------------------------- 1152 * 1153 * Tcl_StringMatch -- 1154 * 1155 * See if a particular string matches a particular pattern. 1156 * 1157 * Results: 1158 * The return value is 1 if string matches pattern, and 1159 * 0 otherwise. The matching operation permits the following 1160 * special characters in the pattern: *?\[] (see the manual 1161 * entry for details on what these mean). 1162 * 1163 * Side effects: 1164 * None. 1165 * 1166 *---------------------------------------------------------------------- 1167 */ 1168 1169int 1170Tcl_StringMatch(string, pattern) 1171 CONST char *string; /* String. */ 1172 CONST char *pattern; /* Pattern, which may contain special 1173 * characters. */ 1174{ 1175 return Tcl_StringCaseMatch(string, pattern, 0); 1176} 1177 1178/* 1179 *---------------------------------------------------------------------- 1180 * 1181 * Tcl_StringCaseMatch -- 1182 * 1183 * See if a particular string matches a particular pattern. 1184 * Allows case insensitivity. 1185 * 1186 * Results: 1187 * The return value is 1 if string matches pattern, and 1188 * 0 otherwise. The matching operation permits the following 1189 * special characters in the pattern: *?\[] (see the manual 1190 * entry for details on what these mean). 1191 * 1192 * Side effects: 1193 * None. 1194 * 1195 *---------------------------------------------------------------------- 1196 */ 1197 1198int 1199Tcl_StringCaseMatch(string, pattern, nocase) 1200 CONST char *string; /* String. */ 1201 CONST char *pattern; /* Pattern, which may contain special 1202 * characters. */ 1203 int nocase; /* 0 for case sensitive, 1 for insensitive */ 1204{ 1205 int p, charLen; 1206 CONST char *pstart = pattern; 1207 Tcl_UniChar ch1, ch2; 1208 1209 while (1) { 1210 p = *pattern; 1211 1212 /* 1213 * See if we're at the end of both the pattern and the string. If 1214 * so, we succeeded. If we're at the end of the pattern but not at 1215 * the end of the string, we failed. 1216 */ 1217 1218 if (p == '\0') { 1219 return (*string == '\0'); 1220 } 1221 if ((*string == '\0') && (p != '*')) { 1222 return 0; 1223 } 1224 1225 /* 1226 * Check for a "*" as the next pattern character. It matches 1227 * any substring. We handle this by calling ourselves 1228 * recursively for each postfix of string, until either we 1229 * match or we reach the end of the string. 1230 */ 1231 1232 if (p == '*') { 1233 /* 1234 * Skip all successive *'s in the pattern 1235 */ 1236 while (*(++pattern) == '*') {} 1237 p = *pattern; 1238 if (p == '\0') { 1239 return 1; 1240 } 1241 /* 1242 * This is a special case optimization for single-byte utf. 1243 */ 1244 if (UCHAR(*pattern) < 0x80) { 1245 ch2 = (Tcl_UniChar) 1246 (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); 1247 } else { 1248 Tcl_UtfToUniChar(pattern, &ch2); 1249 if (nocase) { 1250 ch2 = Tcl_UniCharToLower(ch2); 1251 } 1252 } 1253 while (1) { 1254 /* 1255 * Optimization for matching - cruise through the string 1256 * quickly if the next char in the pattern isn't a special 1257 * character 1258 */ 1259 if ((p != '[') && (p != '?') && (p != '\\')) { 1260 if (nocase) { 1261 while (*string) { 1262 charLen = TclUtfToUniChar(string, &ch1); 1263 if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { 1264 break; 1265 } 1266 string += charLen; 1267 } 1268 } else { 1269 /* 1270 * There's no point in trying to make this code 1271 * shorter, as the number of bytes you want to 1272 * compare each time is non-constant. 1273 */ 1274 while (*string) { 1275 charLen = TclUtfToUniChar(string, &ch1); 1276 if (ch2 == ch1) { 1277 break; 1278 } 1279 string += charLen; 1280 } 1281 } 1282 } 1283 if (Tcl_StringCaseMatch(string, pattern, nocase)) { 1284 return 1; 1285 } 1286 if (*string == '\0') { 1287 return 0; 1288 } 1289 string += TclUtfToUniChar(string, &ch1); 1290 } 1291 } 1292 1293 /* 1294 * Check for a "?" as the next pattern character. It matches 1295 * any single character. 1296 */ 1297 1298 if (p == '?') { 1299 pattern++; 1300 string += TclUtfToUniChar(string, &ch1); 1301 continue; 1302 } 1303 1304 /* 1305 * Check for a "[" as the next pattern character. It is followed 1306 * by a list of characters that are acceptable, or by a range 1307 * (two characters separated by "-"). 1308 */ 1309 1310 if (p == '[') { 1311 Tcl_UniChar startChar, endChar; 1312 1313 pattern++; 1314 if (UCHAR(*string) < 0x80) { 1315 ch1 = (Tcl_UniChar) 1316 (nocase ? tolower(UCHAR(*string)) : UCHAR(*string)); 1317 string++; 1318 } else { 1319 string += Tcl_UtfToUniChar(string, &ch1); 1320 if (nocase) { 1321 ch1 = Tcl_UniCharToLower(ch1); 1322 } 1323 } 1324 while (1) { 1325 if ((*pattern == ']') || (*pattern == '\0')) { 1326 return 0; 1327 } 1328 if (UCHAR(*pattern) < 0x80) { 1329 startChar = (Tcl_UniChar) 1330 (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); 1331 pattern++; 1332 } else { 1333 pattern += Tcl_UtfToUniChar(pattern, &startChar); 1334 if (nocase) { 1335 startChar = Tcl_UniCharToLower(startChar); 1336 } 1337 } 1338 if (*pattern == '-') { 1339 pattern++; 1340 if (*pattern == '\0') { 1341 return 0; 1342 } 1343 if (UCHAR(*pattern) < 0x80) { 1344 endChar = (Tcl_UniChar) 1345 (nocase ? tolower(UCHAR(*pattern)) 1346 : UCHAR(*pattern)); 1347 pattern++; 1348 } else { 1349 pattern += Tcl_UtfToUniChar(pattern, &endChar); 1350 if (nocase) { 1351 endChar = Tcl_UniCharToLower(endChar); 1352 } 1353 } 1354 if (((startChar <= ch1) && (ch1 <= endChar)) 1355 || ((endChar <= ch1) && (ch1 <= startChar))) { 1356 /* 1357 * Matches ranges of form [a-z] or [z-a]. 1358 */ 1359 1360 break; 1361 } 1362 } else if (startChar == ch1) { 1363 break; 1364 } 1365 } 1366 while (*pattern != ']') { 1367 if (*pattern == '\0') { 1368 pattern = Tcl_UtfPrev(pattern, pstart); 1369 break; 1370 } 1371 pattern++; 1372 } 1373 pattern++; 1374 continue; 1375 } 1376 1377 /* 1378 * If the next pattern character is '\', just strip off the '\' 1379 * so we do exact matching on the character that follows. 1380 */ 1381 1382 if (p == '\\') { 1383 pattern++; 1384 if (*pattern == '\0') { 1385 return 0; 1386 } 1387 } 1388 1389 /* 1390 * There's no special character. Just make sure that the next 1391 * bytes of each string match. 1392 */ 1393 1394 string += TclUtfToUniChar(string, &ch1); 1395 pattern += TclUtfToUniChar(pattern, &ch2); 1396 if (nocase) { 1397 if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { 1398 return 0; 1399 } 1400 } else if (ch1 != ch2) { 1401 return 0; 1402 } 1403 } 1404} 1405 1406/* 1407 *---------------------------------------------------------------------- 1408 * 1409 * TclMatchIsTrivial -- 1410 * 1411 * Test whether a particular glob pattern is a trivial pattern. 1412 * (i.e. where matching is the same as equality testing). 1413 * 1414 * Results: 1415 * A boolean indicating whether the pattern is free of all of the 1416 * glob special chars. 1417 * 1418 * Side effects: 1419 * None. 1420 * 1421 *---------------------------------------------------------------------- 1422 */ 1423 1424int 1425TclMatchIsTrivial(pattern) 1426 CONST char *pattern; 1427{ 1428 CONST char *p = pattern; 1429 1430 while (1) { 1431 switch (*p++) { 1432 case '\0': 1433 return 1; 1434 case '*': 1435 case '?': 1436 case '[': 1437 case '\\': 1438 return 0; 1439 } 1440 } 1441} 1442 1443/* 1444 *---------------------------------------------------------------------- 1445 * 1446 * Tcl_DStringInit -- 1447 * 1448 * Initializes a dynamic string, discarding any previous contents 1449 * of the string (Tcl_DStringFree should have been called already 1450 * if the dynamic string was previously in use). 1451 * 1452 * Results: 1453 * None. 1454 * 1455 * Side effects: 1456 * The dynamic string is initialized to be empty. 1457 * 1458 *---------------------------------------------------------------------- 1459 */ 1460 1461void 1462Tcl_DStringInit(dsPtr) 1463 Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */ 1464{ 1465 dsPtr->string = dsPtr->staticSpace; 1466 dsPtr->length = 0; 1467 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 1468 dsPtr->staticSpace[0] = '\0'; 1469} 1470 1471/* 1472 *---------------------------------------------------------------------- 1473 * 1474 * Tcl_DStringAppend -- 1475 * 1476 * Append more characters to the current value of a dynamic string. 1477 * 1478 * Results: 1479 * The return value is a pointer to the dynamic string's new value. 1480 * 1481 * Side effects: 1482 * Length bytes from string (or all of string if length is less 1483 * than zero) are added to the current value of the string. Memory 1484 * gets reallocated if needed to accomodate the string's new size. 1485 * 1486 *---------------------------------------------------------------------- 1487 */ 1488 1489char * 1490Tcl_DStringAppend(dsPtr, string, length) 1491 Tcl_DString *dsPtr; /* Structure describing dynamic string. */ 1492 CONST char *string; /* String to append. If length is -1 then 1493 * this must be null-terminated. */ 1494 int length; /* Number of characters from string to 1495 * append. If < 0, then append all of string, 1496 * up to null at end. */ 1497{ 1498 int newSize; 1499 char *dst; 1500 CONST char *end; 1501 1502 if (length < 0) { 1503 length = strlen(string); 1504 } 1505 newSize = length + dsPtr->length; 1506 1507 /* 1508 * Allocate a larger buffer for the string if the current one isn't 1509 * large enough. Allocate extra space in the new buffer so that there 1510 * will be room to grow before we have to allocate again. 1511 */ 1512 1513 if (newSize >= dsPtr->spaceAvl) { 1514 dsPtr->spaceAvl = newSize * 2; 1515 if (dsPtr->string == dsPtr->staticSpace) { 1516 char *newString; 1517 1518 newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); 1519 memcpy((VOID *) newString, (VOID *) dsPtr->string, 1520 (size_t) dsPtr->length); 1521 dsPtr->string = newString; 1522 } else { 1523 dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, 1524 (size_t) dsPtr->spaceAvl); 1525 } 1526 } 1527 1528 /* 1529 * Copy the new string into the buffer at the end of the old 1530 * one. 1531 */ 1532 1533 for (dst = dsPtr->string + dsPtr->length, end = string+length; 1534 string < end; string++, dst++) { 1535 *dst = *string; 1536 } 1537 *dst = '\0'; 1538 dsPtr->length += length; 1539 return dsPtr->string; 1540} 1541 1542/* 1543 *---------------------------------------------------------------------- 1544 * 1545 * Tcl_DStringAppendElement -- 1546 * 1547 * Append a list element to the current value of a dynamic string. 1548 * 1549 * Results: 1550 * The return value is a pointer to the dynamic string's new value. 1551 * 1552 * Side effects: 1553 * String is reformatted as a list element and added to the current 1554 * value of the string. Memory gets reallocated if needed to 1555 * accomodate the string's new size. 1556 * 1557 *---------------------------------------------------------------------- 1558 */ 1559 1560char * 1561Tcl_DStringAppendElement(dsPtr, string) 1562 Tcl_DString *dsPtr; /* Structure describing dynamic string. */ 1563 CONST char *string; /* String to append. Must be 1564 * null-terminated. */ 1565{ 1566 int newSize, flags, strSize; 1567 char *dst; 1568 1569 strSize = ((string == NULL) ? 0 : strlen(string)); 1570 newSize = Tcl_ScanCountedElement(string, strSize, &flags) 1571 + dsPtr->length + 1; 1572 1573 /* 1574 * Allocate a larger buffer for the string if the current one isn't 1575 * large enough. Allocate extra space in the new buffer so that there 1576 * will be room to grow before we have to allocate again. 1577 * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string 1578 * to a larger buffer, since there may be embedded NULLs in the 1579 * string in some cases. 1580 */ 1581 1582 if (newSize >= dsPtr->spaceAvl) { 1583 dsPtr->spaceAvl = newSize * 2; 1584 if (dsPtr->string == dsPtr->staticSpace) { 1585 char *newString; 1586 1587 newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); 1588 memcpy((VOID *) newString, (VOID *) dsPtr->string, 1589 (size_t) dsPtr->length); 1590 dsPtr->string = newString; 1591 } else { 1592 dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, 1593 (size_t) dsPtr->spaceAvl); 1594 } 1595 } 1596 1597 /* 1598 * Convert the new string to a list element and copy it into the 1599 * buffer at the end, with a space, if needed. 1600 */ 1601 1602 dst = dsPtr->string + dsPtr->length; 1603 if (TclNeedSpace(dsPtr->string, dst)) { 1604 *dst = ' '; 1605 dst++; 1606 dsPtr->length++; 1607 } 1608 dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags); 1609 return dsPtr->string; 1610} 1611 1612/* 1613 *---------------------------------------------------------------------- 1614 * 1615 * Tcl_DStringSetLength -- 1616 * 1617 * Change the length of a dynamic string. This can cause the 1618 * string to either grow or shrink, depending on the value of 1619 * length. 1620 * 1621 * Results: 1622 * None. 1623 * 1624 * Side effects: 1625 * The length of dsPtr is changed to length and a null byte is 1626 * stored at that position in the string. If length is larger 1627 * than the space allocated for dsPtr, then a panic occurs. 1628 * 1629 *---------------------------------------------------------------------- 1630 */ 1631 1632void 1633Tcl_DStringSetLength(dsPtr, length) 1634 Tcl_DString *dsPtr; /* Structure describing dynamic string. */ 1635 int length; /* New length for dynamic string. */ 1636{ 1637 int newsize; 1638 1639 if (length < 0) { 1640 length = 0; 1641 } 1642 if (length >= dsPtr->spaceAvl) { 1643 /* 1644 * There are two interesting cases here. In the first case, the user 1645 * may be trying to allocate a large buffer of a specific size. It 1646 * would be wasteful to overallocate that buffer, so we just allocate 1647 * enough for the requested size plus the trailing null byte. In the 1648 * second case, we are growing the buffer incrementally, so we need 1649 * behavior similar to Tcl_DStringAppend. The requested length will 1650 * usually be a small delta above the current spaceAvl, so we'll end up 1651 * doubling the old size. This won't grow the buffer quite as quickly, 1652 * but it should be close enough. 1653 */ 1654 1655 newsize = dsPtr->spaceAvl * 2; 1656 if (length < newsize) { 1657 dsPtr->spaceAvl = newsize; 1658 } else { 1659 dsPtr->spaceAvl = length + 1; 1660 } 1661 if (dsPtr->string == dsPtr->staticSpace) { 1662 char *newString; 1663 1664 newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); 1665 memcpy((VOID *) newString, (VOID *) dsPtr->string, 1666 (size_t) dsPtr->length); 1667 dsPtr->string = newString; 1668 } else { 1669 dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, 1670 (size_t) dsPtr->spaceAvl); 1671 } 1672 } 1673 dsPtr->length = length; 1674 dsPtr->string[length] = 0; 1675} 1676 1677/* 1678 *---------------------------------------------------------------------- 1679 * 1680 * Tcl_DStringFree -- 1681 * 1682 * Frees up any memory allocated for the dynamic string and 1683 * reinitializes the string to an empty state. 1684 * 1685 * Results: 1686 * None. 1687 * 1688 * Side effects: 1689 * The previous contents of the dynamic string are lost, and 1690 * the new value is an empty string. 1691 * 1692 *---------------------------------------------------------------------- */ 1693 1694void 1695Tcl_DStringFree(dsPtr) 1696 Tcl_DString *dsPtr; /* Structure describing dynamic string. */ 1697{ 1698 if (dsPtr->string != dsPtr->staticSpace) { 1699 ckfree(dsPtr->string); 1700 } 1701 dsPtr->string = dsPtr->staticSpace; 1702 dsPtr->length = 0; 1703 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 1704 dsPtr->staticSpace[0] = '\0'; 1705} 1706 1707/* 1708 *---------------------------------------------------------------------- 1709 * 1710 * Tcl_DStringResult -- 1711 * 1712 * This procedure moves the value of a dynamic string into an 1713 * interpreter as its string result. Afterwards, the dynamic string 1714 * is reset to an empty string. 1715 * 1716 * Results: 1717 * None. 1718 * 1719 * Side effects: 1720 * The string is "moved" to interp's result, and any existing 1721 * string result for interp is freed. dsPtr is reinitialized to 1722 * an empty string. 1723 * 1724 *---------------------------------------------------------------------- 1725 */ 1726 1727void 1728Tcl_DStringResult(interp, dsPtr) 1729 Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ 1730 Tcl_DString *dsPtr; /* Dynamic string that is to become the 1731 * result of interp. */ 1732{ 1733 Tcl_ResetResult(interp); 1734 1735 if (dsPtr->string != dsPtr->staticSpace) { 1736 interp->result = dsPtr->string; 1737 interp->freeProc = TCL_DYNAMIC; 1738 } else if (dsPtr->length < TCL_RESULT_SIZE) { 1739 interp->result = ((Interp *) interp)->resultSpace; 1740 strcpy(interp->result, dsPtr->string); 1741 } else { 1742 Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); 1743 } 1744 1745 dsPtr->string = dsPtr->staticSpace; 1746 dsPtr->length = 0; 1747 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 1748 dsPtr->staticSpace[0] = '\0'; 1749} 1750 1751/* 1752 *---------------------------------------------------------------------- 1753 * 1754 * Tcl_DStringGetResult -- 1755 * 1756 * This procedure moves an interpreter's result into a dynamic string. 1757 * 1758 * Results: 1759 * None. 1760 * 1761 * Side effects: 1762 * The interpreter's string result is cleared, and the previous 1763 * contents of dsPtr are freed. 1764 * 1765 * If the string result is empty, the object result is moved to the 1766 * string result, then the object result is reset. 1767 * 1768 *---------------------------------------------------------------------- 1769 */ 1770 1771void 1772Tcl_DStringGetResult(interp, dsPtr) 1773 Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ 1774 Tcl_DString *dsPtr; /* Dynamic string that is to become the 1775 * result of interp. */ 1776{ 1777 Interp *iPtr = (Interp *) interp; 1778 1779 if (dsPtr->string != dsPtr->staticSpace) { 1780 ckfree(dsPtr->string); 1781 } 1782 1783 /* 1784 * If the string result is empty, move the object result to the 1785 * string result, then reset the object result. 1786 */ 1787 1788 if (*(iPtr->result) == 0) { 1789 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 1790 TCL_VOLATILE); 1791 } 1792 1793 dsPtr->length = strlen(iPtr->result); 1794 if (iPtr->freeProc != NULL) { 1795 if (iPtr->freeProc == TCL_DYNAMIC) { 1796 dsPtr->string = iPtr->result; 1797 dsPtr->spaceAvl = dsPtr->length+1; 1798 } else { 1799 dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); 1800 strcpy(dsPtr->string, iPtr->result); 1801 (*iPtr->freeProc)(iPtr->result); 1802 } 1803 dsPtr->spaceAvl = dsPtr->length+1; 1804 iPtr->freeProc = NULL; 1805 } else { 1806 if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { 1807 dsPtr->string = dsPtr->staticSpace; 1808 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 1809 } else { 1810 dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); 1811 dsPtr->spaceAvl = dsPtr->length + 1; 1812 } 1813 strcpy(dsPtr->string, iPtr->result); 1814 } 1815 1816 iPtr->result = iPtr->resultSpace; 1817 iPtr->resultSpace[0] = 0; 1818} 1819 1820/* 1821 *---------------------------------------------------------------------- 1822 * 1823 * Tcl_DStringStartSublist -- 1824 * 1825 * This procedure adds the necessary information to a dynamic 1826 * string (e.g. " {" to start a sublist. Future element 1827 * appends will be in the sublist rather than the main list. 1828 * 1829 * Results: 1830 * None. 1831 * 1832 * Side effects: 1833 * Characters get added to the dynamic string. 1834 * 1835 *---------------------------------------------------------------------- 1836 */ 1837 1838void 1839Tcl_DStringStartSublist(dsPtr) 1840 Tcl_DString *dsPtr; /* Dynamic string. */ 1841{ 1842 if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { 1843 Tcl_DStringAppend(dsPtr, " {", -1); 1844 } else { 1845 Tcl_DStringAppend(dsPtr, "{", -1); 1846 } 1847} 1848 1849/* 1850 *---------------------------------------------------------------------- 1851 * 1852 * Tcl_DStringEndSublist -- 1853 * 1854 * This procedure adds the necessary characters to a dynamic 1855 * string to end a sublist (e.g. "}"). Future element appends 1856 * will be in the enclosing (sub)list rather than the current 1857 * sublist. 1858 * 1859 * Results: 1860 * None. 1861 * 1862 * Side effects: 1863 * None. 1864 * 1865 *---------------------------------------------------------------------- 1866 */ 1867 1868void 1869Tcl_DStringEndSublist(dsPtr) 1870 Tcl_DString *dsPtr; /* Dynamic string. */ 1871{ 1872 Tcl_DStringAppend(dsPtr, "}", -1); 1873} 1874 1875/* 1876 *---------------------------------------------------------------------- 1877 * 1878 * Tcl_PrintDouble -- 1879 * 1880 * Given a floating-point value, this procedure converts it to 1881 * an ASCII string using. 1882 * 1883 * Results: 1884 * The ASCII equivalent of "value" is written at "dst". It is 1885 * written using the current precision, and it is guaranteed to 1886 * contain a decimal point or exponent, so that it looks like 1887 * a floating-point value and not an integer. 1888 * 1889 * Side effects: 1890 * None. 1891 * 1892 *---------------------------------------------------------------------- 1893 */ 1894 1895void 1896Tcl_PrintDouble(interp, value, dst) 1897 Tcl_Interp *interp; /* Interpreter whose tcl_precision 1898 * variable used to be used to control 1899 * printing. It's ignored now. */ 1900 double value; /* Value to print as string. */ 1901 char *dst; /* Where to store converted value; 1902 * must have at least TCL_DOUBLE_SPACE 1903 * characters. */ 1904{ 1905 char *p, c; 1906 Tcl_UniChar ch; 1907 1908 Tcl_MutexLock(&precisionMutex); 1909 sprintf(dst, precisionFormat, value); 1910 Tcl_MutexUnlock(&precisionMutex); 1911 1912 /* 1913 * If the ASCII result looks like an integer, add ".0" so that it 1914 * doesn't look like an integer anymore. This prevents floating-point 1915 * values from being converted to integers unintentionally. 1916 * Check for ASCII specifically to speed up the function. 1917 */ 1918 1919 for (p = dst; *p != 0; ) { 1920 if (UCHAR(*p) < 0x80) { 1921 c = *p++; 1922 } else { 1923 p += Tcl_UtfToUniChar(p, &ch); 1924 c = UCHAR(ch); 1925 } 1926 if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ 1927 return; 1928 } 1929 } 1930 p[0] = '.'; 1931 p[1] = '0'; 1932 p[2] = 0; 1933} 1934 1935/* 1936 *---------------------------------------------------------------------- 1937 * 1938 * TclPrecTraceProc -- 1939 * 1940 * This procedure is invoked whenever the variable "tcl_precision" 1941 * is written. 1942 * 1943 * Results: 1944 * Returns NULL if all went well, or an error message if the 1945 * new value for the variable doesn't make sense. 1946 * 1947 * Side effects: 1948 * If the new value doesn't make sense then this procedure 1949 * undoes the effect of the variable modification. Otherwise 1950 * it modifies the format string that's used by Tcl_PrintDouble. 1951 * 1952 *---------------------------------------------------------------------- 1953 */ 1954 1955 /* ARGSUSED */ 1956char * 1957TclPrecTraceProc(clientData, interp, name1, name2, flags) 1958 ClientData clientData; /* Not used. */ 1959 Tcl_Interp *interp; /* Interpreter containing variable. */ 1960 CONST char *name1; /* Name of variable. */ 1961 CONST char *name2; /* Second part of variable name. */ 1962 int flags; /* Information about what happened. */ 1963{ 1964 CONST char *value; 1965 char *end; 1966 int prec; 1967 1968 /* 1969 * If the variable is unset, then recreate the trace. 1970 */ 1971 1972 if (flags & TCL_TRACE_UNSETS) { 1973 if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { 1974 Tcl_TraceVar2(interp, name1, name2, 1975 TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES 1976 |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); 1977 } 1978 return (char *) NULL; 1979 } 1980 1981 /* 1982 * When the variable is read, reset its value from our shared 1983 * value. This is needed in case the variable was modified in 1984 * some other interpreter so that this interpreter's value is 1985 * out of date. 1986 */ 1987 1988 Tcl_MutexLock(&precisionMutex); 1989 1990 if (flags & TCL_TRACE_READS) { 1991 Tcl_SetVar2(interp, name1, name2, precisionString, 1992 flags & TCL_GLOBAL_ONLY); 1993 Tcl_MutexUnlock(&precisionMutex); 1994 return (char *) NULL; 1995 } 1996 1997 /* 1998 * The variable is being written. Check the new value and disallow 1999 * it if it isn't reasonable or if this is a safe interpreter (we 2000 * don't want safe interpreters messing up the precision of other 2001 * interpreters). 2002 */ 2003 2004 if (Tcl_IsSafe(interp)) { 2005 Tcl_SetVar2(interp, name1, name2, precisionString, 2006 flags & TCL_GLOBAL_ONLY); 2007 Tcl_MutexUnlock(&precisionMutex); 2008 return "can't modify precision from a safe interpreter"; 2009 } 2010 value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); 2011 if (value == NULL) { 2012 value = ""; 2013 } 2014 prec = strtoul(value, &end, 10); 2015 if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || 2016 (end == value) || (*end != 0)) { 2017 Tcl_SetVar2(interp, name1, name2, precisionString, 2018 flags & TCL_GLOBAL_ONLY); 2019 Tcl_MutexUnlock(&precisionMutex); 2020 return "improper value for precision"; 2021 } 2022 TclFormatInt(precisionString, prec); 2023 sprintf(precisionFormat, "%%.%dg", prec); 2024 Tcl_MutexUnlock(&precisionMutex); 2025 return (char *) NULL; 2026} 2027 2028/* 2029 *---------------------------------------------------------------------- 2030 * 2031 * TclNeedSpace -- 2032 * 2033 * This procedure checks to see whether it is appropriate to 2034 * add a space before appending a new list element to an 2035 * existing string. 2036 * 2037 * Results: 2038 * The return value is 1 if a space is appropriate, 0 otherwise. 2039 * 2040 * Side effects: 2041 * None. 2042 * 2043 *---------------------------------------------------------------------- 2044 */ 2045 2046int 2047TclNeedSpace(start, end) 2048 CONST char *start; /* First character in string. */ 2049 CONST char *end; /* End of string (place where space will 2050 * be added, if appropriate). */ 2051{ 2052 /* 2053 * A space is needed unless either 2054 * (a) we're at the start of the string, or 2055 */ 2056 if (end == start) { 2057 return 0; 2058 } 2059 2060 /* 2061 * (b) we're at the start of a nested list-element, quoted with an 2062 * open curly brace; we can be nested arbitrarily deep, so long 2063 * as the first curly brace starts an element, so backtrack over 2064 * open curly braces that are trailing characters of the string; and 2065 */ 2066 2067 end = Tcl_UtfPrev(end, start); 2068 while (*end == '{') { 2069 if (end == start) { 2070 return 0; 2071 } 2072 end = Tcl_UtfPrev(end, start); 2073 } 2074 2075 /* 2076 * (c) the trailing character of the string is already a list-element 2077 * separator (according to TclFindElement); that is, one of these 2078 * characters: 2079 * \u0009 \t TAB 2080 * \u000A \n NEWLINE 2081 * \u000B \v VERTICAL TAB 2082 * \u000C \f FORM FEED 2083 * \u000D \r CARRIAGE RETURN 2084 * \u0020 SPACE 2085 * with the condition that the penultimate character is not a 2086 * backslash. 2087 */ 2088 2089 if (*end > 0x20) { 2090 /* 2091 * Performance tweak. All ASCII spaces are <= 0x20. So get 2092 * a quick answer for most characters before comparing against 2093 * all spaces in the switch below. 2094 * 2095 * NOTE: Remove this if other Unicode spaces ever get accepted 2096 * as list-element separators. 2097 */ 2098 return 1; 2099 } 2100 switch (*end) { 2101 case ' ': 2102 case '\t': 2103 case '\n': 2104 case '\r': 2105 case '\v': 2106 case '\f': 2107 if ((end == start) || (end[-1] != '\\')) { 2108 return 0; 2109 } 2110 } 2111 return 1; 2112} 2113 2114/* 2115 *---------------------------------------------------------------------- 2116 * 2117 * TclFormatInt -- 2118 * 2119 * This procedure formats an integer into a sequence of decimal digit 2120 * characters in a buffer. If the integer is negative, a minus sign is 2121 * inserted at the start of the buffer. A null character is inserted at 2122 * the end of the formatted characters. It is the caller's 2123 * responsibility to ensure that enough storage is available. This 2124 * procedure has the effect of sprintf(buffer, "%d", n) but is faster. 2125 * 2126 * Results: 2127 * An integer representing the number of characters formatted, not 2128 * including the terminating \0. 2129 * 2130 * Side effects: 2131 * The formatted characters are written into the storage pointer to 2132 * by the "buffer" argument. 2133 * 2134 *---------------------------------------------------------------------- 2135 */ 2136 2137int 2138TclFormatInt(buffer, n) 2139 char *buffer; /* Points to the storage into which the 2140 * formatted characters are written. */ 2141 long n; /* The integer to format. */ 2142{ 2143 long intVal; 2144 int i; 2145 int numFormatted, j; 2146 char *digits = "0123456789"; 2147 2148 /* 2149 * Check first whether "n" is zero. 2150 */ 2151 2152 if (n == 0) { 2153 buffer[0] = '0'; 2154 buffer[1] = 0; 2155 return 1; 2156 } 2157 2158 /* 2159 * Check whether "n" is the maximum negative value. This is 2160 * -2^(m-1) for an m-bit word, and has no positive equivalent; 2161 * negating it produces the same value. 2162 */ 2163 2164 if (n == -n) { 2165 sprintf(buffer, "%ld", n); 2166 return strlen(buffer); 2167 } 2168 2169 /* 2170 * Generate the characters of the result backwards in the buffer. 2171 */ 2172 2173 intVal = (n < 0? -n : n); 2174 i = 0; 2175 buffer[0] = '\0'; 2176 do { 2177 i++; 2178 buffer[i] = digits[intVal % 10]; 2179 intVal = intVal/10; 2180 } while (intVal > 0); 2181 if (n < 0) { 2182 i++; 2183 buffer[i] = '-'; 2184 } 2185 numFormatted = i; 2186 2187 /* 2188 * Now reverse the characters. 2189 */ 2190 2191 for (j = 0; j < i; j++, i--) { 2192 char tmp = buffer[i]; 2193 buffer[i] = buffer[j]; 2194 buffer[j] = tmp; 2195 } 2196 return numFormatted; 2197} 2198 2199/* 2200 *---------------------------------------------------------------------- 2201 * 2202 * TclLooksLikeInt -- 2203 * 2204 * This procedure decides whether the leading characters of a 2205 * string look like an integer or something else (such as a 2206 * floating-point number or string). 2207 * 2208 * Results: 2209 * The return value is 1 if the leading characters of p look 2210 * like a valid Tcl integer. If they look like a floating-point 2211 * number (e.g. "e01" or "2.4"), or if they don't look like a 2212 * number at all, then 0 is returned. 2213 * 2214 * Side effects: 2215 * None. 2216 * 2217 *---------------------------------------------------------------------- 2218 */ 2219 2220int 2221TclLooksLikeInt(bytes, length) 2222 register CONST char *bytes; /* Points to first byte of the string. */ 2223 int length; /* Number of bytes in the string. If < 0 2224 * bytes up to the first null byte are 2225 * considered (if they may appear in an 2226 * integer). */ 2227{ 2228 register CONST char *p; 2229 2230 if ((bytes == NULL) && (length > 0)) { 2231 Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length); 2232 } 2233 2234 if (length < 0) { 2235 length = (bytes? strlen(bytes) : 0); 2236 } 2237 2238 p = bytes; 2239 while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2240 length--; p++; 2241 } 2242 if (length == 0) { 2243 return 0; 2244 } 2245 if ((*p == '+') || (*p == '-')) { 2246 p++; length--; 2247 } 2248 2249 return (0 != TclParseInteger(p, length)); 2250} 2251 2252/* 2253 *---------------------------------------------------------------------- 2254 * 2255 * TclGetIntForIndex -- 2256 * 2257 * This procedure returns an integer corresponding to the list index 2258 * held in a Tcl object. The Tcl object's value is expected to be 2259 * either an integer or a string of the form "end([+-]integer)?". 2260 * 2261 * Results: 2262 * The return value is normally TCL_OK, which means that the index was 2263 * successfully stored into the location referenced by "indexPtr". If 2264 * the Tcl object referenced by "objPtr" has the value "end", the 2265 * value stored is "endValue". If "objPtr"s values is not of the form 2266 * "end([+-]integer)?" and 2267 * can not be converted to an integer, TCL_ERROR is returned and, if 2268 * "interp" is non-NULL, an error message is left in the interpreter's 2269 * result object. 2270 * 2271 * Side effects: 2272 * The object referenced by "objPtr" might be converted to an 2273 * integer, wide integer, or end-based-index object. 2274 * 2275 *---------------------------------------------------------------------- 2276 */ 2277 2278int 2279TclGetIntForIndex(interp, objPtr, endValue, indexPtr) 2280 Tcl_Interp *interp; /* Interpreter to use for error reporting. 2281 * If NULL, then no error message is left 2282 * after errors. */ 2283 Tcl_Obj *objPtr; /* Points to an object containing either 2284 * "end" or an integer. */ 2285 int endValue; /* The value to be stored at "indexPtr" if 2286 * "objPtr" holds "end". */ 2287 int *indexPtr; /* Location filled in with an integer 2288 * representing an index. */ 2289{ 2290 if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { 2291 return TCL_OK; 2292 } 2293 2294 if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { 2295 /* 2296 * If the object is already an offset from the end of the 2297 * list, or can be converted to one, use it. 2298 */ 2299 2300 *indexPtr = endValue + objPtr->internalRep.longValue; 2301 2302 } else { 2303 /* 2304 * Report a parse error. 2305 */ 2306 2307 if (interp != NULL) { 2308 char *bytes = Tcl_GetString(objPtr); 2309 /* 2310 * The result might not be empty; this resets it which 2311 * should be both a cheap operation, and of little problem 2312 * because this is an error-generation path anyway. 2313 */ 2314 Tcl_ResetResult(interp); 2315 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2316 "bad index \"", bytes, 2317 "\": must be integer or end?-integer?", 2318 (char *) NULL); 2319 if (!strncmp(bytes, "end-", 3)) { 2320 bytes += 3; 2321 } 2322 TclCheckBadOctal(interp, bytes); 2323 } 2324 2325 return TCL_ERROR; 2326 } 2327 2328 return TCL_OK; 2329} 2330 2331/* 2332 *---------------------------------------------------------------------- 2333 * 2334 * UpdateStringOfEndOffset -- 2335 * 2336 * Update the string rep of a Tcl object holding an "end-offset" 2337 * expression. 2338 * 2339 * Results: 2340 * None. 2341 * 2342 * Side effects: 2343 * Stores a valid string in the object's string rep. 2344 * 2345 * This procedure does NOT free any earlier string rep. If it is 2346 * called on an object that already has a valid string rep, it will 2347 * leak memory. 2348 * 2349 *---------------------------------------------------------------------- 2350 */ 2351 2352static void 2353UpdateStringOfEndOffset(objPtr) 2354 register Tcl_Obj* objPtr; 2355{ 2356 char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; 2357 register int len; 2358 2359 strcpy(buffer, "end"); 2360 len = sizeof("end") - 1; 2361 if (objPtr->internalRep.longValue != 0) { 2362 buffer[len++] = '-'; 2363 len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); 2364 } 2365 objPtr->bytes = ckalloc((unsigned) (len+1)); 2366 strcpy(objPtr->bytes, buffer); 2367 objPtr->length = len; 2368} 2369 2370/* 2371 *---------------------------------------------------------------------- 2372 * 2373 * SetEndOffsetFromAny -- 2374 * 2375 * Look for a string of the form "end-offset" and convert it 2376 * to an internal representation holding the offset. 2377 * 2378 * Results: 2379 * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. 2380 * 2381 * Side effects: 2382 * If interp is not NULL, stores an error message in the 2383 * interpreter result. 2384 * 2385 *---------------------------------------------------------------------- 2386 */ 2387 2388static int 2389SetEndOffsetFromAny(interp, objPtr) 2390 Tcl_Interp* interp; /* Tcl interpreter or NULL */ 2391 Tcl_Obj* objPtr; /* Pointer to the object to parse */ 2392{ 2393 int offset; /* Offset in the "end-offset" expression */ 2394 Tcl_ObjType* oldTypePtr = objPtr->typePtr; 2395 /* Old internal rep type of the object */ 2396 register char* bytes; /* String rep of the object */ 2397 int length; /* Length of the object's string rep */ 2398 2399 /* If it's already the right type, we're fine. */ 2400 2401 if (objPtr->typePtr == &tclEndOffsetType) { 2402 return TCL_OK; 2403 } 2404 2405 /* Check for a string rep of the right form. */ 2406 2407 bytes = Tcl_GetStringFromObj(objPtr, &length); 2408 if ((*bytes != 'e') || (strncmp(bytes, "end", 2409 (size_t)((length > 3) ? 3 : length)) != 0)) { 2410 if (interp != NULL) { 2411 Tcl_ResetResult(interp); 2412 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2413 "bad index \"", bytes, 2414 "\": must be end?-integer?", 2415 (char*) NULL); 2416 } 2417 return TCL_ERROR; 2418 } 2419 2420 /* Convert the string rep */ 2421 2422 if (length <= 3) { 2423 offset = 0; 2424 } else if ((length > 4) && (bytes[3] == '-')) { 2425 /* 2426 * This is our limited string expression evaluator. Pass everything 2427 * after "end-" to Tcl_GetInt, then reverse for offset. 2428 */ 2429 if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { 2430 return TCL_ERROR; 2431 } 2432 offset = -offset; 2433 } else { 2434 /* 2435 * Conversion failed. Report the error. 2436 */ 2437 if (interp != NULL) { 2438 Tcl_ResetResult(interp); 2439 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2440 "bad index \"", bytes, 2441 "\": must be integer or end?-integer?", 2442 (char *) NULL); 2443 } 2444 return TCL_ERROR; 2445 } 2446 2447 /* 2448 * The conversion succeeded. Free the old internal rep and set 2449 * the new one. 2450 */ 2451 2452 if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { 2453 oldTypePtr->freeIntRepProc(objPtr); 2454 } 2455 2456 objPtr->internalRep.longValue = offset; 2457 objPtr->typePtr = &tclEndOffsetType; 2458 2459 return TCL_OK; 2460} 2461 2462/* 2463 *---------------------------------------------------------------------- 2464 * 2465 * TclCheckBadOctal -- 2466 * 2467 * This procedure checks for a bad octal value and appends a 2468 * meaningful error to the interp's result. 2469 * 2470 * Results: 2471 * 1 if the argument was a bad octal, else 0. 2472 * 2473 * Side effects: 2474 * The interpreter's result is modified. 2475 * 2476 *---------------------------------------------------------------------- 2477 */ 2478 2479int 2480TclCheckBadOctal(interp, value) 2481 Tcl_Interp *interp; /* Interpreter to use for error reporting. 2482 * If NULL, then no error message is left 2483 * after errors. */ 2484 CONST char *value; /* String to check. */ 2485{ 2486 register CONST char *p = value; 2487 2488 /* 2489 * A frequent mistake is invalid octal values due to an unwanted 2490 * leading zero. Try to generate a meaningful error message. 2491 */ 2492 2493 while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2494 p++; 2495 } 2496 if (*p == '+' || *p == '-') { 2497 p++; 2498 } 2499 if (*p == '0') { 2500 while (isdigit(UCHAR(*p))) { /* INTL: digit. */ 2501 p++; 2502 } 2503 while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2504 p++; 2505 } 2506 if (*p == '\0') { 2507 /* Reached end of string */ 2508 if (interp != NULL) { 2509 /* 2510 * Don't reset the result here because we want this result 2511 * to be added to an existing error message as extra info. 2512 */ 2513 Tcl_AppendResult(interp, " (looks like invalid octal number)", 2514 (char *) NULL); 2515 } 2516 return 1; 2517 } 2518 } 2519 return 0; 2520} 2521 2522/* 2523 *---------------------------------------------------------------------- 2524 * 2525 * Tcl_GetNameOfExecutable -- 2526 * 2527 * This procedure simply returns a pointer to the internal full 2528 * path name of the executable file as computed by 2529 * Tcl_FindExecutable. This procedure call is the C API 2530 * equivalent to the "info nameofexecutable" command. 2531 * 2532 * Results: 2533 * A pointer to the internal string or NULL if the internal full 2534 * path name has not been computed or unknown. 2535 * 2536 * Side effects: 2537 * The object referenced by "objPtr" might be converted to an 2538 * integer object. 2539 * 2540 *---------------------------------------------------------------------- 2541 */ 2542 2543CONST char * 2544Tcl_GetNameOfExecutable() 2545{ 2546 return tclExecutableName; 2547} 2548 2549/* 2550 *---------------------------------------------------------------------- 2551 * 2552 * TclpGetTime -- 2553 * 2554 * Deprecated synonym for Tcl_GetTime. 2555 * 2556 * Results: 2557 * None. 2558 * 2559 * Side effects: 2560 * Stores current time in the buffer designated by "timePtr" 2561 * 2562 * This procedure is provided for the benefit of extensions written 2563 * before Tcl_GetTime was exported from the library. 2564 * 2565 *---------------------------------------------------------------------- 2566 */ 2567 2568void 2569TclpGetTime(timePtr) 2570 Tcl_Time* timePtr; 2571{ 2572 Tcl_GetTime(timePtr); 2573} 2574