1/* 2 * tclUtil.c -- 3 * 4 * This file contains utility functions 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 of 12 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id: tclUtil.c,v 1.97.2.6 2010/08/10 20:48:21 hobbs Exp $ 15 */ 16 17#include "tclInt.h" 18#include <float.h> 19#include <math.h> 20 21/* 22 * The absolute pathname of the executable in which this Tcl library is 23 * running. 24 */ 25 26static ProcessGlobalValue executableName = { 27 0, 0, NULL, NULL, NULL, NULL, NULL 28}; 29 30/* 31 * The following values are used in the flags returned by Tcl_ScanElement and 32 * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and 33 * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps 34 * with any of the 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, or 38 * ends in a backslash character, or user just 39 * doesn't want braces); handle all special 40 * 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 in 45 * the argument. 46 * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash 47 * character ('#') should *not* be quoted. This 48 * is appropriate when the caller can guarantee 49 * the element is not the first element of a 50 * list, so [eval] cannot mis-parse the element 51 * as a comment. 52 */ 53 54#define USE_BRACES 2 55#define BRACES_UNMATCHED 4 56 57/* 58 * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to 59 * access the precision to be used for double formatting. 60 */ 61 62static Tcl_ThreadDataKey precisionKey; 63 64/* 65 * Prototypes for functions defined later in this file. 66 */ 67 68static void ClearHash(Tcl_HashTable *tablePtr); 69static void FreeProcessGlobalValue(ClientData clientData); 70static void FreeThreadHash(ClientData clientData); 71static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); 72static int SetEndOffsetFromAny(Tcl_Interp* interp, 73 Tcl_Obj* objPtr); 74static void UpdateStringOfEndOffset(Tcl_Obj* objPtr); 75 76/* 77 * The following is the Tcl object type definition for an object that 78 * represents a list index in the form, "end-offset". It is used as a 79 * performance optimization in TclGetIntForIndex. The internal rep is an 80 * integer, so no memory management is required for it. 81 */ 82 83Tcl_ObjType tclEndOffsetType = { 84 "end-offset", /* name */ 85 NULL, /* freeIntRepProc */ 86 NULL, /* dupIntRepProc */ 87 UpdateStringOfEndOffset, /* updateStringProc */ 88 SetEndOffsetFromAny 89}; 90 91/* 92 *---------------------------------------------------------------------- 93 * 94 * TclFindElement -- 95 * 96 * Given a pointer into a Tcl list, locate the first (or next) element in 97 * the list. 98 * 99 * Results: 100 * The return value is normally TCL_OK, which means that the element was 101 * successfully located. If TCL_ERROR is returned it means that list 102 * didn't have proper list structure; the interp's result contains a more 103 * 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 list, 109 * then *nextPtr will point just after the last character in the list 110 * (i.e., at the character at list+listLength). If sizePtr is non-NULL, 111 * *sizePtr is filled in with the number of characters in the element. If 112 * the element is in braces, then *elementPtr will point to the character 113 * after the opening brace and *sizePtr will not include either of the 114 * braces. If there isn't an element in the list, *sizePtr will be zero, 115 * and both *elementPtr and *termPtr will point just after the last 116 * character in the list. Note: this function does NOT collapse backslash 117 * sequences. 118 * 119 * Side effects: 120 * None. 121 * 122 *---------------------------------------------------------------------- 123 */ 124 125int 126TclFindElement( 127 Tcl_Interp *interp, /* Interpreter to use for error reporting. If 128 * NULL, then no error message is left after 129 * errors. */ 130 CONST char *list, /* Points to the first byte of a string 131 * containing a Tcl list with zero or more 132 * elements (possibly in braces). */ 133 int listLength, /* Number of bytes in the list's string. */ 134 CONST char **elementPtr, /* Where to put address of first significant 135 * character in first element of list. */ 136 CONST char **nextPtr, /* Fill in with location of character just 137 * after all white space following end of 138 * argument (next arg or end of list). */ 139 int *sizePtr, /* If non-zero, fill in with size of 140 * element. */ 141 int *bracePtr) /* If non-zero, fill in with non-zero/zero to 142 * indicate that arg was/wasn't in braces. */ 143{ 144 CONST char *p = list; 145 CONST char *elemStart; /* Points to first byte of first element. */ 146 CONST char *limit; /* Points just after list's last byte. */ 147 int openBraces = 0; /* Brace nesting level during parse. */ 148 int inQuotes = 0; 149 int size = 0; /* lint. */ 150 int numChars; 151 CONST char *p2; 152 153 /* 154 * Skim off leading white space and check for an opening brace or quote. 155 * We treat embedded NULLs in the list as bytes belonging to a list 156 * element. 157 */ 158 159 limit = (list + listLength); 160 while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ 161 p++; 162 } 163 if (p == limit) { /* no element found */ 164 elemStart = limit; 165 goto done; 166 } 167 168 if (*p == '{') { 169 openBraces = 1; 170 p++; 171 } else if (*p == '"') { 172 inQuotes = 1; 173 p++; 174 } 175 elemStart = p; 176 if (bracePtr != 0) { 177 *bracePtr = openBraces; 178 } 179 180 /* 181 * Find element's end (a space, close brace, or the end of the string). 182 */ 183 184 while (p < limit) { 185 switch (*p) { 186 /* 187 * Open brace: don't treat specially unless the element is in 188 * braces. In this case, keep a nesting count. 189 */ 190 191 case '{': 192 if (openBraces != 0) { 193 openBraces++; 194 } 195 break; 196 197 /* 198 * Close brace: if element is in braces, keep nesting count and 199 * quit when the last close brace is seen. 200 */ 201 202 case '}': 203 if (openBraces > 1) { 204 openBraces--; 205 } else if (openBraces == 1) { 206 size = (p - elemStart); 207 p++; 208 if ((p >= limit) 209 || isspace(UCHAR(*p))) { /* INTL: ISO space. */ 210 goto done; 211 } 212 213 /* 214 * Garbage after the closing brace; return an error. 215 */ 216 217 if (interp != NULL) { 218 p2 = p; 219 while ((p2 < limit) 220 && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ 221 && (p2 < p+20)) { 222 p2++; 223 } 224 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 225 "list element in braces followed by \"%.*s\" " 226 "instead of space", (int) (p2-p), p)); 227 } 228 return TCL_ERROR; 229 } 230 break; 231 232 /* 233 * Backslash: skip over everything up to the end of the backslash 234 * sequence. 235 */ 236 237 case '\\': 238 Tcl_UtfBackslash(p, &numChars, NULL); 239 p += (numChars - 1); 240 break; 241 242 /* 243 * Space: ignore if element is in braces or quotes; otherwise 244 * terminate element. 245 */ 246 247 case ' ': 248 case '\f': 249 case '\n': 250 case '\r': 251 case '\t': 252 case '\v': 253 if ((openBraces == 0) && !inQuotes) { 254 size = (p - elemStart); 255 goto done; 256 } 257 break; 258 259 /* 260 * Double-quote: if element is in quotes then terminate it. 261 */ 262 263 case '"': 264 if (inQuotes) { 265 size = (p - elemStart); 266 p++; 267 if ((p >= limit) 268 || isspace(UCHAR(*p))) { /* INTL: ISO space */ 269 goto done; 270 } 271 272 /* 273 * Garbage after the closing quote; return an error. 274 */ 275 276 if (interp != NULL) { 277 p2 = p; 278 while ((p2 < limit) 279 && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ 280 && (p2 < p+20)) { 281 p2++; 282 } 283 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 284 "list element in quotes followed by \"%.*s\" " 285 "instead of space", (int) (p2-p), p)); 286 } 287 return TCL_ERROR; 288 } 289 break; 290 } 291 p++; 292 } 293 294 /* 295 * End of list: terminate element. 296 */ 297 298 if (p == limit) { 299 if (openBraces != 0) { 300 if (interp != NULL) { 301 Tcl_SetResult(interp, "unmatched open brace in list", 302 TCL_STATIC); 303 } 304 return TCL_ERROR; 305 } else if (inQuotes) { 306 if (interp != NULL) { 307 Tcl_SetResult(interp, "unmatched open quote in list", 308 TCL_STATIC); 309 } 310 return TCL_ERROR; 311 } 312 size = (p - elemStart); 313 } 314 315 done: 316 while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ 317 p++; 318 } 319 *elementPtr = elemStart; 320 *nextPtr = p; 321 if (sizePtr != 0) { 322 *sizePtr = size; 323 } 324 return TCL_OK; 325} 326 327/* 328 *---------------------------------------------------------------------- 329 * 330 * TclCopyAndCollapse -- 331 * 332 * Copy a string and eliminate any backslashes that aren't in braces. 333 * 334 * Results: 335 * Count characters get copied from src to dst. Along the way, if 336 * backslash sequences are found outside braces, the backslashes are 337 * eliminated in the copy. After scanning count chars from source, a null 338 * character is placed at the end of dst. Returns the number of 339 * characters that got copied. 340 * 341 * Side effects: 342 * None. 343 * 344 *---------------------------------------------------------------------- 345 */ 346 347int 348TclCopyAndCollapse( 349 int count, /* Number of characters to copy from src. */ 350 CONST char *src, /* Copy from here... */ 351 char *dst) /* ... to here. */ 352{ 353 register char c; 354 int numRead; 355 int newCount = 0; 356 int backslashCount; 357 358 for (c = *src; count > 0; src++, c = *src, count--) { 359 if (c == '\\') { 360 backslashCount = Tcl_UtfBackslash(src, &numRead, dst); 361 dst += backslashCount; 362 newCount += backslashCount; 363 src += numRead-1; 364 count -= numRead-1; 365 } else { 366 *dst = c; 367 dst++; 368 newCount++; 369 } 370 } 371 *dst = 0; 372 return newCount; 373} 374 375/* 376 *---------------------------------------------------------------------- 377 * 378 * Tcl_SplitList -- 379 * 380 * Splits a list up into its constituent fields. 381 * 382 * Results 383 * The return value is normally TCL_OK, which means that the list was 384 * successfully split up. If TCL_ERROR is returned, it means that "list" 385 * didn't have proper list structure; the interp's result will contain a 386 * more detailed error message. 387 * 388 * *argvPtr will be filled in with the address of an array whose elements 389 * point to the elements of list, in order. *argcPtr will get filled in 390 * with the number of valid elements in the array. A single block of 391 * memory is dynamically allocated to hold both the argv array and a copy 392 * of the list (with backslashes and braces removed in the standard way). 393 * The caller must eventually free this memory by calling free() on 394 * *argvPtr. Note: *argvPtr and *argcPtr are only modified if the 395 * function returns normally. 396 * 397 * Side effects: 398 * Memory is allocated. 399 * 400 *---------------------------------------------------------------------- 401 */ 402 403int 404Tcl_SplitList( 405 Tcl_Interp *interp, /* Interpreter to use for error reporting. If 406 * NULL, no error message is left. */ 407 CONST char *list, /* Pointer to string with list structure. */ 408 int *argcPtr, /* Pointer to location to fill in with the 409 * number of elements in the list. */ 410 CONST char ***argvPtr) /* Pointer to place to store pointer to array 411 * of pointers to list elements. */ 412{ 413 CONST char **argv, *l, *element; 414 char *p; 415 int length, size, i, result, elSize, brace; 416 417 /* 418 * Figure out how much space to allocate. There must be enough space for 419 * both the array of pointers and also for a copy of the list. To estimate 420 * the number of pointers needed, count the number of space characters in 421 * the list. 422 */ 423 424 for (size = 2, l = list; *l != 0; l++) { 425 if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ 426 size++; 427 428 /* 429 * Consecutive space can only count as a single list delimiter. 430 */ 431 432 while (1) { 433 char next = *(l + 1); 434 435 if (next == '\0') { 436 break; 437 } 438 ++l; 439 if (isspace(UCHAR(next))) { /* INTL: ISO space. */ 440 continue; 441 } 442 break; 443 } 444 } 445 } 446 length = l - list; 447 argv = (CONST char **) ckalloc((unsigned) 448 ((size * sizeof(char *)) + length + 1)); 449 for (i = 0, p = ((char *) argv) + size*sizeof(char *); 450 *list != 0; i++) { 451 CONST char *prevList = list; 452 453 result = TclFindElement(interp, list, length, &element, &list, 454 &elSize, &brace); 455 length -= (list - prevList); 456 if (result != TCL_OK) { 457 ckfree((char *) argv); 458 return result; 459 } 460 if (*element == 0) { 461 break; 462 } 463 if (i >= size) { 464 ckfree((char *) argv); 465 if (interp != NULL) { 466 Tcl_SetResult(interp, "internal error in Tcl_SplitList", 467 TCL_STATIC); 468 } 469 return TCL_ERROR; 470 } 471 argv[i] = p; 472 if (brace) { 473 memcpy(p, element, (size_t) elSize); 474 p += elSize; 475 *p = 0; 476 p++; 477 } else { 478 TclCopyAndCollapse(elSize, element, p); 479 p += elSize+1; 480 } 481 } 482 483 argv[i] = NULL; 484 *argvPtr = argv; 485 *argcPtr = i; 486 return TCL_OK; 487} 488 489/* 490 *---------------------------------------------------------------------- 491 * 492 * TclMarkList -- 493 * 494 * Marks the locations within a string where list elements start and 495 * computes where they end. 496 * 497 * Results 498 * The return value is normally TCL_OK, which means that the list was 499 * successfully split up. If TCL_ERROR is returned, it means that "list" 500 * didn't have proper list structure; the interp's result will contain a 501 * more detailed error message. 502 * 503 * *argvPtr will be filled in with the address of an array whose elements 504 * point to the places where the elements of list start, in order. 505 * *argcPtr will get filled in with the number of valid elements in the 506 * array. *argszPtr will get filled in with the address of an array whose 507 * elements are the lengths of the elements of the list, in order. 508 * Note: *argvPtr, *argcPtr and *argszPtr are only modified if the 509 * function returns normally. 510 * 511 * Side effects: 512 * Memory is allocated. 513 * 514 *---------------------------------------------------------------------- 515 */ 516 517int 518TclMarkList( 519 Tcl_Interp *interp, /* Interpreter to use for error reporting. If 520 * NULL, no error message is left. */ 521 CONST char *list, /* Pointer to string with list structure. */ 522 CONST char *end, /* Pointer to first char after the list. */ 523 int *argcPtr, /* Pointer to location to fill in with the 524 * number of elements in the list. */ 525 CONST int **argszPtr, /* Pointer to place to store length of list 526 * elements. */ 527 CONST char ***argvPtr) /* Pointer to place to store pointer to array 528 * of pointers to list elements. */ 529{ 530 CONST char **argv, *l, *element; 531 int *argn, length, size, i, result, elSize, brace; 532 533 /* 534 * Figure out how much space to allocate. There must be enough space for 535 * the array of pointers and lengths. To estimate the number of pointers 536 * needed, count the number of whitespace characters in the list. 537 */ 538 539 for (size=2, l=list ; l!=end ; l++) { 540 if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ 541 size++; 542 543 /* 544 * Consecutive space can only count as a single list delimiter. 545 */ 546 547 while (1) { 548 char next = *(l + 1); 549 550 if ((l+1) == end) { 551 break; 552 } 553 ++l; 554 if (isspace(UCHAR(next))) { /* INTL: ISO space. */ 555 continue; 556 } 557 break; 558 } 559 } 560 } 561 length = l - list; 562 argv = (CONST char **) ckalloc((unsigned) size * sizeof(char *)); 563 argn = (int *) ckalloc((unsigned) size * sizeof(int *)); 564 565 for (i = 0; list != end; i++) { 566 CONST char *prevList = list; 567 568 result = TclFindElement(interp, list, length, &element, &list, 569 &elSize, &brace); 570 length -= (list - prevList); 571 if (result != TCL_OK) { 572 ckfree((char *) argv); 573 ckfree((char *) argn); 574 return result; 575 } 576 if (*element == 0) { 577 break; 578 } 579 if (i >= size) { 580 ckfree((char *) argv); 581 ckfree((char *) argn); 582 if (interp != NULL) { 583 Tcl_SetResult(interp, "internal error in TclMarkList", 584 TCL_STATIC); 585 } 586 return TCL_ERROR; 587 } 588 argv[i] = element; 589 argn[i] = elSize; 590 } 591 592 argv[i] = NULL; 593 argn[i] = 0; 594 *argvPtr = argv; 595 *argszPtr = argn; 596 *argcPtr = i; 597 return TCL_OK; 598} 599 600/* 601 *---------------------------------------------------------------------- 602 * 603 * Tcl_ScanElement -- 604 * 605 * This function is a companion function to Tcl_ConvertElement. It scans 606 * a string to see what needs to be done to it (e.g. add backslashes or 607 * enclosing braces) to make the string into a valid Tcl list element. 608 * 609 * Results: 610 * The return value is an overestimate of the number of characters that 611 * will be needed by Tcl_ConvertElement to produce a valid list element 612 * from string. The word at *flagPtr is filled in with a value needed by 613 * Tcl_ConvertElement when doing the actual conversion. 614 * 615 * Side effects: 616 * None. 617 * 618 *---------------------------------------------------------------------- 619 */ 620 621int 622Tcl_ScanElement( 623 register CONST char *string,/* String to convert to list element. */ 624 register int *flagPtr) /* Where to store information to guide 625 * Tcl_ConvertCountedElement. */ 626{ 627 return Tcl_ScanCountedElement(string, -1, flagPtr); 628} 629 630/* 631 *---------------------------------------------------------------------- 632 * 633 * Tcl_ScanCountedElement -- 634 * 635 * This function is a companion function to Tcl_ConvertCountedElement. It 636 * scans a string to see what needs to be done to it (e.g. add 637 * backslashes or enclosing braces) to make the string into a valid Tcl 638 * list element. If length is -1, then the string is scanned up to the 639 * first null byte. 640 * 641 * Results: 642 * The return value is an overestimate of the number of characters that 643 * will be needed by Tcl_ConvertCountedElement to produce a valid list 644 * element from string. The word at *flagPtr is filled in with a value 645 * needed by Tcl_ConvertCountedElement when doing the actual conversion. 646 * 647 * Side effects: 648 * None. 649 * 650 *---------------------------------------------------------------------- 651 */ 652 653int 654Tcl_ScanCountedElement( 655 CONST char *string, /* String to convert to Tcl list element. */ 656 int length, /* Number of bytes in string, or -1. */ 657 int *flagPtr) /* Where to store information to guide 658 * Tcl_ConvertElement. */ 659{ 660 int flags, nestingLevel; 661 register CONST char *p, *lastChar; 662 663 /* 664 * This function and Tcl_ConvertElement together do two things: 665 * 666 * 1. They produce a proper list, one that will yield back the argument 667 * strings when evaluated or when disassembled with Tcl_SplitList. This 668 * is the most important thing. 669 * 670 * 2. They try to produce legible output, which means minimizing the use 671 * of backslashes (using braces instead). However, there are some 672 * situations where backslashes must be used (e.g. an element like 673 * "{abc": the leading brace will have to be backslashed. For each 674 * element, one of three things must be done: 675 * 676 * (a) Use the element as-is (it doesn't contain any special 677 * characters). This is the most desirable option. 678 * 679 * (b) Enclose the element in braces, but leave the contents alone. 680 * This happens if the element contains embedded space, or if it 681 * contains characters with special interpretation ($, [, ;, or \), 682 * or if it starts with a brace or double-quote, or if there are no 683 * characters in the element. 684 * 685 * (c) Don't enclose the element in braces, but add backslashes to 686 * prevent special interpretation of special characters. This is a 687 * last resort used when the argument would normally fall under 688 * case (b) but contains unmatched braces. It also occurs if the 689 * last character of the argument is a backslash or if the element 690 * contains a backslash followed by newline. 691 * 692 * The function figures out how many bytes will be needed to store the 693 * result (actually, it overestimates). It also collects information about 694 * the element in the form of a flags word. 695 * 696 * Note: list elements produced by this function and 697 * Tcl_ConvertCountedElement must have the property that they can be 698 * enclosing in curly braces to make sub-lists. This means, for example, 699 * that we must not leave unmatched curly braces in the resulting list 700 * element. This property is necessary in order for functions like 701 * Tcl_DStringStartSublist to work. 702 */ 703 704 nestingLevel = 0; 705 flags = 0; 706 if (string == NULL) { 707 string = ""; 708 } 709 if (length == -1) { 710 length = strlen(string); 711 } 712 lastChar = string + length; 713 p = string; 714 if ((p == lastChar) || (*p == '{') || (*p == '"')) { 715 flags |= USE_BRACES; 716 } 717 for (; p < lastChar; p++) { 718 switch (*p) { 719 case '{': 720 nestingLevel++; 721 break; 722 case '}': 723 nestingLevel--; 724 if (nestingLevel < 0) { 725 flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; 726 } 727 break; 728 case '[': 729 case '$': 730 case ';': 731 case ' ': 732 case '\f': 733 case '\n': 734 case '\r': 735 case '\t': 736 case '\v': 737 flags |= USE_BRACES; 738 break; 739 case '\\': 740 if ((p+1 == lastChar) || (p[1] == '\n')) { 741 flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; 742 } else { 743 int size; 744 745 Tcl_UtfBackslash(p, &size, NULL); 746 p += size-1; 747 flags |= USE_BRACES; 748 } 749 break; 750 } 751 } 752 if (nestingLevel != 0) { 753 flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; 754 } 755 *flagPtr = flags; 756 757 /* 758 * Allow enough space to backslash every character plus leave two spaces 759 * for braces. 760 */ 761 762 return 2*(p-string) + 2; 763} 764 765/* 766 *---------------------------------------------------------------------- 767 * 768 * Tcl_ConvertElement -- 769 * 770 * This is a companion function to Tcl_ScanElement. Given the information 771 * produced by Tcl_ScanElement, this function converts a string to a list 772 * element equal to that string. 773 * 774 * Results: 775 * Information is copied to *dst in the form of a list element identical 776 * to src (i.e. if Tcl_SplitList is applied to dst it will produce a 777 * string identical to src). The return value is a count of the number of 778 * characters copied (not including the terminating NULL character). 779 * 780 * Side effects: 781 * None. 782 * 783 *---------------------------------------------------------------------- 784 */ 785 786int 787Tcl_ConvertElement( 788 register CONST char *src, /* Source information for list element. */ 789 register char *dst, /* Place to put list-ified element. */ 790 register int flags) /* Flags produced by Tcl_ScanElement. */ 791{ 792 return Tcl_ConvertCountedElement(src, -1, dst, flags); 793} 794 795/* 796 *---------------------------------------------------------------------- 797 * 798 * Tcl_ConvertCountedElement -- 799 * 800 * This is a companion function to Tcl_ScanCountedElement. Given the 801 * information produced by Tcl_ScanCountedElement, this function converts 802 * a string to a list element equal to that string. 803 * 804 * Results: 805 * Information is copied to *dst in the form of a list element identical 806 * to src (i.e. if Tcl_SplitList is applied to dst it will produce a 807 * string identical to src). The return value is a count of the number of 808 * characters copied (not including the terminating NULL character). 809 * 810 * Side effects: 811 * None. 812 * 813 *---------------------------------------------------------------------- 814 */ 815 816int 817Tcl_ConvertCountedElement( 818 register CONST char *src, /* Source information for list element. */ 819 int length, /* Number of bytes in src, or -1. */ 820 char *dst, /* Place to put list-ified element. */ 821 int flags) /* Flags produced by Tcl_ScanElement. */ 822{ 823 register char *p = dst; 824 register CONST char *lastChar; 825 826 /* 827 * See the comment block at the beginning of the Tcl_ScanElement code for 828 * details of how this works. 829 */ 830 831 if (src && length == -1) { 832 length = strlen(src); 833 } 834 if ((src == NULL) || (length == 0)) { 835 p[0] = '{'; 836 p[1] = '}'; 837 p[2] = 0; 838 return 2; 839 } 840 lastChar = src + length; 841 if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { 842 flags |= USE_BRACES; 843 } 844 if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { 845 *p = '{'; 846 p++; 847 for (; src != lastChar; src++, p++) { 848 *p = *src; 849 } 850 *p = '}'; 851 p++; 852 } else { 853 if (*src == '{') { 854 /* 855 * Can't have a leading brace unless the whole element is enclosed 856 * in braces. Add a backslash before the brace. Furthermore, this 857 * may destroy the balance between open and close braces, so set 858 * BRACES_UNMATCHED. 859 */ 860 861 p[0] = '\\'; 862 p[1] = '{'; 863 p += 2; 864 src++; 865 flags |= BRACES_UNMATCHED; 866 } else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { 867 /* 868 * Leading '#' could be seen by [eval] as the start of a comment, 869 * if on the first element of a list, so quote it. 870 */ 871 872 p[0] = '\\'; 873 p[1] = '#'; 874 p += 2; 875 src++; 876 } 877 for (; src != lastChar; src++) { 878 switch (*src) { 879 case ']': 880 case '[': 881 case '$': 882 case ';': 883 case ' ': 884 case '\\': 885 case '"': 886 *p = '\\'; 887 p++; 888 break; 889 case '{': 890 case '}': 891 /* 892 * It may not seem necessary to backslash braces, but it is. 893 * The reason for this is that the resulting list element may 894 * actually be an element of a sub-list enclosed in braces 895 * (e.g. if Tcl_DStringStartSublist has been invoked), so 896 * there may be a brace mismatch if the braces aren't 897 * backslashed. 898 */ 899 900 if (flags & BRACES_UNMATCHED) { 901 *p = '\\'; 902 p++; 903 } 904 break; 905 case '\f': 906 *p = '\\'; 907 p++; 908 *p = 'f'; 909 p++; 910 continue; 911 case '\n': 912 *p = '\\'; 913 p++; 914 *p = 'n'; 915 p++; 916 continue; 917 case '\r': 918 *p = '\\'; 919 p++; 920 *p = 'r'; 921 p++; 922 continue; 923 case '\t': 924 *p = '\\'; 925 p++; 926 *p = 't'; 927 p++; 928 continue; 929 case '\v': 930 *p = '\\'; 931 p++; 932 *p = 'v'; 933 p++; 934 continue; 935 } 936 *p = *src; 937 p++; 938 } 939 } 940 *p = '\0'; 941 return p-dst; 942} 943 944/* 945 *---------------------------------------------------------------------- 946 * 947 * Tcl_Merge -- 948 * 949 * Given a collection of strings, merge them together into a single 950 * string that has proper Tcl list structured (i.e. Tcl_SplitList may be 951 * used to retrieve strings equal to the original elements, and Tcl_Eval 952 * will parse the string back into its original elements). 953 * 954 * Results: 955 * The return value is the address of a dynamically-allocated string 956 * containing the merged list. 957 * 958 * Side effects: 959 * None. 960 * 961 *---------------------------------------------------------------------- 962 */ 963 964char * 965Tcl_Merge( 966 int argc, /* How many strings to merge. */ 967 CONST char * CONST *argv) /* Array of string values. */ 968{ 969# define LOCAL_SIZE 20 970 int localFlags[LOCAL_SIZE], *flagPtr; 971 int numChars; 972 char *result; 973 char *dst; 974 int i; 975 976 /* 977 * Pass 1: estimate space, gather flags. 978 */ 979 980 if (argc <= LOCAL_SIZE) { 981 flagPtr = localFlags; 982 } else { 983 flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); 984 } 985 numChars = 1; 986 for (i = 0; i < argc; i++) { 987 numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; 988 } 989 990 /* 991 * Pass two: copy into the result area. 992 */ 993 994 result = (char *) ckalloc((unsigned) numChars); 995 dst = result; 996 for (i = 0; i < argc; i++) { 997 numChars = Tcl_ConvertElement(argv[i], dst, 998 flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); 999 dst += numChars; 1000 *dst = ' '; 1001 dst++; 1002 } 1003 if (dst == result) { 1004 *dst = 0; 1005 } else { 1006 dst[-1] = 0; 1007 } 1008 1009 if (flagPtr != localFlags) { 1010 ckfree((char *) flagPtr); 1011 } 1012 return result; 1013} 1014 1015/* 1016 *---------------------------------------------------------------------- 1017 * 1018 * Tcl_Backslash -- 1019 * 1020 * Figure out how to handle a backslash sequence. 1021 * 1022 * Results: 1023 * The return value is the character that should be substituted in place 1024 * of the backslash sequence that starts at src. If readPtr isn't NULL 1025 * then it is filled in with a count of the number of characters in the 1026 * backslash sequence. 1027 * 1028 * Side effects: 1029 * None. 1030 * 1031 *---------------------------------------------------------------------- 1032 */ 1033 1034char 1035Tcl_Backslash( 1036 CONST char *src, /* Points to the backslash character of a 1037 * backslash sequence. */ 1038 int *readPtr) /* Fill in with number of characters read from 1039 * src, unless NULL. */ 1040{ 1041 char buf[TCL_UTF_MAX]; 1042 Tcl_UniChar ch; 1043 1044 Tcl_UtfBackslash(src, readPtr, buf); 1045 TclUtfToUniChar(buf, &ch); 1046 return (char) ch; 1047} 1048 1049/* 1050 *---------------------------------------------------------------------- 1051 * 1052 * Tcl_Concat -- 1053 * 1054 * Concatenate a set of strings into a single large string. 1055 * 1056 * Results: 1057 * The return value is dynamically-allocated string containing a 1058 * concatenation of all the strings in argv, with spaces between the 1059 * original argv elements. 1060 * 1061 * Side effects: 1062 * Memory is allocated for the result; the caller is responsible for 1063 * freeing the memory. 1064 * 1065 *---------------------------------------------------------------------- 1066 */ 1067 1068char * 1069Tcl_Concat( 1070 int argc, /* Number of strings to concatenate. */ 1071 CONST char * CONST *argv) /* Array of strings to concatenate. */ 1072{ 1073 int totalSize, i; 1074 char *p; 1075 char *result; 1076 1077 for (totalSize = 1, i = 0; i < argc; i++) { 1078 totalSize += strlen(argv[i]) + 1; 1079 } 1080 result = (char *) ckalloc((unsigned) totalSize); 1081 if (argc == 0) { 1082 *result = '\0'; 1083 return result; 1084 } 1085 for (p = result, i = 0; i < argc; i++) { 1086 CONST char *element; 1087 int length; 1088 1089 /* 1090 * Clip white space off the front and back of the string to generate a 1091 * neater result, and ignore any empty elements. 1092 */ 1093 1094 element = argv[i]; 1095 while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ 1096 element++; 1097 } 1098 for (length = strlen(element); 1099 (length > 0) 1100 && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ 1101 && ((length < 2) || (element[length-2] != '\\')); 1102 length--) { 1103 /* Null loop body. */ 1104 } 1105 if (length == 0) { 1106 continue; 1107 } 1108 memcpy(p, element, (size_t) length); 1109 p += length; 1110 *p = ' '; 1111 p++; 1112 } 1113 if (p != result) { 1114 p[-1] = 0; 1115 } else { 1116 *p = 0; 1117 } 1118 return result; 1119} 1120 1121/* 1122 *---------------------------------------------------------------------- 1123 * 1124 * Tcl_ConcatObj -- 1125 * 1126 * Concatenate the strings from a set of objects into a single string 1127 * object with spaces between the original strings. 1128 * 1129 * Results: 1130 * The return value is a new string object containing a concatenation of 1131 * the strings in objv. Its ref count is zero. 1132 * 1133 * Side effects: 1134 * A new object is created. 1135 * 1136 *---------------------------------------------------------------------- 1137 */ 1138 1139Tcl_Obj * 1140Tcl_ConcatObj( 1141 int objc, /* Number of objects to concatenate. */ 1142 Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */ 1143{ 1144 int allocSize, finalSize, length, elemLength, i; 1145 char *p; 1146 char *element; 1147 char *concatStr; 1148 Tcl_Obj *objPtr, *resPtr; 1149 1150 /* 1151 * Check first to see if all the items are of list type or empty. If so, 1152 * we will concat them together as lists, and return a list object. This 1153 * is only valid when the lists have no current string representation, 1154 * since we don't know what the original type was. An original string rep 1155 * may have lost some whitespace info when converted which could be 1156 * important. 1157 */ 1158 1159 for (i = 0; i < objc; i++) { 1160 List *listRepPtr; 1161 1162 objPtr = objv[i]; 1163 if (objPtr->typePtr != &tclListType) { 1164 TclGetString(objPtr); 1165 if (objPtr->length) { 1166 break; 1167 } else { 1168 continue; 1169 } 1170 } 1171 listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; 1172 if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { 1173 break; 1174 } 1175 } 1176 if (i == objc) { 1177 Tcl_Obj **listv; 1178 int listc; 1179 1180 resPtr = NULL; 1181 for (i = 0; i < objc; i++) { 1182 /* 1183 * Tcl_ListObjAppendList could be used here, but this saves us a 1184 * bit of type checking (since we've already done it). Use of 1185 * INT_MAX tells us to always put the new stuff on the end. It 1186 * will be set right in Tcl_ListObjReplace. 1187 * Note that all objs at this point are either lists or have an 1188 * empty string rep. 1189 */ 1190 1191 objPtr = objv[i]; 1192 if (objPtr->bytes && !objPtr->length) { 1193 continue; 1194 } 1195 TclListObjGetElements(NULL, objPtr, &listc, &listv); 1196 if (listc) { 1197 if (resPtr) { 1198 Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv); 1199 } else { 1200 resPtr = TclListObjCopy(NULL, objPtr); 1201 } 1202 } 1203 } 1204 if (!resPtr) { 1205 resPtr = Tcl_NewObj(); 1206 } 1207 return resPtr; 1208 } 1209 1210 /* 1211 * Something cannot be determined to be safe, so build the concatenation 1212 * the slow way, using the string representations. 1213 */ 1214 1215 allocSize = 0; 1216 for (i = 0; i < objc; i++) { 1217 objPtr = objv[i]; 1218 element = TclGetStringFromObj(objPtr, &length); 1219 if ((element != NULL) && (length > 0)) { 1220 allocSize += (length + 1); 1221 } 1222 } 1223 if (allocSize == 0) { 1224 allocSize = 1; /* enough for the NULL byte at end */ 1225 } 1226 1227 /* 1228 * Allocate storage for the concatenated result. Note that allocSize is 1229 * one more than the total number of characters, and so includes room for 1230 * the terminating NULL byte. 1231 */ 1232 1233 concatStr = ckalloc((unsigned) allocSize); 1234 1235 /* 1236 * Now concatenate the elements. Clip white space off the front and back 1237 * to generate a neater result, and ignore any empty elements. Also put a 1238 * null byte at the end. 1239 */ 1240 1241 finalSize = 0; 1242 if (objc == 0) { 1243 *concatStr = '\0'; 1244 } else { 1245 p = concatStr; 1246 for (i = 0; i < objc; i++) { 1247 objPtr = objv[i]; 1248 element = TclGetStringFromObj(objPtr, &elemLength); 1249 while ((elemLength > 0) && (UCHAR(*element) < 127) 1250 && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ 1251 element++; 1252 elemLength--; 1253 } 1254 1255 /* 1256 * Trim trailing white space. But, be careful not to trim a space 1257 * character if it is preceded by a backslash: in this case it 1258 * could be significant. 1259 */ 1260 1261 while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) 1262 && isspace(UCHAR(element[elemLength-1])) 1263 /* INTL: ISO C space. */ 1264 && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { 1265 elemLength--; 1266 } 1267 if (elemLength == 0) { 1268 continue; /* nothing left of this element */ 1269 } 1270 memcpy(p, element, (size_t) elemLength); 1271 p += elemLength; 1272 *p = ' '; 1273 p++; 1274 finalSize += (elemLength + 1); 1275 } 1276 if (p != concatStr) { 1277 p[-1] = 0; 1278 finalSize -= 1; /* we overwrote the final ' ' */ 1279 } else { 1280 *p = 0; 1281 } 1282 } 1283 1284 TclNewObj(objPtr); 1285 objPtr->bytes = concatStr; 1286 objPtr->length = finalSize; 1287 return objPtr; 1288} 1289 1290/* 1291 *---------------------------------------------------------------------- 1292 * 1293 * Tcl_StringMatch -- 1294 * 1295 * See if a particular string matches a particular pattern. 1296 * 1297 * Results: 1298 * The return value is 1 if string matches pattern, and 0 otherwise. The 1299 * matching operation permits the following special characters in the 1300 * pattern: *?\[] (see the manual entry for details on what these mean). 1301 * 1302 * Side effects: 1303 * None. 1304 * 1305 *---------------------------------------------------------------------- 1306 */ 1307 1308int 1309Tcl_StringMatch( 1310 CONST char *str, /* String. */ 1311 CONST char *pattern) /* Pattern, which may contain special 1312 * characters. */ 1313{ 1314 return Tcl_StringCaseMatch(str, pattern, 0); 1315} 1316 1317/* 1318 *---------------------------------------------------------------------- 1319 * 1320 * Tcl_StringCaseMatch -- 1321 * 1322 * See if a particular string matches a particular pattern. Allows case 1323 * insensitivity. 1324 * 1325 * Results: 1326 * The return value is 1 if string matches pattern, and 0 otherwise. The 1327 * matching operation permits the following special characters in the 1328 * pattern: *?\[] (see the manual entry for details on what these mean). 1329 * 1330 * Side effects: 1331 * None. 1332 * 1333 *---------------------------------------------------------------------- 1334 */ 1335 1336int 1337Tcl_StringCaseMatch( 1338 CONST char *str, /* String. */ 1339 CONST char *pattern, /* Pattern, which may contain special 1340 * characters. */ 1341 int nocase) /* 0 for case sensitive, 1 for insensitive */ 1342{ 1343 int p, charLen; 1344 CONST char *pstart = pattern; 1345 Tcl_UniChar ch1, ch2; 1346 1347 while (1) { 1348 p = *pattern; 1349 1350 /* 1351 * See if we're at the end of both the pattern and the string. If so, 1352 * we succeeded. If we're at the end of the pattern but not at the end 1353 * of the string, we failed. 1354 */ 1355 1356 if (p == '\0') { 1357 return (*str == '\0'); 1358 } 1359 if ((*str == '\0') && (p != '*')) { 1360 return 0; 1361 } 1362 1363 /* 1364 * Check for a "*" as the next pattern character. It matches any 1365 * substring. We handle this by calling ourselves recursively for each 1366 * postfix of string, until either we match or we reach the end of the 1367 * string. 1368 */ 1369 1370 if (p == '*') { 1371 /* 1372 * Skip all successive *'s in the pattern 1373 */ 1374 1375 while (*(++pattern) == '*') {} 1376 p = *pattern; 1377 if (p == '\0') { 1378 return 1; 1379 } 1380 1381 /* 1382 * This is a special case optimization for single-byte utf. 1383 */ 1384 1385 if (UCHAR(*pattern) < 0x80) { 1386 ch2 = (Tcl_UniChar) 1387 (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); 1388 } else { 1389 Tcl_UtfToUniChar(pattern, &ch2); 1390 if (nocase) { 1391 ch2 = Tcl_UniCharToLower(ch2); 1392 } 1393 } 1394 1395 while (1) { 1396 /* 1397 * Optimization for matching - cruise through the string 1398 * quickly if the next char in the pattern isn't a special 1399 * character 1400 */ 1401 1402 if ((p != '[') && (p != '?') && (p != '\\')) { 1403 if (nocase) { 1404 while (*str) { 1405 charLen = TclUtfToUniChar(str, &ch1); 1406 if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { 1407 break; 1408 } 1409 str += charLen; 1410 } 1411 } else { 1412 /* 1413 * There's no point in trying to make this code 1414 * shorter, as the number of bytes you want to compare 1415 * each time is non-constant. 1416 */ 1417 1418 while (*str) { 1419 charLen = TclUtfToUniChar(str, &ch1); 1420 if (ch2 == ch1) { 1421 break; 1422 } 1423 str += charLen; 1424 } 1425 } 1426 } 1427 if (Tcl_StringCaseMatch(str, pattern, nocase)) { 1428 return 1; 1429 } 1430 if (*str == '\0') { 1431 return 0; 1432 } 1433 str += TclUtfToUniChar(str, &ch1); 1434 } 1435 } 1436 1437 /* 1438 * Check for a "?" as the next pattern character. It matches any 1439 * single character. 1440 */ 1441 1442 if (p == '?') { 1443 pattern++; 1444 str += TclUtfToUniChar(str, &ch1); 1445 continue; 1446 } 1447 1448 /* 1449 * Check for a "[" as the next pattern character. It is followed by a 1450 * list of characters that are acceptable, or by a range (two 1451 * characters separated by "-"). 1452 */ 1453 1454 if (p == '[') { 1455 Tcl_UniChar startChar, endChar; 1456 1457 pattern++; 1458 if (UCHAR(*str) < 0x80) { 1459 ch1 = (Tcl_UniChar) 1460 (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); 1461 str++; 1462 } else { 1463 str += Tcl_UtfToUniChar(str, &ch1); 1464 if (nocase) { 1465 ch1 = Tcl_UniCharToLower(ch1); 1466 } 1467 } 1468 while (1) { 1469 if ((*pattern == ']') || (*pattern == '\0')) { 1470 return 0; 1471 } 1472 if (UCHAR(*pattern) < 0x80) { 1473 startChar = (Tcl_UniChar) (nocase 1474 ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); 1475 pattern++; 1476 } else { 1477 pattern += Tcl_UtfToUniChar(pattern, &startChar); 1478 if (nocase) { 1479 startChar = Tcl_UniCharToLower(startChar); 1480 } 1481 } 1482 if (*pattern == '-') { 1483 pattern++; 1484 if (*pattern == '\0') { 1485 return 0; 1486 } 1487 if (UCHAR(*pattern) < 0x80) { 1488 endChar = (Tcl_UniChar) (nocase 1489 ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); 1490 pattern++; 1491 } else { 1492 pattern += Tcl_UtfToUniChar(pattern, &endChar); 1493 if (nocase) { 1494 endChar = Tcl_UniCharToLower(endChar); 1495 } 1496 } 1497 if (((startChar <= ch1) && (ch1 <= endChar)) 1498 || ((endChar <= ch1) && (ch1 <= startChar))) { 1499 /* 1500 * Matches ranges of form [a-z] or [z-a]. 1501 */ 1502 1503 break; 1504 } 1505 } else if (startChar == ch1) { 1506 break; 1507 } 1508 } 1509 while (*pattern != ']') { 1510 if (*pattern == '\0') { 1511 pattern = Tcl_UtfPrev(pattern, pstart); 1512 break; 1513 } 1514 pattern++; 1515 } 1516 pattern++; 1517 continue; 1518 } 1519 1520 /* 1521 * If the next pattern character is '\', just strip off the '\' so we 1522 * do exact matching on the character that follows. 1523 */ 1524 1525 if (p == '\\') { 1526 pattern++; 1527 if (*pattern == '\0') { 1528 return 0; 1529 } 1530 } 1531 1532 /* 1533 * There's no special character. Just make sure that the next bytes of 1534 * each string match. 1535 */ 1536 1537 str += TclUtfToUniChar(str, &ch1); 1538 pattern += TclUtfToUniChar(pattern, &ch2); 1539 if (nocase) { 1540 if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { 1541 return 0; 1542 } 1543 } else if (ch1 != ch2) { 1544 return 0; 1545 } 1546 } 1547} 1548 1549/* 1550 *---------------------------------------------------------------------- 1551 * 1552 * TclByteArrayMatch -- 1553 * 1554 * See if a particular string matches a particular pattern. Does not 1555 * allow for case insensitivity. 1556 * Parallels tclUtf.c:TclUniCharMatch, adjusted for char* and sans nocase. 1557 * 1558 * Results: 1559 * The return value is 1 if string matches pattern, and 0 otherwise. The 1560 * matching operation permits the following special characters in the 1561 * pattern: *?\[] (see the manual entry for details on what these mean). 1562 * 1563 * Side effects: 1564 * None. 1565 * 1566 *---------------------------------------------------------------------- 1567 */ 1568 1569int 1570TclByteArrayMatch( 1571 const unsigned char *string, /* String. */ 1572 int strLen, /* Length of String */ 1573 const unsigned char *pattern, /* Pattern, which may contain special 1574 * characters. */ 1575 int ptnLen, /* Length of Pattern */ 1576 int flags) 1577{ 1578 const unsigned char *stringEnd, *patternEnd; 1579 unsigned char p; 1580 1581 stringEnd = string + strLen; 1582 patternEnd = pattern + ptnLen; 1583 1584 while (1) { 1585 /* 1586 * See if we're at the end of both the pattern and the string. If so, 1587 * we succeeded. If we're at the end of the pattern but not at the end 1588 * of the string, we failed. 1589 */ 1590 1591 if (pattern == patternEnd) { 1592 return (string == stringEnd); 1593 } 1594 p = *pattern; 1595 if ((string == stringEnd) && (p != '*')) { 1596 return 0; 1597 } 1598 1599 /* 1600 * Check for a "*" as the next pattern character. It matches any 1601 * substring. We handle this by skipping all the characters up to the 1602 * next matching one in the pattern, and then calling ourselves 1603 * recursively for each postfix of string, until either we match or we 1604 * reach the end of the string. 1605 */ 1606 1607 if (p == '*') { 1608 /* 1609 * Skip all successive *'s in the pattern. 1610 */ 1611 1612 while ((++pattern < patternEnd) && (*pattern == '*')) { 1613 /* empty body */ 1614 } 1615 if (pattern == patternEnd) { 1616 return 1; 1617 } 1618 p = *pattern; 1619 while (1) { 1620 /* 1621 * Optimization for matching - cruise through the string 1622 * quickly if the next char in the pattern isn't a special 1623 * character. 1624 */ 1625 1626 if ((p != '[') && (p != '?') && (p != '\\')) { 1627 while ((string < stringEnd) && (p != *string)) { 1628 string++; 1629 } 1630 } 1631 if (TclByteArrayMatch(string, stringEnd - string, 1632 pattern, patternEnd - pattern, 0)) { 1633 return 1; 1634 } 1635 if (string == stringEnd) { 1636 return 0; 1637 } 1638 string++; 1639 } 1640 } 1641 1642 /* 1643 * Check for a "?" as the next pattern character. It matches any 1644 * single character. 1645 */ 1646 1647 if (p == '?') { 1648 pattern++; 1649 string++; 1650 continue; 1651 } 1652 1653 /* 1654 * Check for a "[" as the next pattern character. It is followed by a 1655 * list of characters that are acceptable, or by a range (two 1656 * characters separated by "-"). 1657 */ 1658 1659 if (p == '[') { 1660 unsigned char ch1, startChar, endChar; 1661 1662 pattern++; 1663 ch1 = *string; 1664 string++; 1665 while (1) { 1666 if ((*pattern == ']') || (pattern == patternEnd)) { 1667 return 0; 1668 } 1669 startChar = *pattern; 1670 pattern++; 1671 if (*pattern == '-') { 1672 pattern++; 1673 if (pattern == patternEnd) { 1674 return 0; 1675 } 1676 endChar = *pattern; 1677 pattern++; 1678 if (((startChar <= ch1) && (ch1 <= endChar)) 1679 || ((endChar <= ch1) && (ch1 <= startChar))) { 1680 /* 1681 * Matches ranges of form [a-z] or [z-a]. 1682 */ 1683 break; 1684 } 1685 } else if (startChar == ch1) { 1686 break; 1687 } 1688 } 1689 while (*pattern != ']') { 1690 if (pattern == patternEnd) { 1691 pattern--; 1692 break; 1693 } 1694 pattern++; 1695 } 1696 pattern++; 1697 continue; 1698 } 1699 1700 /* 1701 * If the next pattern character is '\', just strip off the '\' so we 1702 * do exact matching on the character that follows. 1703 */ 1704 1705 if (p == '\\') { 1706 if (++pattern == patternEnd) { 1707 return 0; 1708 } 1709 } 1710 1711 /* 1712 * There's no special character. Just make sure that the next bytes of 1713 * each string match. 1714 */ 1715 1716 if (*string != *pattern) { 1717 return 0; 1718 } 1719 string++; 1720 pattern++; 1721 } 1722} 1723 1724/* 1725 *---------------------------------------------------------------------- 1726 * 1727 * TclStringMatchObj -- 1728 * 1729 * See if a particular string matches a particular pattern. 1730 * Allows case insensitivity. This is the generic multi-type handler 1731 * for the various matching algorithms. 1732 * 1733 * Results: 1734 * The return value is 1 if string matches pattern, and 0 otherwise. The 1735 * matching operation permits the following special characters in the 1736 * pattern: *?\[] (see the manual entry for details on what these mean). 1737 * 1738 * Side effects: 1739 * None. 1740 * 1741 *---------------------------------------------------------------------- 1742 */ 1743 1744int 1745TclStringMatchObj( 1746 Tcl_Obj *strObj, /* string object. */ 1747 Tcl_Obj *ptnObj, /* pattern object. */ 1748 int flags) /* Only TCL_MATCH_NOCASE should be passed or 0. */ 1749{ 1750 int match, length, plen; 1751 1752 /* 1753 * Promote based on the type of incoming object. 1754 * XXX: Currently doesn't take advantage of exact-ness that 1755 * XXX: TclReToGlob tells us about 1756 trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); 1757 */ 1758 1759 if ((strObj->typePtr == &tclStringType)) { 1760 Tcl_UniChar *udata, *uptn; 1761 1762 udata = Tcl_GetUnicodeFromObj(strObj, &length); 1763 uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); 1764 match = TclUniCharMatch(udata, length, uptn, plen, flags); 1765 } else if ((strObj->typePtr == &tclByteArrayType) && !flags) { 1766 unsigned char *data, *ptn; 1767 1768 data = Tcl_GetByteArrayFromObj(strObj, &length); 1769 ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); 1770 match = TclByteArrayMatch(data, length, ptn, plen, 0); 1771 } else { 1772 match = Tcl_StringCaseMatch(TclGetString(strObj), 1773 TclGetString(ptnObj), flags); 1774 } 1775 return match; 1776} 1777 1778/* 1779 *---------------------------------------------------------------------- 1780 * 1781 * Tcl_DStringInit -- 1782 * 1783 * Initializes a dynamic string, discarding any previous contents of the 1784 * string (Tcl_DStringFree should have been called already if the dynamic 1785 * string was previously in use). 1786 * 1787 * Results: 1788 * None. 1789 * 1790 * Side effects: 1791 * The dynamic string is initialized to be empty. 1792 * 1793 *---------------------------------------------------------------------- 1794 */ 1795 1796void 1797Tcl_DStringInit( 1798 Tcl_DString *dsPtr) /* Pointer to structure for dynamic string. */ 1799{ 1800 dsPtr->string = dsPtr->staticSpace; 1801 dsPtr->length = 0; 1802 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 1803 dsPtr->staticSpace[0] = '\0'; 1804} 1805 1806/* 1807 *---------------------------------------------------------------------- 1808 * 1809 * Tcl_DStringAppend -- 1810 * 1811 * Append more bytes to the current value of a dynamic string. 1812 * 1813 * Results: 1814 * The return value is a pointer to the dynamic string's new value. 1815 * 1816 * Side effects: 1817 * Length bytes from "bytes" (or all of "bytes" if length is less than 1818 * zero) are added to the current value of the string. Memory gets 1819 * reallocated if needed to accomodate the string's new size. 1820 * 1821 *---------------------------------------------------------------------- 1822 */ 1823 1824char * 1825Tcl_DStringAppend( 1826 Tcl_DString *dsPtr, /* Structure describing dynamic string. */ 1827 CONST char *bytes, /* String to append. If length is -1 then this 1828 * must be null-terminated. */ 1829 int length) /* Number of bytes from "bytes" to append. If 1830 * < 0, then append all of bytes, up to null 1831 * at end. */ 1832{ 1833 int newSize; 1834 char *dst; 1835 CONST char *end; 1836 1837 if (length < 0) { 1838 length = strlen(bytes); 1839 } 1840 newSize = length + dsPtr->length; 1841 1842 /* 1843 * Allocate a larger buffer for the string if the current one isn't large 1844 * enough. Allocate extra space in the new buffer so that there will be 1845 * room to grow before we have to allocate again. 1846 */ 1847 1848 if (newSize >= dsPtr->spaceAvl) { 1849 dsPtr->spaceAvl = newSize * 2; 1850 if (dsPtr->string == dsPtr->staticSpace) { 1851 char *newString = ckalloc((unsigned) dsPtr->spaceAvl); 1852 1853 memcpy(newString, dsPtr->string, (size_t) dsPtr->length); 1854 dsPtr->string = newString; 1855 } else { 1856 dsPtr->string = ckrealloc((void *) dsPtr->string, 1857 (size_t) dsPtr->spaceAvl); 1858 } 1859 } 1860 1861 /* 1862 * Copy the new string into the buffer at the end of the old one. 1863 */ 1864 1865 for (dst = dsPtr->string + dsPtr->length, end = bytes+length; 1866 bytes < end; bytes++, dst++) { 1867 *dst = *bytes; 1868 } 1869 *dst = '\0'; 1870 dsPtr->length += length; 1871 return dsPtr->string; 1872} 1873 1874/* 1875 *---------------------------------------------------------------------- 1876 * 1877 * Tcl_DStringAppendElement -- 1878 * 1879 * Append a list element to the current value of a dynamic string. 1880 * 1881 * Results: 1882 * The return value is a pointer to the dynamic string's new value. 1883 * 1884 * Side effects: 1885 * String is reformatted as a list element and added to the current value 1886 * of the string. Memory gets reallocated if needed to accomodate the 1887 * string's new size. 1888 * 1889 *---------------------------------------------------------------------- 1890 */ 1891 1892char * 1893Tcl_DStringAppendElement( 1894 Tcl_DString *dsPtr, /* Structure describing dynamic string. */ 1895 CONST char *element) /* String to append. Must be 1896 * null-terminated. */ 1897{ 1898 int newSize, flags, strSize; 1899 char *dst; 1900 1901 strSize = ((element== NULL) ? 0 : strlen(element)); 1902 newSize = Tcl_ScanCountedElement(element, strSize, &flags) 1903 + dsPtr->length + 1; 1904 1905 /* 1906 * Allocate a larger buffer for the string if the current one isn't large 1907 * enough. Allocate extra space in the new buffer so that there will be 1908 * room to grow before we have to allocate again. SPECIAL NOTE: must use 1909 * memcpy, not strcpy, to copy the string to a larger buffer, since there 1910 * may be embedded NULLs in the string in some cases. 1911 */ 1912 1913 if (newSize >= dsPtr->spaceAvl) { 1914 dsPtr->spaceAvl = newSize * 2; 1915 if (dsPtr->string == dsPtr->staticSpace) { 1916 char *newString = ckalloc((unsigned) dsPtr->spaceAvl); 1917 1918 memcpy(newString, dsPtr->string, (size_t) dsPtr->length); 1919 dsPtr->string = newString; 1920 } else { 1921 dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, 1922 (size_t) dsPtr->spaceAvl); 1923 } 1924 } 1925 1926 /* 1927 * Convert the new string to a list element and copy it into the buffer at 1928 * the end, with a space, if needed. 1929 */ 1930 1931 dst = dsPtr->string + dsPtr->length; 1932 if (TclNeedSpace(dsPtr->string, dst)) { 1933 *dst = ' '; 1934 dst++; 1935 dsPtr->length++; 1936 1937 /* 1938 * If we need a space to separate this element from preceding stuff, 1939 * then this element will not lead a list, and need not have it's 1940 * leading '#' quoted. 1941 */ 1942 1943 flags |= TCL_DONT_QUOTE_HASH; 1944 } 1945 dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags); 1946 return dsPtr->string; 1947} 1948 1949/* 1950 *---------------------------------------------------------------------- 1951 * 1952 * Tcl_DStringSetLength -- 1953 * 1954 * Change the length of a dynamic string. This can cause the string to 1955 * either grow or shrink, depending on the value of length. 1956 * 1957 * Results: 1958 * None. 1959 * 1960 * Side effects: 1961 * The length of dsPtr is changed to length and a null byte is stored at 1962 * that position in the string. If length is larger than the space 1963 * allocated for dsPtr, then a panic occurs. 1964 * 1965 *---------------------------------------------------------------------- 1966 */ 1967 1968void 1969Tcl_DStringSetLength( 1970 Tcl_DString *dsPtr, /* Structure describing dynamic string. */ 1971 int length) /* New length for dynamic string. */ 1972{ 1973 int newsize; 1974 1975 if (length < 0) { 1976 length = 0; 1977 } 1978 if (length >= dsPtr->spaceAvl) { 1979 /* 1980 * There are two interesting cases here. In the first case, the user 1981 * may be trying to allocate a large buffer of a specific size. It 1982 * would be wasteful to overallocate that buffer, so we just allocate 1983 * enough for the requested size plus the trailing null byte. In the 1984 * second case, we are growing the buffer incrementally, so we need 1985 * behavior similar to Tcl_DStringAppend. The requested length will 1986 * usually be a small delta above the current spaceAvl, so we'll end 1987 * up doubling the old size. This won't grow the buffer quite as 1988 * quickly, but it should be close enough. 1989 */ 1990 1991 newsize = dsPtr->spaceAvl * 2; 1992 if (length < newsize) { 1993 dsPtr->spaceAvl = newsize; 1994 } else { 1995 dsPtr->spaceAvl = length + 1; 1996 } 1997 if (dsPtr->string == dsPtr->staticSpace) { 1998 char *newString = ckalloc((unsigned) dsPtr->spaceAvl); 1999 2000 memcpy(newString, dsPtr->string, (size_t) dsPtr->length); 2001 dsPtr->string = newString; 2002 } else { 2003 dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, 2004 (size_t) dsPtr->spaceAvl); 2005 } 2006 } 2007 dsPtr->length = length; 2008 dsPtr->string[length] = 0; 2009} 2010 2011/* 2012 *---------------------------------------------------------------------- 2013 * 2014 * Tcl_DStringFree -- 2015 * 2016 * Frees up any memory allocated for the dynamic string and reinitializes 2017 * the string to an empty state. 2018 * 2019 * Results: 2020 * None. 2021 * 2022 * Side effects: 2023 * The previous contents of the dynamic string are lost, and the new 2024 * value is an empty string. 2025 * 2026 *---------------------------------------------------------------------- 2027 */ 2028 2029void 2030Tcl_DStringFree( 2031 Tcl_DString *dsPtr) /* Structure describing dynamic string. */ 2032{ 2033 if (dsPtr->string != dsPtr->staticSpace) { 2034 ckfree(dsPtr->string); 2035 } 2036 dsPtr->string = dsPtr->staticSpace; 2037 dsPtr->length = 0; 2038 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 2039 dsPtr->staticSpace[0] = '\0'; 2040} 2041 2042/* 2043 *---------------------------------------------------------------------- 2044 * 2045 * Tcl_DStringResult -- 2046 * 2047 * This function moves the value of a dynamic string into an interpreter 2048 * as its string result. Afterwards, the dynamic string is reset to an 2049 * empty string. 2050 * 2051 * Results: 2052 * None. 2053 * 2054 * Side effects: 2055 * The string is "moved" to interp's result, and any existing string 2056 * result for interp is freed. dsPtr is reinitialized to an empty string. 2057 * 2058 *---------------------------------------------------------------------- 2059 */ 2060 2061void 2062Tcl_DStringResult( 2063 Tcl_Interp *interp, /* Interpreter whose result is to be reset. */ 2064 Tcl_DString *dsPtr) /* Dynamic string that is to become the 2065 * result of interp. */ 2066{ 2067 Tcl_ResetResult(interp); 2068 2069 if (dsPtr->string != dsPtr->staticSpace) { 2070 interp->result = dsPtr->string; 2071 interp->freeProc = TCL_DYNAMIC; 2072 } else if (dsPtr->length < TCL_RESULT_SIZE) { 2073 interp->result = ((Interp *) interp)->resultSpace; 2074 strcpy(interp->result, dsPtr->string); 2075 } else { 2076 Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); 2077 } 2078 2079 dsPtr->string = dsPtr->staticSpace; 2080 dsPtr->length = 0; 2081 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 2082 dsPtr->staticSpace[0] = '\0'; 2083} 2084 2085/* 2086 *---------------------------------------------------------------------- 2087 * 2088 * Tcl_DStringGetResult -- 2089 * 2090 * This function moves an interpreter's result into a dynamic string. 2091 * 2092 * Results: 2093 * None. 2094 * 2095 * Side effects: 2096 * The interpreter's string result is cleared, and the previous contents 2097 * of dsPtr are freed. 2098 * 2099 * If the string result is empty, the object result is moved to the 2100 * string result, then the object result is reset. 2101 * 2102 *---------------------------------------------------------------------- 2103 */ 2104 2105void 2106Tcl_DStringGetResult( 2107 Tcl_Interp *interp, /* Interpreter whose result is to be reset. */ 2108 Tcl_DString *dsPtr) /* Dynamic string that is to become the result 2109 * of interp. */ 2110{ 2111 Interp *iPtr = (Interp *) interp; 2112 2113 if (dsPtr->string != dsPtr->staticSpace) { 2114 ckfree(dsPtr->string); 2115 } 2116 2117 /* 2118 * If the string result is empty, move the object result to the string 2119 * result, then reset the object result. 2120 */ 2121 2122 (void) Tcl_GetStringResult(interp); 2123 2124 dsPtr->length = strlen(iPtr->result); 2125 if (iPtr->freeProc != NULL) { 2126 if (iPtr->freeProc == TCL_DYNAMIC) { 2127 dsPtr->string = iPtr->result; 2128 dsPtr->spaceAvl = dsPtr->length+1; 2129 } else { 2130 dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); 2131 memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); 2132 (*iPtr->freeProc)(iPtr->result); 2133 } 2134 dsPtr->spaceAvl = dsPtr->length+1; 2135 iPtr->freeProc = NULL; 2136 } else { 2137 if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { 2138 dsPtr->string = dsPtr->staticSpace; 2139 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; 2140 } else { 2141 dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); 2142 dsPtr->spaceAvl = dsPtr->length + 1; 2143 } 2144 memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); 2145 } 2146 2147 iPtr->result = iPtr->resultSpace; 2148 iPtr->resultSpace[0] = 0; 2149} 2150 2151/* 2152 *---------------------------------------------------------------------- 2153 * 2154 * Tcl_DStringStartSublist -- 2155 * 2156 * This function adds the necessary information to a dynamic string 2157 * (e.g. " {") to start a sublist. Future element appends will be in the 2158 * sublist rather than the main list. 2159 * 2160 * Results: 2161 * None. 2162 * 2163 * Side effects: 2164 * Characters get added to the dynamic string. 2165 * 2166 *---------------------------------------------------------------------- 2167 */ 2168 2169void 2170Tcl_DStringStartSublist( 2171 Tcl_DString *dsPtr) /* Dynamic string. */ 2172{ 2173 if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { 2174 Tcl_DStringAppend(dsPtr, " {", -1); 2175 } else { 2176 Tcl_DStringAppend(dsPtr, "{", -1); 2177 } 2178} 2179 2180/* 2181 *---------------------------------------------------------------------- 2182 * 2183 * Tcl_DStringEndSublist -- 2184 * 2185 * This function adds the necessary characters to a dynamic string to end 2186 * a sublist (e.g. "}"). Future element appends will be in the enclosing 2187 * (sub)list rather than the current sublist. 2188 * 2189 * Results: 2190 * None. 2191 * 2192 * Side effects: 2193 * None. 2194 * 2195 *---------------------------------------------------------------------- 2196 */ 2197 2198void 2199Tcl_DStringEndSublist( 2200 Tcl_DString *dsPtr) /* Dynamic string. */ 2201{ 2202 Tcl_DStringAppend(dsPtr, "}", -1); 2203} 2204 2205/* 2206 *---------------------------------------------------------------------- 2207 * 2208 * Tcl_PrintDouble -- 2209 * 2210 * Given a floating-point value, this function converts it to an ASCII 2211 * string using. 2212 * 2213 * Results: 2214 * The ASCII equivalent of "value" is written at "dst". It is written 2215 * using the current precision, and it is guaranteed to contain a decimal 2216 * point or exponent, so that it looks like a floating-point value and 2217 * not an integer. 2218 * 2219 * Side effects: 2220 * None. 2221 * 2222 *---------------------------------------------------------------------- 2223 */ 2224 2225void 2226Tcl_PrintDouble( 2227 Tcl_Interp *interp, /* Interpreter whose tcl_precision variable 2228 * used to be used to control printing. It's 2229 * ignored now. */ 2230 double value, /* Value to print as string. */ 2231 char *dst) /* Where to store converted value; must have 2232 * at least TCL_DOUBLE_SPACE characters. */ 2233{ 2234 char *p, c; 2235 int exp; 2236 int signum; 2237 char buffer[TCL_DOUBLE_SPACE]; 2238 Tcl_UniChar ch; 2239 2240 int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); 2241 2242 /* 2243 * If *precisionPtr == 0, then use TclDoubleDigits to develop a decimal 2244 * significand and exponent, then format it in E or F format as 2245 * appropriate. If *precisionPtr != 0, use the native sprintf and then add 2246 * a trailing ".0" if there is no decimal point in the rep. 2247 */ 2248 2249 if (*precisionPtr == 0) { 2250 /* 2251 * Handle NaN. 2252 */ 2253 2254 if (TclIsNaN(value)) { 2255 TclFormatNaN(value, dst); 2256 return; 2257 } 2258 2259 /* 2260 * Handle infinities. 2261 */ 2262 2263 if (TclIsInfinite(value)) { 2264 if (value < 0) { 2265 strcpy(dst, "-Inf"); 2266 } else { 2267 strcpy(dst, "Inf"); 2268 } 2269 return; 2270 } 2271 2272 /* 2273 * Ordinary (normal and denormal) values. 2274 */ 2275 2276 exp = TclDoubleDigits(buffer, value, &signum); 2277 if (signum) { 2278 *dst++ = '-'; 2279 } 2280 p = buffer; 2281 if (exp < -3 || exp > 17) { 2282 /* 2283 * E format for numbers < 1e-3 or >= 1e17. 2284 */ 2285 2286 *dst++ = *p++; 2287 c = *p; 2288 if (c != '\0') { 2289 *dst++ = '.'; 2290 while (c != '\0') { 2291 *dst++ = c; 2292 c = *++p; 2293 } 2294 } 2295 sprintf(dst, "e%+d", exp-1); 2296 } else { 2297 /* 2298 * F format for others. 2299 */ 2300 2301 if (exp <= 0) { 2302 *dst++ = '0'; 2303 } 2304 c = *p; 2305 while (exp-- > 0) { 2306 if (c != '\0') { 2307 *dst++ = c; 2308 c = *++p; 2309 } else { 2310 *dst++ = '0'; 2311 } 2312 } 2313 *dst++ = '.'; 2314 if (c == '\0') { 2315 *dst++ = '0'; 2316 } else { 2317 while (++exp < 0) { 2318 *dst++ = '0'; 2319 } 2320 while (c != '\0') { 2321 *dst++ = c; 2322 c = *++p; 2323 } 2324 } 2325 *dst++ = '\0'; 2326 } 2327 } else { 2328 /* 2329 * tcl_precision is supplied, pass it to the native sprintf. 2330 */ 2331 2332 sprintf(dst, "%.*g", *precisionPtr, value); 2333 2334 /* 2335 * If the ASCII result looks like an integer, add ".0" so that it 2336 * doesn't look like an integer anymore. This prevents floating-point 2337 * values from being converted to integers unintentionally. Check for 2338 * ASCII specifically to speed up the function. 2339 */ 2340 2341 for (p = dst; *p != 0;) { 2342 if (UCHAR(*p) < 0x80) { 2343 c = *p++; 2344 } else { 2345 p += Tcl_UtfToUniChar(p, &ch); 2346 c = UCHAR(ch); 2347 } 2348 if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ 2349 return; 2350 } 2351 } 2352 p[0] = '.'; 2353 p[1] = '0'; 2354 p[2] = 0; 2355 } 2356} 2357 2358/* 2359 *---------------------------------------------------------------------- 2360 * 2361 * TclPrecTraceProc -- 2362 * 2363 * This function is invoked whenever the variable "tcl_precision" is 2364 * written. 2365 * 2366 * Results: 2367 * Returns NULL if all went well, or an error message if the new value 2368 * for the variable doesn't make sense. 2369 * 2370 * Side effects: 2371 * If the new value doesn't make sense then this function undoes the 2372 * effect of the variable modification. Otherwise it modifies the format 2373 * string that's used by Tcl_PrintDouble. 2374 * 2375 *---------------------------------------------------------------------- 2376 */ 2377 2378 /* ARGSUSED */ 2379char * 2380TclPrecTraceProc( 2381 ClientData clientData, /* Not used. */ 2382 Tcl_Interp *interp, /* Interpreter containing variable. */ 2383 CONST char *name1, /* Name of variable. */ 2384 CONST char *name2, /* Second part of variable name. */ 2385 int flags) /* Information about what happened. */ 2386{ 2387 Tcl_Obj* value; 2388 int prec; 2389 int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); 2390 2391 /* 2392 * If the variable is unset, then recreate the trace. 2393 */ 2394 2395 if (flags & TCL_TRACE_UNSETS) { 2396 if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { 2397 Tcl_TraceVar2(interp, name1, name2, 2398 TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES 2399 |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); 2400 } 2401 return NULL; 2402 } 2403 2404 /* 2405 * When the variable is read, reset its value from our shared value. This 2406 * is needed in case the variable was modified in some other interpreter 2407 * so that this interpreter's value is out of date. 2408 */ 2409 2410 2411 if (flags & TCL_TRACE_READS) { 2412 Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), 2413 flags & TCL_GLOBAL_ONLY); 2414 return NULL; 2415 } 2416 2417 /* 2418 * The variable is being written. Check the new value and disallow it if 2419 * it isn't reasonable or if this is a safe interpreter (we don't want 2420 * safe interpreters messing up the precision of other interpreters). 2421 */ 2422 2423 if (Tcl_IsSafe(interp)) { 2424 return "can't modify precision from a safe interpreter"; 2425 } 2426 value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); 2427 if (value == NULL 2428 || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK 2429 || prec < 0 || prec > TCL_MAX_PREC) { 2430 return "improper value for precision"; 2431 } 2432 *precisionPtr = prec; 2433 return NULL; 2434} 2435 2436/* 2437 *---------------------------------------------------------------------- 2438 * 2439 * TclNeedSpace -- 2440 * 2441 * This function checks to see whether it is appropriate to add a space 2442 * before appending a new list element to an existing string. 2443 * 2444 * Results: 2445 * The return value is 1 if a space is appropriate, 0 otherwise. 2446 * 2447 * Side effects: 2448 * None. 2449 * 2450 *---------------------------------------------------------------------- 2451 */ 2452 2453int 2454TclNeedSpace( 2455 CONST char *start, /* First character in string. */ 2456 CONST char *end) /* End of string (place where space will be 2457 * added, if appropriate). */ 2458{ 2459 /* 2460 * A space is needed unless either: 2461 * (a) we're at the start of the string, or 2462 */ 2463 2464 if (end == start) { 2465 return 0; 2466 } 2467 2468 /* 2469 * (b) we're at the start of a nested list-element, quoted with an open 2470 * curly brace; we can be nested arbitrarily deep, so long as the 2471 * first curly brace starts an element, so backtrack over open curly 2472 * braces that are trailing characters of the string; and 2473 */ 2474 2475 end = Tcl_UtfPrev(end, start); 2476 while (*end == '{') { 2477 if (end == start) { 2478 return 0; 2479 } 2480 end = Tcl_UtfPrev(end, start); 2481 } 2482 2483 /* 2484 * (c) the trailing character of the string is already a list-element 2485 * separator (according to TclFindElement); that is, one of these 2486 * characters: 2487 * \u0009 \t TAB 2488 * \u000A \n NEWLINE 2489 * \u000B \v VERTICAL TAB 2490 * \u000C \f FORM FEED 2491 * \u000D \r CARRIAGE RETURN 2492 * \u0020 SPACE 2493 * with the condition that the penultimate character is not a 2494 * backslash. 2495 */ 2496 2497 if (*end > 0x20) { 2498 /* 2499 * Performance tweak. All ASCII spaces are <= 0x20. So get a quick 2500 * answer for most characters before comparing against all spaces in 2501 * the switch below. 2502 * 2503 * NOTE: Remove this if other Unicode spaces ever get accepted as 2504 * list-element separators. 2505 */ 2506 return 1; 2507 } 2508 switch (*end) { 2509 case ' ': 2510 case '\t': 2511 case '\n': 2512 case '\r': 2513 case '\v': 2514 case '\f': 2515 if ((end == start) || (end[-1] != '\\')) { 2516 return 0; 2517 } 2518 } 2519 return 1; 2520} 2521 2522/* 2523 *---------------------------------------------------------------------- 2524 * 2525 * TclGetIntForIndex -- 2526 * 2527 * This function returns an integer corresponding to the list index held 2528 * in a Tcl object. The Tcl object's value is expected to be in the 2529 * format integer([+-]integer)? or the format end([+-]integer)?. 2530 * 2531 * Results: 2532 * The return value is normally TCL_OK, which means that the index was 2533 * successfully stored into the location referenced by "indexPtr". If the 2534 * Tcl object referenced by "objPtr" has the value "end", the value 2535 * stored is "endValue". If "objPtr"s values is not of one of the 2536 * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, 2537 * an error message is left in the interpreter's result object. 2538 * 2539 * Side effects: 2540 * The object referenced by "objPtr" might be converted to an integer, 2541 * wide integer, or end-based-index object. 2542 * 2543 *---------------------------------------------------------------------- 2544 */ 2545 2546int 2547TclGetIntForIndex( 2548 Tcl_Interp *interp, /* Interpreter to use for error reporting. If 2549 * NULL, then no error message is left after 2550 * errors. */ 2551 Tcl_Obj *objPtr, /* Points to an object containing either "end" 2552 * or an integer. */ 2553 int endValue, /* The value to be stored at "indexPtr" if 2554 * "objPtr" holds "end". */ 2555 int *indexPtr) /* Location filled in with an integer 2556 * representing an index. */ 2557{ 2558 int length; 2559 char *opPtr, *bytes; 2560 2561 if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { 2562 return TCL_OK; 2563 } 2564 2565 if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { 2566 /* 2567 * If the object is already an offset from the end of the list, or can 2568 * be converted to one, use it. 2569 */ 2570 2571 *indexPtr = endValue + objPtr->internalRep.longValue; 2572 return TCL_OK; 2573 } 2574 2575 bytes = TclGetStringFromObj(objPtr, &length); 2576 2577 /* 2578 * Leading whitespace is acceptable in an index. 2579 */ 2580 2581 while (length && isspace(UCHAR(*bytes))) { /* INTL: ISO space. */ 2582 bytes++; 2583 length--; 2584 } 2585 2586 if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, 2587 TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { 2588 int code, first, second; 2589 char savedOp = *opPtr; 2590 2591 if ((savedOp != '+') && (savedOp != '-')) { 2592 goto parseError; 2593 } 2594 if (isspace(UCHAR(opPtr[1]))) { 2595 goto parseError; 2596 } 2597 *opPtr = '\0'; 2598 code = Tcl_GetInt(interp, bytes, &first); 2599 *opPtr = savedOp; 2600 if (code == TCL_ERROR) { 2601 goto parseError; 2602 } 2603 if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { 2604 goto parseError; 2605 } 2606 if (savedOp == '+') { 2607 *indexPtr = first + second; 2608 } else { 2609 *indexPtr = first - second; 2610 } 2611 return TCL_OK; 2612 } 2613 2614 /* 2615 * Report a parse error. 2616 */ 2617 2618 parseError: 2619 if (interp != NULL) { 2620 char *bytes = Tcl_GetString(objPtr); 2621 2622 /* 2623 * The result might not be empty; this resets it which should be both 2624 * a cheap operation, and of little problem because this is an 2625 * error-generation path anyway. 2626 */ 2627 2628 Tcl_ResetResult(interp); 2629 Tcl_AppendResult(interp, "bad index \"", bytes, 2630 "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); 2631 if (!strncmp(bytes, "end-", 4)) { 2632 bytes += 4; 2633 } 2634 TclCheckBadOctal(interp, bytes); 2635 } 2636 2637 return TCL_ERROR; 2638} 2639 2640/* 2641 *---------------------------------------------------------------------- 2642 * 2643 * UpdateStringOfEndOffset -- 2644 * 2645 * Update the string rep of a Tcl object holding an "end-offset" 2646 * expression. 2647 * 2648 * Results: 2649 * None. 2650 * 2651 * Side effects: 2652 * Stores a valid string in the object's string rep. 2653 * 2654 * This function does NOT free any earlier string rep. If it is called on an 2655 * object that already has a valid string rep, it will leak memory. 2656 * 2657 *---------------------------------------------------------------------- 2658 */ 2659 2660static void 2661UpdateStringOfEndOffset( 2662 register Tcl_Obj* objPtr) 2663{ 2664 char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; 2665 register int len; 2666 2667 strcpy(buffer, "end"); 2668 len = sizeof("end") - 1; 2669 if (objPtr->internalRep.longValue != 0) { 2670 buffer[len++] = '-'; 2671 len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); 2672 } 2673 objPtr->bytes = ckalloc((unsigned) len+1); 2674 memcpy(objPtr->bytes, buffer, (unsigned) len+1); 2675 objPtr->length = len; 2676} 2677 2678/* 2679 *---------------------------------------------------------------------- 2680 * 2681 * SetEndOffsetFromAny -- 2682 * 2683 * Look for a string of the form "end[+-]offset" and convert it to an 2684 * internal representation holding the offset. 2685 * 2686 * Results: 2687 * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. 2688 * 2689 * Side effects: 2690 * If interp is not NULL, stores an error message in the interpreter 2691 * result. 2692 * 2693 *---------------------------------------------------------------------- 2694 */ 2695 2696static int 2697SetEndOffsetFromAny( 2698 Tcl_Interp *interp, /* Tcl interpreter or NULL */ 2699 Tcl_Obj *objPtr) /* Pointer to the object to parse */ 2700{ 2701 int offset; /* Offset in the "end-offset" expression */ 2702 register char* bytes; /* String rep of the object */ 2703 int length; /* Length of the object's string rep */ 2704 2705 /* 2706 * If it's already the right type, we're fine. 2707 */ 2708 2709 if (objPtr->typePtr == &tclEndOffsetType) { 2710 return TCL_OK; 2711 } 2712 2713 /* 2714 * Check for a string rep of the right form. 2715 */ 2716 2717 bytes = TclGetStringFromObj(objPtr, &length); 2718 if ((*bytes != 'e') || (strncmp(bytes, "end", 2719 (size_t)((length > 3) ? 3 : length)) != 0)) { 2720 if (interp != NULL) { 2721 Tcl_ResetResult(interp); 2722 Tcl_AppendResult(interp, "bad index \"", bytes, 2723 "\": must be end?[+-]integer?", NULL); 2724 } 2725 return TCL_ERROR; 2726 } 2727 2728 /* 2729 * Convert the string rep. 2730 */ 2731 2732 if (length <= 3) { 2733 offset = 0; 2734 } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { 2735 /* 2736 * This is our limited string expression evaluator. Pass everything 2737 * after "end-" to Tcl_GetInt, then reverse for offset. 2738 */ 2739 2740 if (isspace(UCHAR(bytes[4]))) { 2741 return TCL_ERROR; 2742 } 2743 if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { 2744 return TCL_ERROR; 2745 } 2746 if (bytes[3] == '-') { 2747 offset = -offset; 2748 } 2749 } else { 2750 /* 2751 * Conversion failed. Report the error. 2752 */ 2753 2754 if (interp != NULL) { 2755 Tcl_ResetResult(interp); 2756 Tcl_AppendResult(interp, "bad index \"", bytes, 2757 "\": must be end?[+-]integer?", NULL); 2758 } 2759 return TCL_ERROR; 2760 } 2761 2762 /* 2763 * The conversion succeeded. Free the old internal rep and set the new 2764 * one. 2765 */ 2766 2767 TclFreeIntRep(objPtr); 2768 objPtr->internalRep.longValue = offset; 2769 objPtr->typePtr = &tclEndOffsetType; 2770 2771 return TCL_OK; 2772} 2773 2774/* 2775 *---------------------------------------------------------------------- 2776 * 2777 * TclCheckBadOctal -- 2778 * 2779 * This function checks for a bad octal value and appends a meaningful 2780 * error to the interp's result. 2781 * 2782 * Results: 2783 * 1 if the argument was a bad octal, else 0. 2784 * 2785 * Side effects: 2786 * The interpreter's result is modified. 2787 * 2788 *---------------------------------------------------------------------- 2789 */ 2790 2791int 2792TclCheckBadOctal( 2793 Tcl_Interp *interp, /* Interpreter to use for error reporting. If 2794 * NULL, then no error message is left after 2795 * errors. */ 2796 CONST char *value) /* String to check. */ 2797{ 2798 register CONST char *p = value; 2799 2800 /* 2801 * A frequent mistake is invalid octal values due to an unwanted leading 2802 * zero. Try to generate a meaningful error message. 2803 */ 2804 2805 while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2806 p++; 2807 } 2808 if (*p == '+' || *p == '-') { 2809 p++; 2810 } 2811 if (*p == '0') { 2812 if ((p[1] == 'o') || p[1] == 'O') { 2813 p+=2; 2814 } 2815 while (isdigit(UCHAR(*p))) { /* INTL: digit. */ 2816 p++; 2817 } 2818 while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2819 p++; 2820 } 2821 if (*p == '\0') { 2822 /* 2823 * Reached end of string. 2824 */ 2825 2826 if (interp != NULL) { 2827 /* 2828 * Don't reset the result here because we want this result to 2829 * be added to an existing error message as extra info. 2830 */ 2831 2832 Tcl_AppendResult(interp, " (looks like invalid octal number)", 2833 NULL); 2834 } 2835 return 1; 2836 } 2837 } 2838 return 0; 2839} 2840 2841/* 2842 *---------------------------------------------------------------------- 2843 * 2844 * ClearHash -- 2845 * 2846 * Remove all the entries in the hash table *tablePtr. 2847 * 2848 *---------------------------------------------------------------------- 2849 */ 2850 2851static void 2852ClearHash( 2853 Tcl_HashTable *tablePtr) 2854{ 2855 Tcl_HashSearch search; 2856 Tcl_HashEntry *hPtr; 2857 2858 for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; 2859 hPtr = Tcl_NextHashEntry(&search)) { 2860 Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); 2861 Tcl_DecrRefCount(objPtr); 2862 Tcl_DeleteHashEntry(hPtr); 2863 } 2864} 2865 2866/* 2867 *---------------------------------------------------------------------- 2868 * 2869 * GetThreadHash -- 2870 * 2871 * Get a thread-specific (Tcl_HashTable *) associated with a thread data 2872 * key. 2873 * 2874 * Results: 2875 * The Tcl_HashTable * corresponding to *keyPtr. 2876 * 2877 * Side effects: 2878 * The first call on a keyPtr in each thread creates a new Tcl_HashTable, 2879 * and registers a thread exit handler to dispose of it. 2880 * 2881 *---------------------------------------------------------------------- 2882 */ 2883 2884static Tcl_HashTable * 2885GetThreadHash( 2886 Tcl_ThreadDataKey *keyPtr) 2887{ 2888 Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) 2889 Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *)); 2890 2891 if (NULL == *tablePtrPtr) { 2892 *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); 2893 Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); 2894 Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); 2895 } 2896 return *tablePtrPtr; 2897} 2898 2899/* 2900 *---------------------------------------------------------------------- 2901 * 2902 * FreeThreadHash -- 2903 * 2904 * Thread exit handler used by GetThreadHash to dispose of a thread hash 2905 * table. 2906 * 2907 * Side effects: 2908 * Frees a Tcl_HashTable. 2909 * 2910 *---------------------------------------------------------------------- 2911 */ 2912 2913static void 2914FreeThreadHash( 2915 ClientData clientData) 2916{ 2917 Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; 2918 2919 ClearHash(tablePtr); 2920 Tcl_DeleteHashTable(tablePtr); 2921 ckfree((char *) tablePtr); 2922} 2923 2924/* 2925 *---------------------------------------------------------------------- 2926 * 2927 * FreeProcessGlobalValue -- 2928 * 2929 * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a 2930 * ProcessGlobalValue at exit. 2931 * 2932 *---------------------------------------------------------------------- 2933 */ 2934 2935static void 2936FreeProcessGlobalValue( 2937 ClientData clientData) 2938{ 2939 ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; 2940 2941 pgvPtr->epoch++; 2942 pgvPtr->numBytes = 0; 2943 ckfree(pgvPtr->value); 2944 pgvPtr->value = NULL; 2945 if (pgvPtr->encoding) { 2946 Tcl_FreeEncoding(pgvPtr->encoding); 2947 pgvPtr->encoding = NULL; 2948 } 2949 Tcl_MutexFinalize(&pgvPtr->mutex); 2950} 2951 2952/* 2953 *---------------------------------------------------------------------- 2954 * 2955 * TclSetProcessGlobalValue -- 2956 * 2957 * Utility routine to set a global value shared by all threads in the 2958 * process while keeping a thread-local copy as well. 2959 * 2960 *---------------------------------------------------------------------- 2961 */ 2962 2963void 2964TclSetProcessGlobalValue( 2965 ProcessGlobalValue *pgvPtr, 2966 Tcl_Obj *newValue, 2967 Tcl_Encoding encoding) 2968{ 2969 CONST char *bytes; 2970 Tcl_HashTable *cacheMap; 2971 Tcl_HashEntry *hPtr; 2972 int dummy; 2973 2974 Tcl_MutexLock(&pgvPtr->mutex); 2975 2976 /* 2977 * Fill the global string value. 2978 */ 2979 2980 pgvPtr->epoch++; 2981 if (NULL != pgvPtr->value) { 2982 ckfree(pgvPtr->value); 2983 } else { 2984 Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); 2985 } 2986 bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); 2987 pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1); 2988 memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); 2989 if (pgvPtr->encoding) { 2990 Tcl_FreeEncoding(pgvPtr->encoding); 2991 } 2992 pgvPtr->encoding = encoding; 2993 2994 /* 2995 * Fill the local thread copy directly with the Tcl_Obj value to avoid 2996 * loss of the intrep. Increment newValue refCount early to handle case 2997 * where we set a PGV to itself. 2998 */ 2999 3000 Tcl_IncrRefCount(newValue); 3001 cacheMap = GetThreadHash(&pgvPtr->key); 3002 ClearHash(cacheMap); 3003 hPtr = Tcl_CreateHashEntry(cacheMap, 3004 (char *) INT2PTR(pgvPtr->epoch), &dummy); 3005 Tcl_SetHashValue(hPtr, (ClientData) newValue); 3006 Tcl_MutexUnlock(&pgvPtr->mutex); 3007} 3008 3009/* 3010 *---------------------------------------------------------------------- 3011 * 3012 * TclGetProcessGlobalValue -- 3013 * 3014 * Retrieve a global value shared among all threads of the process, 3015 * preferring a thread-local copy as long as it remains valid. 3016 * 3017 * Results: 3018 * Returns a (Tcl_Obj *) that holds a copy of the global value. 3019 * 3020 *---------------------------------------------------------------------- 3021 */ 3022 3023Tcl_Obj * 3024TclGetProcessGlobalValue( 3025 ProcessGlobalValue *pgvPtr) 3026{ 3027 Tcl_Obj *value = NULL; 3028 Tcl_HashTable *cacheMap; 3029 Tcl_HashEntry *hPtr; 3030 int epoch = pgvPtr->epoch; 3031 3032 if (pgvPtr->encoding) { 3033 Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); 3034 3035 if (pgvPtr->encoding != current) { 3036 /* 3037 * The system encoding has changed since the master string value 3038 * was saved. Convert the master value to be based on the new 3039 * system encoding. 3040 */ 3041 3042 Tcl_DString native, newValue; 3043 3044 Tcl_MutexLock(&pgvPtr->mutex); 3045 pgvPtr->epoch++; 3046 epoch = pgvPtr->epoch; 3047 Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, 3048 pgvPtr->numBytes, &native); 3049 Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), 3050 Tcl_DStringLength(&native), &newValue); 3051 Tcl_DStringFree(&native); 3052 ckfree(pgvPtr->value); 3053 pgvPtr->value = ckalloc((unsigned int) 3054 Tcl_DStringLength(&newValue) + 1); 3055 memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), 3056 (size_t) Tcl_DStringLength(&newValue) + 1); 3057 Tcl_DStringFree(&newValue); 3058 Tcl_FreeEncoding(pgvPtr->encoding); 3059 pgvPtr->encoding = current; 3060 Tcl_MutexUnlock(&pgvPtr->mutex); 3061 } else { 3062 Tcl_FreeEncoding(current); 3063 } 3064 } 3065 cacheMap = GetThreadHash(&pgvPtr->key); 3066 hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); 3067 if (NULL == hPtr) { 3068 int dummy; 3069 3070 /* 3071 * No cache for the current epoch - must be a new one. 3072 * 3073 * First, clear the cacheMap, as anything in it must refer to some 3074 * expired epoch. 3075 */ 3076 3077 ClearHash(cacheMap); 3078 3079 /* 3080 * If no thread has set the shared value, call the initializer. 3081 */ 3082 3083 Tcl_MutexLock(&pgvPtr->mutex); 3084 if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { 3085 pgvPtr->epoch++; 3086 (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, 3087 &pgvPtr->encoding); 3088 if (pgvPtr->value == NULL) { 3089 Tcl_Panic("PGV Initializer did not initialize"); 3090 } 3091 Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData)pgvPtr); 3092 } 3093 3094 /* 3095 * Store a copy of the shared value in our epoch-indexed cache. 3096 */ 3097 3098 value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); 3099 hPtr = Tcl_CreateHashEntry(cacheMap, 3100 (char *) INT2PTR(pgvPtr->epoch), &dummy); 3101 Tcl_MutexUnlock(&pgvPtr->mutex); 3102 Tcl_SetHashValue(hPtr, (ClientData) value); 3103 Tcl_IncrRefCount(value); 3104 } 3105 return (Tcl_Obj *) Tcl_GetHashValue(hPtr); 3106} 3107 3108/* 3109 *---------------------------------------------------------------------- 3110 * 3111 * TclSetObjNameOfExecutable -- 3112 * 3113 * This function stores the absolute pathname of the executable file 3114 * (normally as computed by TclpFindExecutable). 3115 * 3116 * Results: 3117 * None. 3118 * 3119 * Side effects: 3120 * Stores the executable name. 3121 * 3122 *---------------------------------------------------------------------- 3123 */ 3124 3125void 3126TclSetObjNameOfExecutable( 3127 Tcl_Obj *name, 3128 Tcl_Encoding encoding) 3129{ 3130 TclSetProcessGlobalValue(&executableName, name, encoding); 3131} 3132 3133/* 3134 *---------------------------------------------------------------------- 3135 * 3136 * TclGetObjNameOfExecutable -- 3137 * 3138 * This function retrieves the absolute pathname of the application in 3139 * which the Tcl library is running, usually as previously stored by 3140 * TclpFindExecutable(). This function call is the C API equivalent to 3141 * the "info nameofexecutable" command. 3142 * 3143 * Results: 3144 * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the 3145 * pathname of the application is unknown. 3146 * 3147 * Side effects: 3148 * None. 3149 * 3150 *---------------------------------------------------------------------- 3151 */ 3152 3153Tcl_Obj * 3154TclGetObjNameOfExecutable(void) 3155{ 3156 return TclGetProcessGlobalValue(&executableName); 3157} 3158 3159/* 3160 *---------------------------------------------------------------------- 3161 * 3162 * Tcl_GetNameOfExecutable -- 3163 * 3164 * This function retrieves the absolute pathname of the application in 3165 * which the Tcl library is running, and returns it in string form. 3166 * 3167 * The returned string belongs to Tcl and should be copied if the caller 3168 * plans to keep it, to guard against it becoming invalid. 3169 * 3170 * Results: 3171 * A pointer to the internal string or NULL if the internal full path 3172 * name has not been computed or unknown. 3173 * 3174 * Side effects: 3175 * None. 3176 * 3177 *---------------------------------------------------------------------- 3178 */ 3179 3180CONST char * 3181Tcl_GetNameOfExecutable(void) 3182{ 3183 int numBytes; 3184 const char *bytes = 3185 Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); 3186 3187 if (numBytes == 0) { 3188 return NULL; 3189 } 3190 return bytes; 3191} 3192 3193/* 3194 *---------------------------------------------------------------------- 3195 * 3196 * TclpGetTime -- 3197 * 3198 * Deprecated synonym for Tcl_GetTime. This function is provided for the 3199 * benefit of extensions written before Tcl_GetTime was exported from the 3200 * library. 3201 * 3202 * Results: 3203 * None. 3204 * 3205 * Side effects: 3206 * Stores current time in the buffer designated by "timePtr" 3207 * 3208 *---------------------------------------------------------------------- 3209 */ 3210 3211void 3212TclpGetTime( 3213 Tcl_Time *timePtr) 3214{ 3215 Tcl_GetTime(timePtr); 3216} 3217 3218/* 3219 *---------------------------------------------------------------------- 3220 * 3221 * TclGetPlatform -- 3222 * 3223 * This is a kludge that allows the test library to get access the 3224 * internal tclPlatform variable. 3225 * 3226 * Results: 3227 * Returns a pointer to the tclPlatform variable. 3228 * 3229 * Side effects: 3230 * None. 3231 * 3232 *---------------------------------------------------------------------- 3233 */ 3234 3235TclPlatformType * 3236TclGetPlatform(void) 3237{ 3238 return &tclPlatform; 3239} 3240 3241/* 3242 *---------------------------------------------------------------------- 3243 * 3244 * TclReToGlob -- 3245 * 3246 * Attempt to convert a regular expression to an equivalent glob pattern. 3247 * 3248 * Results: 3249 * Returns TCL_OK on success, TCL_ERROR on failure. If interp is not 3250 * NULL, an error message is placed in the result. On success, the 3251 * DString will contain an exact equivalent glob pattern. The caller is 3252 * responsible for calling Tcl_DStringFree on success. If exactPtr is not 3253 * NULL, it will be 1 if an exact match qualifies. 3254 * 3255 * Side effects: 3256 * None. 3257 * 3258 *---------------------------------------------------------------------- 3259 */ 3260 3261int 3262TclReToGlob( 3263 Tcl_Interp *interp, 3264 const char *reStr, 3265 int reStrLen, 3266 Tcl_DString *dsPtr, 3267 int *exactPtr) 3268{ 3269 int anchorLeft, anchorRight, lastIsStar; 3270 char *dsStr, *dsStrStart, *msg; 3271 const char *p, *strEnd; 3272 3273 strEnd = reStr + reStrLen; 3274 Tcl_DStringInit(dsPtr); 3275 3276 /* 3277 * "***=xxx" == "*xxx*", watch for glob-sensitive chars. 3278 */ 3279 3280 if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { 3281 /* 3282 * At most, the glob pattern has length 2*reStrLen + 2 to 3283 * backslash escape every character and have * at each end. 3284 */ 3285 Tcl_DStringSetLength(dsPtr, 2*reStrLen + 2); 3286 dsStr = dsStrStart = Tcl_DStringValue(dsPtr); 3287 *dsStr++ = '*'; 3288 for (p = reStr + 4; p < strEnd; p++) { 3289 switch (*p) { 3290 case '\\': case '*': case '[': case ']': case '?': 3291 /* Only add \ where necessary for glob */ 3292 *dsStr++ = '\\'; 3293 /* fall through */ 3294 default: 3295 *dsStr++ = *p; 3296 break; 3297 } 3298 } 3299 *dsStr++ = '*'; 3300 Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart); 3301 if (exactPtr) { 3302 *exactPtr = 0; 3303 } 3304 return TCL_OK; 3305 } 3306 3307 /* 3308 * At most, the glob pattern has length reStrLen + 2 to account 3309 * for possible * at each end. 3310 */ 3311 3312 Tcl_DStringSetLength(dsPtr, reStrLen + 2); 3313 dsStr = dsStrStart = Tcl_DStringValue(dsPtr); 3314 3315 /* 3316 * Check for anchored REs (ie ^foo$), so we can use string equal if 3317 * possible. Do not alter the start of str so we can free it correctly. 3318 * 3319 * Keep track of the last char being an unescaped star to prevent 3320 * multiple instances. Simpler than checking that the last star 3321 * may be escaped. 3322 */ 3323 3324 msg = NULL; 3325 p = reStr; 3326 anchorRight = 0; 3327 lastIsStar = 0; 3328 3329 if (*p == '^') { 3330 anchorLeft = 1; 3331 p++; 3332 } else { 3333 anchorLeft = 0; 3334 *dsStr++ = '*'; 3335 lastIsStar = 1; 3336 } 3337 3338 for ( ; p < strEnd; p++) { 3339 switch (*p) { 3340 case '\\': 3341 p++; 3342 switch (*p) { 3343 case 'a': 3344 *dsStr++ = '\a'; 3345 break; 3346 case 'b': 3347 *dsStr++ = '\b'; 3348 break; 3349 case 'f': 3350 *dsStr++ = '\f'; 3351 break; 3352 case 'n': 3353 *dsStr++ = '\n'; 3354 break; 3355 case 'r': 3356 *dsStr++ = '\r'; 3357 break; 3358 case 't': 3359 *dsStr++ = '\t'; 3360 break; 3361 case 'v': 3362 *dsStr++ = '\v'; 3363 break; 3364 case 'B': case '\\': 3365 *dsStr++ = '\\'; 3366 *dsStr++ = '\\'; 3367 anchorLeft = 0; /* prevent exact match */ 3368 break; 3369 case '*': case '[': case ']': case '?': 3370 /* Only add \ where necessary for glob */ 3371 *dsStr++ = '\\'; 3372 anchorLeft = 0; /* prevent exact match */ 3373 /* fall through */ 3374 case '{': case '}': case '(': case ')': case '+': 3375 case '.': case '|': case '^': case '$': 3376 *dsStr++ = *p; 3377 break; 3378 default: 3379 msg = "invalid escape sequence"; 3380 goto invalidGlob; 3381 } 3382 break; 3383 case '.': 3384 anchorLeft = 0; /* prevent exact match */ 3385 if (p+1 < strEnd) { 3386 if (p[1] == '*') { 3387 p++; 3388 if (!lastIsStar) { 3389 *dsStr++ = '*'; 3390 lastIsStar = 1; 3391 } 3392 continue; 3393 } else if (p[1] == '+') { 3394 p++; 3395 *dsStr++ = '?'; 3396 *dsStr++ = '*'; 3397 lastIsStar = 1; 3398 continue; 3399 } 3400 } 3401 *dsStr++ = '?'; 3402 break; 3403 case '$': 3404 if (p+1 != strEnd) { 3405 msg = "$ not anchor"; 3406 goto invalidGlob; 3407 } 3408 anchorRight = 1; 3409 break; 3410 case '*': case '+': case '?': case '|': case '^': 3411 case '{': case '}': case '(': case ')': case '[': case ']': 3412 msg = "unhandled RE special char"; 3413 goto invalidGlob; 3414 break; 3415 default: 3416 *dsStr++ = *p; 3417 break; 3418 } 3419 lastIsStar = 0; 3420 } 3421 if (!anchorRight && !lastIsStar) { 3422 *dsStr++ = '*'; 3423 } 3424 Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart); 3425 3426 if (exactPtr) { 3427 *exactPtr = (anchorLeft && anchorRight); 3428 } 3429 3430#if 0 3431 fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", 3432 reStrLen, reStr, 3433 Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); 3434 fflush(stderr); 3435#endif 3436 return TCL_OK; 3437 3438 invalidGlob: 3439#if 0 3440 fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", 3441 reStrLen, reStr, msg, *p); 3442 fflush(stderr); 3443#endif 3444 if (interp != NULL) { 3445 Tcl_AppendResult(interp, msg, NULL); 3446 } 3447 Tcl_DStringFree(dsPtr); 3448 return TCL_ERROR; 3449} 3450 3451/* 3452 * Local Variables: 3453 * mode: c 3454 * c-basic-offset: 4 3455 * fill-column: 78 3456 * End: 3457 */ 3458