1/* 2 * tclScan.c -- 3 * 4 * This file contains the implementation of the "scan" command. 5 * 6 * Copyright (c) 1998 by Scriptics Corporation. 7 * 8 * See the file "license.terms" for information on usage and redistribution of 9 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 * 11 * RCS: @(#) $Id: tclScan.c,v 1.27.2.1 2009/07/16 20:50:54 dgp Exp $ 12 */ 13 14#include "tclInt.h" 15 16/* 17 * Flag values used by Tcl_ScanObjCmd. 18 */ 19 20#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ 21#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ 22#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ 23#define SCAN_WIDTH 0x8 /* A width value was supplied. */ 24 25#define SCAN_LONGER 0x400 /* Asked for a wide value. */ 26#define SCAN_BIG 0x800 /* Asked for a bignum value. */ 27 28/* 29 * The following structure contains the information associated with a 30 * character set. 31 */ 32 33typedef struct CharSet { 34 int exclude; /* 1 if this is an exclusion set. */ 35 int nchars; 36 Tcl_UniChar *chars; 37 int nranges; 38 struct Range { 39 Tcl_UniChar start; 40 Tcl_UniChar end; 41 } *ranges; 42} CharSet; 43 44/* 45 * Declarations for functions used only in this file. 46 */ 47 48static char * BuildCharSet(CharSet *cset, char *format); 49static int CharInSet(CharSet *cset, int ch); 50static void ReleaseCharSet(CharSet *cset); 51static int ValidateFormat(Tcl_Interp *interp, char *format, 52 int numVars, int *totalVars); 53 54/* 55 *---------------------------------------------------------------------- 56 * 57 * BuildCharSet -- 58 * 59 * This function examines a character set format specification and builds 60 * a CharSet containing the individual characters and character ranges 61 * specified. 62 * 63 * Results: 64 * Returns the next format position. 65 * 66 * Side effects: 67 * Initializes the charset. 68 * 69 *---------------------------------------------------------------------- 70 */ 71 72static char * 73BuildCharSet( 74 CharSet *cset, 75 char *format) /* Points to first char of set. */ 76{ 77 Tcl_UniChar ch, start; 78 int offset, nranges; 79 char *end; 80 81 memset(cset, 0, sizeof(CharSet)); 82 83 offset = Tcl_UtfToUniChar(format, &ch); 84 if (ch == '^') { 85 cset->exclude = 1; 86 format += offset; 87 offset = Tcl_UtfToUniChar(format, &ch); 88 } 89 end = format + offset; 90 91 /* 92 * Find the close bracket so we can overallocate the set. 93 */ 94 95 if (ch == ']') { 96 end += Tcl_UtfToUniChar(end, &ch); 97 } 98 nranges = 0; 99 while (ch != ']') { 100 if (ch == '-') { 101 nranges++; 102 } 103 end += Tcl_UtfToUniChar(end, &ch); 104 } 105 106 cset->chars = (Tcl_UniChar *) 107 ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); 108 if (nranges > 0) { 109 cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges); 110 } else { 111 cset->ranges = NULL; 112 } 113 114 /* 115 * Now build the character set. 116 */ 117 118 cset->nchars = cset->nranges = 0; 119 format += Tcl_UtfToUniChar(format, &ch); 120 start = ch; 121 if (ch == ']' || ch == '-') { 122 cset->chars[cset->nchars++] = ch; 123 format += Tcl_UtfToUniChar(format, &ch); 124 } 125 while (ch != ']') { 126 if (*format == '-') { 127 /* 128 * This may be the first character of a range, so don't add it 129 * yet. 130 */ 131 132 start = ch; 133 } else if (ch == '-') { 134 /* 135 * Check to see if this is the last character in the set, in which 136 * case it is not a range and we should add the previous character 137 * as well as the dash. 138 */ 139 140 if (*format == ']') { 141 cset->chars[cset->nchars++] = start; 142 cset->chars[cset->nchars++] = ch; 143 } else { 144 format += Tcl_UtfToUniChar(format, &ch); 145 146 /* 147 * Check to see if the range is in reverse order. 148 */ 149 150 if (start < ch) { 151 cset->ranges[cset->nranges].start = start; 152 cset->ranges[cset->nranges].end = ch; 153 } else { 154 cset->ranges[cset->nranges].start = ch; 155 cset->ranges[cset->nranges].end = start; 156 } 157 cset->nranges++; 158 } 159 } else { 160 cset->chars[cset->nchars++] = ch; 161 } 162 format += Tcl_UtfToUniChar(format, &ch); 163 } 164 return format; 165} 166 167/* 168 *---------------------------------------------------------------------- 169 * 170 * CharInSet -- 171 * 172 * Check to see if a character matches the given set. 173 * 174 * Results: 175 * Returns non-zero if the character matches the given set. 176 * 177 * Side effects: 178 * None. 179 * 180 *---------------------------------------------------------------------- 181 */ 182 183static int 184CharInSet( 185 CharSet *cset, 186 int c) /* Character to test, passed as int because of 187 * non-ANSI prototypes. */ 188{ 189 Tcl_UniChar ch = (Tcl_UniChar) c; 190 int i, match = 0; 191 192 for (i = 0; i < cset->nchars; i++) { 193 if (cset->chars[i] == ch) { 194 match = 1; 195 break; 196 } 197 } 198 if (!match) { 199 for (i = 0; i < cset->nranges; i++) { 200 if ((cset->ranges[i].start <= ch) && (ch <= cset->ranges[i].end)) { 201 match = 1; 202 break; 203 } 204 } 205 } 206 return (cset->exclude ? !match : match); 207} 208 209/* 210 *---------------------------------------------------------------------- 211 * 212 * ReleaseCharSet -- 213 * 214 * Free the storage associated with a character set. 215 * 216 * Results: 217 * None. 218 * 219 * Side effects: 220 * None. 221 * 222 *---------------------------------------------------------------------- 223 */ 224 225static void 226ReleaseCharSet( 227 CharSet *cset) 228{ 229 ckfree((char *)cset->chars); 230 if (cset->ranges) { 231 ckfree((char *)cset->ranges); 232 } 233} 234 235/* 236 *---------------------------------------------------------------------- 237 * 238 * ValidateFormat -- 239 * 240 * Parse the format string and verify that it is properly formed and that 241 * there are exactly enough variables on the command line. 242 * 243 * Results: 244 * A standard Tcl result. 245 * 246 * Side effects: 247 * May place an error in the interpreter result. 248 * 249 *---------------------------------------------------------------------- 250 */ 251 252static int 253ValidateFormat( 254 Tcl_Interp *interp, /* Current interpreter. */ 255 char *format, /* The format string. */ 256 int numVars, /* The number of variables passed to the scan 257 * command. */ 258 int *totalSubs) /* The number of variables that will be 259 * required. */ 260{ 261 int gotXpg, gotSequential, value, i, flags; 262 char *end; 263 Tcl_UniChar ch; 264 int objIndex, xpgSize, nspace = numVars; 265 int *nassign = (int *) TclStackAlloc(interp, nspace * sizeof(int)); 266 char buf[TCL_UTF_MAX+1]; 267 268 /* 269 * Initialize an array that records the number of times a variable is 270 * assigned to by the format string. We use this to detect if a variable 271 * is multiply assigned or left unassigned. 272 */ 273 274 for (i = 0; i < nspace; i++) { 275 nassign[i] = 0; 276 } 277 278 xpgSize = objIndex = gotXpg = gotSequential = 0; 279 280 while (*format != '\0') { 281 format += Tcl_UtfToUniChar(format, &ch); 282 283 flags = 0; 284 285 if (ch != '%') { 286 continue; 287 } 288 format += Tcl_UtfToUniChar(format, &ch); 289 if (ch == '%') { 290 continue; 291 } 292 if (ch == '*') { 293 flags |= SCAN_SUPPRESS; 294 format += Tcl_UtfToUniChar(format, &ch); 295 goto xpgCheckDone; 296 } 297 298 if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ 299 /* 300 * Check for an XPG3-style %n$ specification. Note: there must 301 * not be a mixture of XPG3 specs and non-XPG3 specs in the same 302 * format string. 303 */ 304 305 value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ 306 if (*end != '$') { 307 goto notXpg; 308 } 309 format = end+1; 310 format += Tcl_UtfToUniChar(format, &ch); 311 gotXpg = 1; 312 if (gotSequential) { 313 goto mixedXPG; 314 } 315 objIndex = value - 1; 316 if ((objIndex < 0) || (numVars && (objIndex >= numVars))) { 317 goto badIndex; 318 } else if (numVars == 0) { 319 /* 320 * In the case where no vars are specified, the user can 321 * specify %9999$ legally, so we have to consider special 322 * rules for growing the assign array. 'value' is guaranteed 323 * to be > 0. 324 */ 325 xpgSize = (xpgSize > value) ? xpgSize : value; 326 } 327 goto xpgCheckDone; 328 } 329 330 notXpg: 331 gotSequential = 1; 332 if (gotXpg) { 333 mixedXPG: 334 Tcl_SetResult(interp, 335 "cannot mix \"%\" and \"%n$\" conversion specifiers", 336 TCL_STATIC); 337 goto error; 338 } 339 340 xpgCheckDone: 341 /* 342 * Parse any width specifier. 343 */ 344 345 if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ 346 value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ 347 flags |= SCAN_WIDTH; 348 format += Tcl_UtfToUniChar(format, &ch); 349 } 350 351 /* 352 * Handle any size specifier. 353 */ 354 355 switch (ch) { 356 case 'l': 357 if (*format == 'l') { 358 flags |= SCAN_BIG; 359 format += 1; 360 format += Tcl_UtfToUniChar(format, &ch); 361 break; 362 } 363 case 'L': 364 flags |= SCAN_LONGER; 365 case 'h': 366 format += Tcl_UtfToUniChar(format, &ch); 367 } 368 369 if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { 370 goto badIndex; 371 } 372 373 /* 374 * Handle the various field types. 375 */ 376 377 switch (ch) { 378 case 'c': 379 if (flags & SCAN_WIDTH) { 380 Tcl_SetResult(interp, 381 "field width may not be specified in %c conversion", 382 TCL_STATIC); 383 goto error; 384 } 385 /* 386 * Fall through! 387 */ 388 case 'n': 389 case 's': 390 if (flags & (SCAN_LONGER|SCAN_BIG)) { 391 invalidFieldSize: 392 buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; 393 Tcl_AppendResult(interp, 394 "field size modifier may not be specified in %", buf, 395 " conversion", NULL); 396 goto error; 397 } 398 /* 399 * Fall through! 400 */ 401 case 'd': 402 case 'e': 403 case 'f': 404 case 'g': 405 case 'i': 406 case 'o': 407 case 'x': 408 break; 409 case 'u': 410 if (flags & SCAN_BIG) { 411 Tcl_SetResult(interp, 412 "unsigned bignum scans are invalid", TCL_STATIC); 413 goto error; 414 } 415 break; 416 /* 417 * Bracket terms need special checking 418 */ 419 case '[': 420 if (flags & (SCAN_LONGER|SCAN_BIG)) { 421 goto invalidFieldSize; 422 } 423 if (*format == '\0') { 424 goto badSet; 425 } 426 format += Tcl_UtfToUniChar(format, &ch); 427 if (ch == '^') { 428 if (*format == '\0') { 429 goto badSet; 430 } 431 format += Tcl_UtfToUniChar(format, &ch); 432 } 433 if (ch == ']') { 434 if (*format == '\0') { 435 goto badSet; 436 } 437 format += Tcl_UtfToUniChar(format, &ch); 438 } 439 while (ch != ']') { 440 if (*format == '\0') { 441 goto badSet; 442 } 443 format += Tcl_UtfToUniChar(format, &ch); 444 } 445 break; 446 badSet: 447 Tcl_SetResult(interp, "unmatched [ in format string", 448 TCL_STATIC); 449 goto error; 450 default: 451 { 452 char buf[TCL_UTF_MAX+1]; 453 454 buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; 455 Tcl_AppendResult(interp, "bad scan conversion character \"", 456 buf, "\"", NULL); 457 goto error; 458 } 459 } 460 if (!(flags & SCAN_SUPPRESS)) { 461 if (objIndex >= nspace) { 462 /* 463 * Expand the nassign buffer. If we are using XPG specifiers, 464 * make sure that we grow to a large enough size. xpgSize is 465 * guaranteed to be at least one larger than objIndex. 466 */ 467 468 value = nspace; 469 if (xpgSize) { 470 nspace = xpgSize; 471 } else { 472 nspace += 16; /* formerly STATIC_LIST_SIZE */ 473 } 474 nassign = (int *) TclStackRealloc(interp, nassign, 475 nspace * sizeof(int)); 476 for (i = value; i < nspace; i++) { 477 nassign[i] = 0; 478 } 479 } 480 nassign[objIndex]++; 481 objIndex++; 482 } 483 } 484 485 /* 486 * Verify that all of the variable were assigned exactly once. 487 */ 488 489 if (numVars == 0) { 490 if (xpgSize) { 491 numVars = xpgSize; 492 } else { 493 numVars = objIndex; 494 } 495 } 496 if (totalSubs) { 497 *totalSubs = numVars; 498 } 499 for (i = 0; i < numVars; i++) { 500 if (nassign[i] > 1) { 501 Tcl_SetResult(interp, 502 "variable is assigned by multiple \"%n$\" conversion specifiers", 503 TCL_STATIC); 504 goto error; 505 } else if (!xpgSize && (nassign[i] == 0)) { 506 /* 507 * If the space is empty, and xpgSize is 0 (means XPG wasn't used, 508 * and/or numVars != 0), then too many vars were given 509 */ 510 511 Tcl_SetResult(interp, 512 "variable is not assigned by any conversion specifiers", 513 TCL_STATIC); 514 goto error; 515 } 516 } 517 518 TclStackFree(interp, nassign); 519 return TCL_OK; 520 521 badIndex: 522 if (gotXpg) { 523 Tcl_SetResult(interp, "\"%n$\" argument index out of range", 524 TCL_STATIC); 525 } else { 526 Tcl_SetResult(interp, 527 "different numbers of variable names and field specifiers", 528 TCL_STATIC); 529 } 530 531 error: 532 TclStackFree(interp, nassign); 533 return TCL_ERROR; 534} 535 536/* 537 *---------------------------------------------------------------------- 538 * 539 * Tcl_ScanObjCmd -- 540 * 541 * This function is invoked to process the "scan" Tcl command. See the 542 * user documentation for details on what it does. 543 * 544 * Results: 545 * A standard Tcl result. 546 * 547 * Side effects: 548 * See the user documentation. 549 * 550 *---------------------------------------------------------------------- 551 */ 552 553 /* ARGSUSED */ 554int 555Tcl_ScanObjCmd( 556 ClientData dummy, /* Not used. */ 557 Tcl_Interp *interp, /* Current interpreter. */ 558 int objc, /* Number of arguments. */ 559 Tcl_Obj *CONST objv[]) /* Argument objects. */ 560{ 561 char *format; 562 int numVars, nconversions, totalVars = -1; 563 int objIndex, offset, i, result, code; 564 long value; 565 CONST char *string, *end, *baseString; 566 char op = 0; 567 int width, underflow = 0; 568 Tcl_WideInt wideValue; 569 Tcl_UniChar ch, sch; 570 Tcl_Obj **objs = NULL, *objPtr = NULL; 571 int flags; 572 char buf[513]; /* Temporary buffer to hold scanned number 573 * strings before they are passed to 574 * strtoul. */ 575 576 if (objc < 3) { 577 Tcl_WrongNumArgs(interp, 1, objv, 578 "string format ?varName varName ...?"); 579 return TCL_ERROR; 580 } 581 582 format = Tcl_GetStringFromObj(objv[2], NULL); 583 numVars = objc-3; 584 585 /* 586 * Check for errors in the format string. 587 */ 588 589 if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { 590 return TCL_ERROR; 591 } 592 593 /* 594 * Allocate space for the result objects. 595 */ 596 597 if (totalVars > 0) { 598 objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars); 599 for (i = 0; i < totalVars; i++) { 600 objs[i] = NULL; 601 } 602 } 603 604 string = Tcl_GetStringFromObj(objv[1], NULL); 605 baseString = string; 606 607 /* 608 * Iterate over the format string filling in the result objects until we 609 * reach the end of input, the end of the format string, or there is a 610 * mismatch. 611 */ 612 613 objIndex = 0; 614 nconversions = 0; 615 while (*format != '\0') { 616 int parseFlag = TCL_PARSE_NO_WHITESPACE; 617 format += Tcl_UtfToUniChar(format, &ch); 618 619 flags = 0; 620 621 /* 622 * If we see whitespace in the format, skip whitespace in the string. 623 */ 624 625 if (Tcl_UniCharIsSpace(ch)) { 626 offset = Tcl_UtfToUniChar(string, &sch); 627 while (Tcl_UniCharIsSpace(sch)) { 628 if (*string == '\0') { 629 goto done; 630 } 631 string += offset; 632 offset = Tcl_UtfToUniChar(string, &sch); 633 } 634 continue; 635 } 636 637 if (ch != '%') { 638 literal: 639 if (*string == '\0') { 640 underflow = 1; 641 goto done; 642 } 643 string += Tcl_UtfToUniChar(string, &sch); 644 if (ch != sch) { 645 goto done; 646 } 647 continue; 648 } 649 650 format += Tcl_UtfToUniChar(format, &ch); 651 if (ch == '%') { 652 goto literal; 653 } 654 655 /* 656 * Check for assignment suppression ('*') or an XPG3-style assignment 657 * ('%n$'). 658 */ 659 660 if (ch == '*') { 661 flags |= SCAN_SUPPRESS; 662 format += Tcl_UtfToUniChar(format, &ch); 663 } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ 664 char *formatEnd; 665 value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ 666 if (*formatEnd == '$') { 667 format = formatEnd+1; 668 format += Tcl_UtfToUniChar(format, &ch); 669 objIndex = (int) value - 1; 670 } 671 } 672 673 /* 674 * Parse any width specifier. 675 */ 676 677 if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ 678 width = (int) strtoul(format-1, &format, 10);/* INTL: "C" locale. */ 679 format += Tcl_UtfToUniChar(format, &ch); 680 } else { 681 width = 0; 682 } 683 684 /* 685 * Handle any size specifier. 686 */ 687 688 switch (ch) { 689 case 'l': 690 if (*format == 'l') { 691 flags |= SCAN_BIG; 692 format += 1; 693 format += Tcl_UtfToUniChar(format, &ch); 694 break; 695 } 696 case 'L': 697 flags |= SCAN_LONGER; 698 /* 699 * Fall through so we skip to the next character. 700 */ 701 case 'h': 702 format += Tcl_UtfToUniChar(format, &ch); 703 } 704 705 /* 706 * Handle the various field types. 707 */ 708 709 switch (ch) { 710 case 'n': 711 if (!(flags & SCAN_SUPPRESS)) { 712 objPtr = Tcl_NewIntObj(string - baseString); 713 Tcl_IncrRefCount(objPtr); 714 objs[objIndex++] = objPtr; 715 } 716 nconversions++; 717 continue; 718 719 case 'd': 720 op = 'i'; 721 parseFlag |= TCL_PARSE_DECIMAL_ONLY; 722 break; 723 case 'i': 724 op = 'i'; 725 parseFlag |= TCL_PARSE_SCAN_PREFIXES; 726 break; 727 case 'o': 728 op = 'i'; 729 parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; 730 break; 731 case 'x': 732 op = 'i'; 733 parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; 734 break; 735 case 'u': 736 op = 'i'; 737 parseFlag |= TCL_PARSE_DECIMAL_ONLY; 738 flags |= SCAN_UNSIGNED; 739 break; 740 741 case 'f': 742 case 'e': 743 case 'g': 744 op = 'f'; 745 break; 746 747 case 's': 748 op = 's'; 749 break; 750 751 case 'c': 752 op = 'c'; 753 flags |= SCAN_NOSKIP; 754 break; 755 case '[': 756 op = '['; 757 flags |= SCAN_NOSKIP; 758 break; 759 } 760 761 /* 762 * At this point, we will need additional characters from the string 763 * to proceed. 764 */ 765 766 if (*string == '\0') { 767 underflow = 1; 768 goto done; 769 } 770 771 /* 772 * Skip any leading whitespace at the beginning of a field unless the 773 * format suppresses this behavior. 774 */ 775 776 if (!(flags & SCAN_NOSKIP)) { 777 while (*string != '\0') { 778 offset = Tcl_UtfToUniChar(string, &sch); 779 if (!Tcl_UniCharIsSpace(sch)) { 780 break; 781 } 782 string += offset; 783 } 784 if (*string == '\0') { 785 underflow = 1; 786 goto done; 787 } 788 } 789 790 /* 791 * Perform the requested scanning operation. 792 */ 793 794 switch (op) { 795 case 's': 796 /* 797 * Scan a string up to width characters or whitespace. 798 */ 799 800 if (width == 0) { 801 width = ~0; 802 } 803 end = string; 804 while (*end != '\0') { 805 offset = Tcl_UtfToUniChar(end, &sch); 806 if (Tcl_UniCharIsSpace(sch)) { 807 break; 808 } 809 end += offset; 810 if (--width == 0) { 811 break; 812 } 813 } 814 if (!(flags & SCAN_SUPPRESS)) { 815 objPtr = Tcl_NewStringObj(string, end-string); 816 Tcl_IncrRefCount(objPtr); 817 objs[objIndex++] = objPtr; 818 } 819 string = end; 820 break; 821 822 case '[': { 823 CharSet cset; 824 825 if (width == 0) { 826 width = ~0; 827 } 828 end = string; 829 830 format = BuildCharSet(&cset, format); 831 while (*end != '\0') { 832 offset = Tcl_UtfToUniChar(end, &sch); 833 if (!CharInSet(&cset, (int)sch)) { 834 break; 835 } 836 end += offset; 837 if (--width == 0) { 838 break; 839 } 840 } 841 ReleaseCharSet(&cset); 842 843 if (string == end) { 844 /* 845 * Nothing matched the range, stop processing. 846 */ 847 goto done; 848 } 849 if (!(flags & SCAN_SUPPRESS)) { 850 objPtr = Tcl_NewStringObj(string, end-string); 851 Tcl_IncrRefCount(objPtr); 852 objs[objIndex++] = objPtr; 853 } 854 string = end; 855 856 break; 857 } 858 case 'c': 859 /* 860 * Scan a single Unicode character. 861 */ 862 863 string += Tcl_UtfToUniChar(string, &sch); 864 if (!(flags & SCAN_SUPPRESS)) { 865 objPtr = Tcl_NewIntObj((int)sch); 866 Tcl_IncrRefCount(objPtr); 867 objs[objIndex++] = objPtr; 868 } 869 break; 870 871 case 'i': 872 /* 873 * Scan an unsigned or signed integer. 874 */ 875 objPtr = Tcl_NewLongObj(0); 876 Tcl_IncrRefCount(objPtr); 877 if (width == 0) { 878 width = ~0; 879 } 880 if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width, 881 &end, TCL_PARSE_INTEGER_ONLY | parseFlag)) { 882 Tcl_DecrRefCount(objPtr); 883 if (width < 0) { 884 if (*end == '\0') { 885 underflow = 1; 886 } 887 } else { 888 if (end == string + width) { 889 underflow = 1; 890 } 891 } 892 goto done; 893 } 894 string = end; 895 if (flags & SCAN_SUPPRESS) { 896 Tcl_DecrRefCount(objPtr); 897 break; 898 } 899 if (flags & SCAN_LONGER) { 900 if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { 901 wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ 902 if (TclGetString(objPtr)[0] == '-') { 903 wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ 904 } 905 } 906 if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { 907 sprintf(buf, "%" TCL_LL_MODIFIER "u", 908 (Tcl_WideUInt)wideValue); 909 Tcl_SetStringObj(objPtr, buf, -1); 910 } else { 911 Tcl_SetWideIntObj(objPtr, wideValue); 912 } 913 } else if (!(flags & SCAN_BIG)) { 914 if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { 915 if (TclGetString(objPtr)[0] == '-') { 916 value = LONG_MIN; 917 } else { 918 value = LONG_MAX; 919 } 920 } 921 if ((flags & SCAN_UNSIGNED) && (value < 0)) { 922 sprintf(buf, "%lu", value); /* INTL: ISO digit */ 923 Tcl_SetStringObj(objPtr, buf, -1); 924 } else { 925 Tcl_SetLongObj(objPtr, value); 926 } 927 } 928 objs[objIndex++] = objPtr; 929 break; 930 931 case 'f': 932 /* 933 * Scan a floating point number 934 */ 935 936 objPtr = Tcl_NewDoubleObj(0.0); 937 Tcl_IncrRefCount(objPtr); 938 if (width == 0) { 939 width = ~0; 940 } 941 if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width, 942 &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) { 943 Tcl_DecrRefCount(objPtr); 944 if (width < 0) { 945 if (*end == '\0') { 946 underflow = 1; 947 } 948 } else { 949 if (end == string + width) { 950 underflow = 1; 951 } 952 } 953 goto done; 954 } else if (flags & SCAN_SUPPRESS) { 955 Tcl_DecrRefCount(objPtr); 956 string = end; 957 } else { 958 double dvalue; 959 if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { 960#ifdef ACCEPT_NAN 961 if (objPtr->typePtr == &tclDoubleType) { 962 dvalue = objPtr->internalRep.doubleValue; 963 } else 964#endif 965 { 966 Tcl_DecrRefCount(objPtr); 967 goto done; 968 } 969 } 970 Tcl_SetDoubleObj(objPtr, dvalue); 971 objs[objIndex++] = objPtr; 972 string = end; 973 } 974 } 975 nconversions++; 976 } 977 978 done: 979 result = 0; 980 code = TCL_OK; 981 982 if (numVars) { 983 /* 984 * In this case, variables were specified (classic scan). 985 */ 986 987 for (i = 0; i < totalVars; i++) { 988 if (objs[i] == NULL) { 989 continue; 990 } 991 result++; 992 if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { 993 Tcl_AppendResult(interp, "couldn't set variable \"", 994 TclGetString(objv[i+3]), "\"", NULL); 995 code = TCL_ERROR; 996 } 997 Tcl_DecrRefCount(objs[i]); 998 } 999 } else { 1000 /* 1001 * Here no vars were specified, we want a list returned (inline scan) 1002 */ 1003 1004 objPtr = Tcl_NewObj(); 1005 for (i = 0; i < totalVars; i++) { 1006 if (objs[i] != NULL) { 1007 Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); 1008 Tcl_DecrRefCount(objs[i]); 1009 } else { 1010 /* 1011 * More %-specifiers than matching chars, so we just spit out 1012 * empty strings for these. 1013 */ 1014 1015 Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); 1016 } 1017 } 1018 } 1019 if (objs != NULL) { 1020 ckfree((char*) objs); 1021 } 1022 if (code == TCL_OK) { 1023 if (underflow && (nconversions == 0)) { 1024 if (numVars) { 1025 objPtr = Tcl_NewIntObj(-1); 1026 } else { 1027 if (objPtr) { 1028 Tcl_SetListObj(objPtr, 0, NULL); 1029 } else { 1030 objPtr = Tcl_NewObj(); 1031 } 1032 } 1033 } else if (numVars) { 1034 objPtr = Tcl_NewIntObj(result); 1035 } 1036 Tcl_SetObjResult(interp, objPtr); 1037 } 1038 return code; 1039} 1040 1041/* 1042 * Local Variables: 1043 * mode: c 1044 * c-basic-offset: 4 1045 * fill-column: 78 1046 * End: 1047 */ 1048