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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 44 - (hide annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (8 years ago) by dashley
File MIME type: text/plain
File size: 26462 byte(s)
Rename for reorganization.
1 dashley 25 /* $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