/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclscan.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclscan.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25