--- projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclscan.c 2016/10/30 21:57:38 66 +++ projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclscan.c 2016/11/05 11:07:06 71 @@ -1,1136 +1,1136 @@ -/* $Header$ */ -/* - * tclScan.c -- - * - * This file contains the implementation of the "scan" command. - * - * Copyright (c) 1998 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclscan.c,v 1.1.1.1 2001/06/13 04:46:00 dtashley Exp $ - */ - -#include "tclInt.h" - -/* - * Flag values used by Tcl_ScanObjCmd. - */ - -#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ -#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ -#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ -#define SCAN_WIDTH 0x8 /* A width value was supplied. */ - -#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ -#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ -#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ -#define SCAN_XOK 0x80 /* An 'x' is allowed. */ -#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ -#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ - - -/* - * The following structure contains the information associated with - * a character set. - */ - -typedef struct CharSet { - int exclude; /* 1 if this is an exclusion set. */ - int nchars; - Tcl_UniChar *chars; - int nranges; - struct Range { - Tcl_UniChar start; - Tcl_UniChar end; - } *ranges; -} CharSet; - -/* - * Declarations for functions used only in this file. - */ - -static char * BuildCharSet _ANSI_ARGS_((CharSet *cset, char *format)); -static int CharInSet _ANSI_ARGS_((CharSet *cset, int ch)); -static void ReleaseCharSet _ANSI_ARGS_((CharSet *cset)); -static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format, - int numVars, int *totalVars)); - -/* - *---------------------------------------------------------------------- - * - * BuildCharSet -- - * - * This function examines a character set format specification - * and builds a CharSet containing the individual characters and - * character ranges specified. - * - * Results: - * Returns the next format position. - * - * Side effects: - * Initializes the charset. - * - *---------------------------------------------------------------------- - */ - -static char * -BuildCharSet(cset, format) - CharSet *cset; - char *format; /* Points to first char of set. */ -{ - Tcl_UniChar ch, start; - int offset, nranges; - char *end; - - memset(cset, 0, sizeof(CharSet)); - - offset = Tcl_UtfToUniChar(format, &ch); - if (ch == '^') { - cset->exclude = 1; - format += offset; - offset = Tcl_UtfToUniChar(format, &ch); - } - end = format + offset; - - /* - * Find the close bracket so we can overallocate the set. - */ - - if (ch == ']') { - end += Tcl_UtfToUniChar(end, &ch); - } - nranges = 0; - while (ch != ']') { - if (ch == '-') { - nranges++; - } - end += Tcl_UtfToUniChar(end, &ch); - } - - cset->chars = (Tcl_UniChar *) ckalloc(sizeof(Tcl_UniChar) - * (end - format - 1)); - if (nranges > 0) { - cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges); - } else { - cset->ranges = NULL; - } - - /* - * Now build the character set. - */ - - cset->nchars = cset->nranges = 0; - format += Tcl_UtfToUniChar(format, &ch); - start = ch; - if (ch == ']' || ch == '-') { - cset->chars[cset->nchars++] = ch; - format += Tcl_UtfToUniChar(format, &ch); - } - while (ch != ']') { - if (*format == '-') { - /* - * This may be the first character of a range, so don't add - * it yet. - */ - - start = ch; - } else if (ch == '-') { - /* - * Check to see if this is the last character in the set, in which - * case it is not a range and we should add the previous character - * as well as the dash. - */ - - if (*format == ']') { - cset->chars[cset->nchars++] = start; - cset->chars[cset->nchars++] = ch; - } else { - format += Tcl_UtfToUniChar(format, &ch); - - /* - * Check to see if the range is in reverse order. - */ - - if (start < ch) { - cset->ranges[cset->nranges].start = start; - cset->ranges[cset->nranges].end = ch; - } else { - cset->ranges[cset->nranges].start = ch; - cset->ranges[cset->nranges].end = start; - } - cset->nranges++; - } - } else { - cset->chars[cset->nchars++] = ch; - } - format += Tcl_UtfToUniChar(format, &ch); - } - return format; -} - -/* - *---------------------------------------------------------------------- - * - * CharInSet -- - * - * Check to see if a character matches the given set. - * - * Results: - * Returns non-zero if the character matches the given set. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -CharInSet(cset, c) - CharSet *cset; - int c; /* Character to test, passed as int because - * of non-ANSI prototypes. */ -{ - Tcl_UniChar ch = (Tcl_UniChar) c; - int i, match = 0; - for (i = 0; i < cset->nchars; i++) { - if (cset->chars[i] == ch) { - match = 1; - break; - } - } - if (!match) { - for (i = 0; i < cset->nranges; i++) { - if ((cset->ranges[i].start <= ch) - && (ch <= cset->ranges[i].end)) { - match = 1; - break; - } - } - } - return (cset->exclude ? !match : match); -} - -/* - *---------------------------------------------------------------------- - * - * ReleaseCharSet -- - * - * Free the storage associated with a character set. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ReleaseCharSet(cset) - CharSet *cset; -{ - ckfree((char *)cset->chars); - if (cset->ranges) { - ckfree((char *)cset->ranges); - } -} - -/* - *---------------------------------------------------------------------- - * - * ValidateFormat -- - * - * Parse the format string and verify that it is properly formed - * and that there are exactly enough variables on the command line. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May place an error in the interpreter result. - * - *---------------------------------------------------------------------- - */ - -static int -ValidateFormat(interp, format, numVars, totalSubs) - Tcl_Interp *interp; /* Current interpreter. */ - char *format; /* The format string. */ - int numVars; /* The number of variables passed to the - * scan command. */ - int *totalSubs; /* The number of variables that will be - * required. */ -{ -#define STATIC_LIST_SIZE 16 - int gotXpg, gotSequential, value, i, flags; - char *end; - Tcl_UniChar ch; - int staticAssign[STATIC_LIST_SIZE]; - int *nassign = staticAssign; - int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; - - /* - * Initialize an array that records the number of times a variable - * is assigned to by the format string. We use this to detect if - * a variable is multiply assigned or left unassigned. - */ - - if (numVars > nspace) { - nassign = (int*)ckalloc(sizeof(int) * numVars); - nspace = numVars; - } - for (i = 0; i < nspace; i++) { - nassign[i] = 0; - } - - xpgSize = objIndex = gotXpg = gotSequential = 0; - - while (*format != '\0') { - format += Tcl_UtfToUniChar(format, &ch); - - flags = 0; - - if (ch != '%') { - continue; - } - format += Tcl_UtfToUniChar(format, &ch); - if (ch == '%') { - continue; - } - if (ch == '*') { - flags |= SCAN_SUPPRESS; - format += Tcl_UtfToUniChar(format, &ch); - goto xpgCheckDone; - } - - if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - /* - * Check for an XPG3-style %n$ specification. Note: there - * must not be a mixture of XPG3 specs and non-XPG3 specs - * in the same format string. - */ - - value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ - if (*end != '$') { - goto notXpg; - } - format = end+1; - format += Tcl_UtfToUniChar(format, &ch); - gotXpg = 1; - if (gotSequential) { - goto mixedXPG; - } - objIndex = value - 1; - if ((objIndex < 0) || (numVars && (objIndex >= numVars))) { - goto badIndex; - } else if (numVars == 0) { - /* - * In the case where no vars are specified, the user can - * specify %9999$ legally, so we have to consider special - * rules for growing the assign array. 'value' is - * guaranteed to be > 0. - */ - xpgSize = (xpgSize > value) ? xpgSize : value; - } - goto xpgCheckDone; - } - - notXpg: - gotSequential = 1; - if (gotXpg) { - mixedXPG: - Tcl_SetResult(interp, - "cannot mix \"%\" and \"%n$\" conversion specifiers", - TCL_STATIC); - goto error; - } - - xpgCheckDone: - /* - * Parse any width specifier. - */ - - if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ - flags |= SCAN_WIDTH; - format += Tcl_UtfToUniChar(format, &ch); - } - - /* - * Ignore size specifier. - */ - - if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { - format += Tcl_UtfToUniChar(format, &ch); - } - - if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { - goto badIndex; - } - - /* - * Handle the various field types. - */ - - switch (ch) { - case 'n': - case 'd': - case 'i': - case 'o': - case 'x': - case 'u': - case 'f': - case 'e': - case 'g': - case 's': - break; - case 'c': - if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); - goto error; - } - break; - case '[': - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - if (ch == '^') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - if (ch == ']') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - while (ch != ']') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - break; - badSet: - Tcl_SetResult(interp, "unmatched [ in format string", - TCL_STATIC); - goto error; - default: - { - char buf[TCL_UTF_MAX+1]; - - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad scan conversion character \"", buf, "\"", NULL); - goto error; - } - } - if (!(flags & SCAN_SUPPRESS)) { - if (objIndex >= nspace) { - /* - * Expand the nassign buffer. If we are using XPG specifiers, - * make sure that we grow to a large enough size. xpgSize is - * guaranteed to be at least one larger than objIndex. - */ - value = nspace; - if (xpgSize) { - nspace = xpgSize; - } else { - nspace += STATIC_LIST_SIZE; - } - if (nassign == staticAssign) { - nassign = (void *)ckalloc(nspace * sizeof(int)); - for (i = 0; i < STATIC_LIST_SIZE; ++i) { - nassign[i] = staticAssign[i]; - } - } else { - nassign = (void *)ckrealloc((void *)nassign, - nspace * sizeof(int)); - } - for (i = value; i < nspace; i++) { - nassign[i] = 0; - } - } - nassign[objIndex]++; - objIndex++; - } - } - - /* - * Verify that all of the variable were assigned exactly once. - */ - - if (numVars == 0) { - if (xpgSize) { - numVars = xpgSize; - } else { - numVars = objIndex; - } - } - if (totalSubs) { - *totalSubs = numVars; - } - for (i = 0; i < numVars; i++) { - if (nassign[i] > 1) { - Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); - goto error; - } else if (!xpgSize && (nassign[i] == 0)) { - /* - * If the space is empty, and xpgSize is 0 (means XPG wasn't - * used, and/or numVars != 0), then too many vars were given - */ - Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); - goto error; - } - } - - if (nassign != staticAssign) { - ckfree((char *)nassign); - } - return TCL_OK; - - badIndex: - if (gotXpg) { - Tcl_SetResult(interp, "\"%n$\" argument index out of range", - TCL_STATIC); - } else { - Tcl_SetResult(interp, - "different numbers of variable names and field specifiers", - TCL_STATIC); - } - - error: - if (nassign != staticAssign) { - ckfree((char *)nassign); - } - return TCL_ERROR; -#undef STATIC_LIST_SIZE -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ScanObjCmd -- - * - * This procedure is invoked to process the "scan" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_ScanObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - char *format; - int numVars, nconversions, totalVars = -1; - int objIndex, offset, i, value, result, code; - char *string, *end, *baseString; - char op = 0; - int base = 0; - int underflow = 0; - size_t width; - long (*fn)() = NULL; - Tcl_UniChar ch, sch; - Tcl_Obj **objs = NULL, *objPtr = NULL; - int flags; - char buf[513]; /* Temporary buffer to hold scanned - * number strings before they are - * passed to strtoul. */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "string format ?varName varName ...?"); - return TCL_ERROR; - } - - format = Tcl_GetStringFromObj(objv[2], NULL); - numVars = objc-3; - - /* - * Check for errors in the format string. - */ - - if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Allocate space for the result objects. - */ - - if (totalVars > 0) { - objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars); - for (i = 0; i < totalVars; i++) { - objs[i] = NULL; - } - } - - string = Tcl_GetStringFromObj(objv[1], NULL); - baseString = string; - - /* - * Iterate over the format string filling in the result objects until - * we reach the end of input, the end of the format string, or there - * is a mismatch. - */ - - objIndex = 0; - nconversions = 0; - while (*format != '\0') { - format += Tcl_UtfToUniChar(format, &ch); - - flags = 0; - - /* - * If we see whitespace in the format, skip whitespace in the string. - */ - - if (Tcl_UniCharIsSpace(ch)) { - offset = Tcl_UtfToUniChar(string, &sch); - while (Tcl_UniCharIsSpace(sch)) { - if (*string == '\0') { - goto done; - } - string += offset; - offset = Tcl_UtfToUniChar(string, &sch); - } - continue; - } - - if (ch != '%') { - literal: - if (*string == '\0') { - underflow = 1; - goto done; - } - string += Tcl_UtfToUniChar(string, &sch); - if (ch != sch) { - goto done; - } - continue; - } - - format += Tcl_UtfToUniChar(format, &ch); - if (ch == '%') { - goto literal; - } - - /* - * Check for assignment suppression ('*') or an XPG3-style - * assignment ('%n$'). - */ - - if (ch == '*') { - flags |= SCAN_SUPPRESS; - format += Tcl_UtfToUniChar(format, &ch); - } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ - if (*end == '$') { - format = end+1; - format += Tcl_UtfToUniChar(format, &ch); - objIndex = value - 1; - } - } - - /* - * Parse any width specifier. - */ - - if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ - format += Tcl_UtfToUniChar(format, &ch); - } else { - width = 0; - } - - /* - * Ignore size specifier. - */ - - if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { - format += Tcl_UtfToUniChar(format, &ch); - } - - /* - * Handle the various field types. - */ - - switch (ch) { - case 'n': - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj(string - baseString); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - nconversions++; - continue; - - case 'd': - op = 'i'; - base = 10; - fn = (long (*)())strtol; - break; - case 'i': - op = 'i'; - base = 0; - fn = (long (*)())strtol; - break; - case 'o': - op = 'i'; - base = 8; - fn = (long (*)())strtol; - break; - case 'x': - op = 'i'; - base = 16; - fn = (long (*)())strtol; - break; - case 'u': - op = 'i'; - base = 10; - flags |= SCAN_UNSIGNED; - fn = (long (*)())strtoul; - break; - - case 'f': - case 'e': - case 'g': - op = 'f'; - break; - - case 's': - op = 's'; - break; - - case 'c': - op = 'c'; - flags |= SCAN_NOSKIP; - break; - case '[': - op = '['; - flags |= SCAN_NOSKIP; - break; - } - - /* - * At this point, we will need additional characters from the - * string to proceed. - */ - - if (*string == '\0') { - underflow = 1; - goto done; - } - - /* - * Skip any leading whitespace at the beginning of a field unless - * the format suppresses this behavior. - */ - - if (!(flags & SCAN_NOSKIP)) { - while (*string != '\0') { - offset = Tcl_UtfToUniChar(string, &sch); - if (!Tcl_UniCharIsSpace(sch)) { - break; - } - string += offset; - } - if (*string == '\0') { - underflow = 1; - goto done; - } - } - - /* - * Perform the requested scanning operation. - */ - - switch (op) { - case 's': - /* - * Scan a string up to width characters or whitespace. - */ - - if (width == 0) { - width = (size_t) ~0; - } - end = string; - while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); - if (Tcl_UniCharIsSpace(sch)) { - break; - } - end += offset; - if (--width == 0) { - break; - } - } - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewStringObj(string, end-string); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - string = end; - break; - - case '[': { - CharSet cset; - - if (width == 0) { - width = (size_t) ~0; - } - end = string; - - format = BuildCharSet(&cset, format); - while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); - if (!CharInSet(&cset, (int)sch)) { - break; - } - end += offset; - if (--width == 0) { - break; - } - } - ReleaseCharSet(&cset); - - if (string == end) { - /* - * Nothing matched the range, stop processing - */ - goto done; - } - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewStringObj(string, end-string); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - string = end; - - break; - } - case 'c': - /* - * Scan a single Unicode character. - */ - - string += Tcl_UtfToUniChar(string, &sch); - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - break; - - case 'i': - /* - * Scan an unsigned or signed integer. - */ - - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 1; - } - flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; - for (end = buf; width > 0; width--) { - switch (*string) { - /* - * The 0 digit has special meaning at the beginning of - * a number. If we are unsure of the base, it - * indicates that we are in base 8 or base 16 (if it is - * followed by an 'x'). - */ - case '0': - if (base == 0) { - base = 8; - flags |= SCAN_XOK; - } - if (flags & SCAN_NOZERO) { - flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS - | SCAN_NOZERO); - } else { - flags &= ~(SCAN_SIGNOK | SCAN_XOK - | SCAN_NODIGITS); - } - goto addToInt; - - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': - if (base == 0) { - base = 10; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case '8': case '9': - if (base == 0) { - base = 10; - } - if (base <= 8) { - break; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case 'A': case 'B': case 'C': - case 'D': case 'E': case 'F': - case 'a': case 'b': case 'c': - case 'd': case 'e': case 'f': - if (base <= 10) { - break; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case '+': case '-': - if (flags & SCAN_SIGNOK) { - flags &= ~SCAN_SIGNOK; - goto addToInt; - } - break; - - case 'x': case 'X': - if ((flags & SCAN_XOK) && (end == buf+1)) { - base = 16; - flags &= ~SCAN_XOK; - goto addToInt; - } - break; - } - - /* - * We got an illegal character so we are done accumulating. - */ - - break; - - addToInt: - /* - * Add the character to the temporary buffer. - */ - - *end++ = *string++; - if (*string == '\0') { - break; - } - } - - /* - * Check to see if we need to back up because we only got a - * sign or a trailing x after a 0. - */ - - if (flags & SCAN_NODIGITS) { - if (*string == '\0') { - underflow = 1; - } - goto done; - } else if (end[-1] == 'x' || end[-1] == 'X') { - end--; - string--; - } - - - /* - * Scan the value from the temporary buffer. If we are - * returning a large unsigned value, we have to convert it back - * to a string since Tcl only supports signed values. - */ - - if (!(flags & SCAN_SUPPRESS)) { - *end = '\0'; - value = (int) (*fn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (value < 0)) { - sprintf(buf, "%u", value); /* INTL: ISO digit */ - objPtr = Tcl_NewStringObj(buf, -1); - } else { - objPtr = Tcl_NewIntObj(value); - } - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - - break; - - case 'f': - /* - * Scan a floating point number - */ - - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 1; - } - flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; - for (end = buf; width > 0; width--) { - switch (*string) { - case '0': case '1': case '2': case '3': - case '4': case '5': case '6': case '7': - case '8': case '9': - flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS); - goto addToFloat; - case '+': case '-': - if (flags & SCAN_SIGNOK) { - flags &= ~SCAN_SIGNOK; - goto addToFloat; - } - break; - case '.': - if (flags & SCAN_PTOK) { - flags &= ~(SCAN_SIGNOK | SCAN_PTOK); - goto addToFloat; - } - break; - case 'e': case 'E': - /* - * An exponent is not allowed until there has - * been at least one digit. - */ - - if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) - == SCAN_EXPOK) { - flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK)) - | SCAN_SIGNOK | SCAN_NODIGITS; - goto addToFloat; - } - break; - } - - /* - * We got an illegal character so we are done accumulating. - */ - - break; - - addToFloat: - /* - * Add the character to the temporary buffer. - */ - - *end++ = *string++; - if (*string == '\0') { - break; - } - } - - /* - * Check to see if we need to back up because we saw a - * trailing 'e' or sign. - */ - - if (flags & SCAN_NODIGITS) { - if (flags & SCAN_EXPOK) { - /* - * There were no digits at all so scanning has - * failed and we are done. - */ - if (*string == '\0') { - underflow = 1; - } - goto done; - } - - /* - * We got a bad exponent ('e' and maybe a sign). - */ - - end--; - string--; - if (*end != 'e' && *end != 'E') { - end--; - string--; - } - } - - /* - * Scan the value from the temporary buffer. - */ - - if (!(flags & SCAN_SUPPRESS)) { - double dvalue; - *end = '\0'; - dvalue = strtod(buf, NULL); - objPtr = Tcl_NewDoubleObj(dvalue); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - break; - } - nconversions++; - } - - done: - result = 0; - code = TCL_OK; - - if (numVars) { - /* - * In this case, variables were specified (classic scan) - */ - for (i = 0; i < totalVars; i++) { - if (objs[i] != NULL) { - result++; - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, - objs[i], 0) == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "couldn't set variable \"", - Tcl_GetString(objv[i+3]), "\"", (char *) NULL); - code = TCL_ERROR; - } - Tcl_DecrRefCount(objs[i]); - } - } - } else { - /* - * Here no vars were specified, we want a list returned (inline scan) - */ - objPtr = Tcl_NewObj(); - for (i = 0; i < totalVars; i++) { - if (objs[i] != NULL) { - Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); - Tcl_DecrRefCount(objs[i]); - } else { - /* - * More %-specifiers than matching chars, so we - * just spit out empty strings for these - */ - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); - } - } - } - ckfree((char*) objs); - if (code == TCL_OK) { - if (underflow && (nconversions == 0)) { - if (numVars) { - objPtr = Tcl_NewIntObj(-1); - } else { - if (objPtr) { - Tcl_SetListObj(objPtr, 0, NULL); - } else { - objPtr = Tcl_NewObj(); - } - } - } else if (numVars) { - objPtr = Tcl_NewIntObj(result); - } - Tcl_SetObjResult(interp, objPtr); - } - return code; -} - -/* End of tclscan.c */ +/* $Header$ */ +/* + * tclScan.c -- + * + * This file contains the implementation of the "scan" command. + * + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclscan.c,v 1.1.1.1 2001/06/13 04:46:00 dtashley Exp $ + */ + +#include "tclInt.h" + +/* + * Flag values used by Tcl_ScanObjCmd. + */ + +#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ +#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ +#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ +#define SCAN_WIDTH 0x8 /* A width value was supplied. */ + +#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ +#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ +#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ +#define SCAN_XOK 0x80 /* An 'x' is allowed. */ +#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ +#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ + + +/* + * The following structure contains the information associated with + * a character set. + */ + +typedef struct CharSet { + int exclude; /* 1 if this is an exclusion set. */ + int nchars; + Tcl_UniChar *chars; + int nranges; + struct Range { + Tcl_UniChar start; + Tcl_UniChar end; + } *ranges; +} CharSet; + +/* + * Declarations for functions used only in this file. + */ + +static char * BuildCharSet _ANSI_ARGS_((CharSet *cset, char *format)); +static int CharInSet _ANSI_ARGS_((CharSet *cset, int ch)); +static void ReleaseCharSet _ANSI_ARGS_((CharSet *cset)); +static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format, + int numVars, int *totalVars)); + +/* + *---------------------------------------------------------------------- + * + * BuildCharSet -- + * + * This function examines a character set format specification + * and builds a CharSet containing the individual characters and + * character ranges specified. + * + * Results: + * Returns the next format position. + * + * Side effects: + * Initializes the charset. + * + *---------------------------------------------------------------------- + */ + +static char * +BuildCharSet(cset, format) + CharSet *cset; + char *format; /* Points to first char of set. */ +{ + Tcl_UniChar ch, start; + int offset, nranges; + char *end; + + memset(cset, 0, sizeof(CharSet)); + + offset = Tcl_UtfToUniChar(format, &ch); + if (ch == '^') { + cset->exclude = 1; + format += offset; + offset = Tcl_UtfToUniChar(format, &ch); + } + end = format + offset; + + /* + * Find the close bracket so we can overallocate the set. + */ + + if (ch == ']') { + end += Tcl_UtfToUniChar(end, &ch); + } + nranges = 0; + while (ch != ']') { + if (ch == '-') { + nranges++; + } + end += Tcl_UtfToUniChar(end, &ch); + } + + cset->chars = (Tcl_UniChar *) ckalloc(sizeof(Tcl_UniChar) + * (end - format - 1)); + if (nranges > 0) { + cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges); + } else { + cset->ranges = NULL; + } + + /* + * Now build the character set. + */ + + cset->nchars = cset->nranges = 0; + format += Tcl_UtfToUniChar(format, &ch); + start = ch; + if (ch == ']' || ch == '-') { + cset->chars[cset->nchars++] = ch; + format += Tcl_UtfToUniChar(format, &ch); + } + while (ch != ']') { + if (*format == '-') { + /* + * This may be the first character of a range, so don't add + * it yet. + */ + + start = ch; + } else if (ch == '-') { + /* + * Check to see if this is the last character in the set, in which + * case it is not a range and we should add the previous character + * as well as the dash. + */ + + if (*format == ']') { + cset->chars[cset->nchars++] = start; + cset->chars[cset->nchars++] = ch; + } else { + format += Tcl_UtfToUniChar(format, &ch); + + /* + * Check to see if the range is in reverse order. + */ + + if (start < ch) { + cset->ranges[cset->nranges].start = start; + cset->ranges[cset->nranges].end = ch; + } else { + cset->ranges[cset->nranges].start = ch; + cset->ranges[cset->nranges].end = start; + } + cset->nranges++; + } + } else { + cset->chars[cset->nchars++] = ch; + } + format += Tcl_UtfToUniChar(format, &ch); + } + return format; +} + +/* + *---------------------------------------------------------------------- + * + * CharInSet -- + * + * Check to see if a character matches the given set. + * + * Results: + * Returns non-zero if the character matches the given set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CharInSet(cset, c) + CharSet *cset; + int c; /* Character to test, passed as int because + * of non-ANSI prototypes. */ +{ + Tcl_UniChar ch = (Tcl_UniChar) c; + int i, match = 0; + for (i = 0; i < cset->nchars; i++) { + if (cset->chars[i] == ch) { + match = 1; + break; + } + } + if (!match) { + for (i = 0; i < cset->nranges; i++) { + if ((cset->ranges[i].start <= ch) + && (ch <= cset->ranges[i].end)) { + match = 1; + break; + } + } + } + return (cset->exclude ? !match : match); +} + +/* + *---------------------------------------------------------------------- + * + * ReleaseCharSet -- + * + * Free the storage associated with a character set. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ReleaseCharSet(cset) + CharSet *cset; +{ + ckfree((char *)cset->chars); + if (cset->ranges) { + ckfree((char *)cset->ranges); + } +} + +/* + *---------------------------------------------------------------------- + * + * ValidateFormat -- + * + * Parse the format string and verify that it is properly formed + * and that there are exactly enough variables on the command line. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May place an error in the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +ValidateFormat(interp, format, numVars, totalSubs) + Tcl_Interp *interp; /* Current interpreter. */ + char *format; /* The format string. */ + int numVars; /* The number of variables passed to the + * scan command. */ + int *totalSubs; /* The number of variables that will be + * required. */ +{ +#define STATIC_LIST_SIZE 16 + int gotXpg, gotSequential, value, i, flags; + char *end; + Tcl_UniChar ch; + int staticAssign[STATIC_LIST_SIZE]; + int *nassign = staticAssign; + int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; + + /* + * Initialize an array that records the number of times a variable + * is assigned to by the format string. We use this to detect if + * a variable is multiply assigned or left unassigned. + */ + + if (numVars > nspace) { + nassign = (int*)ckalloc(sizeof(int) * numVars); + nspace = numVars; + } + for (i = 0; i < nspace; i++) { + nassign[i] = 0; + } + + xpgSize = objIndex = gotXpg = gotSequential = 0; + + while (*format != '\0') { + format += Tcl_UtfToUniChar(format, &ch); + + flags = 0; + + if (ch != '%') { + continue; + } + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '%') { + continue; + } + if (ch == '*') { + flags |= SCAN_SUPPRESS; + format += Tcl_UtfToUniChar(format, &ch); + goto xpgCheckDone; + } + + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + /* + * Check for an XPG3-style %n$ specification. Note: there + * must not be a mixture of XPG3 specs and non-XPG3 specs + * in the same format string. + */ + + value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ + if (*end != '$') { + goto notXpg; + } + format = end+1; + format += Tcl_UtfToUniChar(format, &ch); + gotXpg = 1; + if (gotSequential) { + goto mixedXPG; + } + objIndex = value - 1; + if ((objIndex < 0) || (numVars && (objIndex >= numVars))) { + goto badIndex; + } else if (numVars == 0) { + /* + * In the case where no vars are specified, the user can + * specify %9999$ legally, so we have to consider special + * rules for growing the assign array. 'value' is + * guaranteed to be > 0. + */ + xpgSize = (xpgSize > value) ? xpgSize : value; + } + goto xpgCheckDone; + } + + notXpg: + gotSequential = 1; + if (gotXpg) { + mixedXPG: + Tcl_SetResult(interp, + "cannot mix \"%\" and \"%n$\" conversion specifiers", + TCL_STATIC); + goto error; + } + + xpgCheckDone: + /* + * Parse any width specifier. + */ + + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ + flags |= SCAN_WIDTH; + format += Tcl_UtfToUniChar(format, &ch); + } + + /* + * Ignore size specifier. + */ + + if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + format += Tcl_UtfToUniChar(format, &ch); + } + + if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { + goto badIndex; + } + + /* + * Handle the various field types. + */ + + switch (ch) { + case 'n': + case 'd': + case 'i': + case 'o': + case 'x': + case 'u': + case 'f': + case 'e': + case 'g': + case 's': + break; + case 'c': + if (flags & SCAN_WIDTH) { + Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); + goto error; + } + break; + case '[': + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '^') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + if (ch == ']') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + while (ch != ']') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + break; + badSet: + Tcl_SetResult(interp, "unmatched [ in format string", + TCL_STATIC); + goto error; + default: + { + char buf[TCL_UTF_MAX+1]; + + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad scan conversion character \"", buf, "\"", NULL); + goto error; + } + } + if (!(flags & SCAN_SUPPRESS)) { + if (objIndex >= nspace) { + /* + * Expand the nassign buffer. If we are using XPG specifiers, + * make sure that we grow to a large enough size. xpgSize is + * guaranteed to be at least one larger than objIndex. + */ + value = nspace; + if (xpgSize) { + nspace = xpgSize; + } else { + nspace += STATIC_LIST_SIZE; + } + if (nassign == staticAssign) { + nassign = (void *)ckalloc(nspace * sizeof(int)); + for (i = 0; i < STATIC_LIST_SIZE; ++i) { + nassign[i] = staticAssign[i]; + } + } else { + nassign = (void *)ckrealloc((void *)nassign, + nspace * sizeof(int)); + } + for (i = value; i < nspace; i++) { + nassign[i] = 0; + } + } + nassign[objIndex]++; + objIndex++; + } + } + + /* + * Verify that all of the variable were assigned exactly once. + */ + + if (numVars == 0) { + if (xpgSize) { + numVars = xpgSize; + } else { + numVars = objIndex; + } + } + if (totalSubs) { + *totalSubs = numVars; + } + for (i = 0; i < numVars; i++) { + if (nassign[i] > 1) { + Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + goto error; + } else if (!xpgSize && (nassign[i] == 0)) { + /* + * If the space is empty, and xpgSize is 0 (means XPG wasn't + * used, and/or numVars != 0), then too many vars were given + */ + Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); + goto error; + } + } + + if (nassign != staticAssign) { + ckfree((char *)nassign); + } + return TCL_OK; + + badIndex: + if (gotXpg) { + Tcl_SetResult(interp, "\"%n$\" argument index out of range", + TCL_STATIC); + } else { + Tcl_SetResult(interp, + "different numbers of variable names and field specifiers", + TCL_STATIC); + } + + error: + if (nassign != staticAssign) { + ckfree((char *)nassign); + } + return TCL_ERROR; +#undef STATIC_LIST_SIZE +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanObjCmd -- + * + * This procedure is invoked to process the "scan" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ScanObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *format; + int numVars, nconversions, totalVars = -1; + int objIndex, offset, i, value, result, code; + char *string, *end, *baseString; + char op = 0; + int base = 0; + int underflow = 0; + size_t width; + long (*fn)() = NULL; + Tcl_UniChar ch, sch; + Tcl_Obj **objs = NULL, *objPtr = NULL; + int flags; + char buf[513]; /* Temporary buffer to hold scanned + * number strings before they are + * passed to strtoul. */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string format ?varName varName ...?"); + return TCL_ERROR; + } + + format = Tcl_GetStringFromObj(objv[2], NULL); + numVars = objc-3; + + /* + * Check for errors in the format string. + */ + + if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Allocate space for the result objects. + */ + + if (totalVars > 0) { + objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars); + for (i = 0; i < totalVars; i++) { + objs[i] = NULL; + } + } + + string = Tcl_GetStringFromObj(objv[1], NULL); + baseString = string; + + /* + * Iterate over the format string filling in the result objects until + * we reach the end of input, the end of the format string, or there + * is a mismatch. + */ + + objIndex = 0; + nconversions = 0; + while (*format != '\0') { + format += Tcl_UtfToUniChar(format, &ch); + + flags = 0; + + /* + * If we see whitespace in the format, skip whitespace in the string. + */ + + if (Tcl_UniCharIsSpace(ch)) { + offset = Tcl_UtfToUniChar(string, &sch); + while (Tcl_UniCharIsSpace(sch)) { + if (*string == '\0') { + goto done; + } + string += offset; + offset = Tcl_UtfToUniChar(string, &sch); + } + continue; + } + + if (ch != '%') { + literal: + if (*string == '\0') { + underflow = 1; + goto done; + } + string += Tcl_UtfToUniChar(string, &sch); + if (ch != sch) { + goto done; + } + continue; + } + + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '%') { + goto literal; + } + + /* + * Check for assignment suppression ('*') or an XPG3-style + * assignment ('%n$'). + */ + + if (ch == '*') { + flags |= SCAN_SUPPRESS; + format += Tcl_UtfToUniChar(format, &ch); + } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ + if (*end == '$') { + format = end+1; + format += Tcl_UtfToUniChar(format, &ch); + objIndex = value - 1; + } + } + + /* + * Parse any width specifier. + */ + + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ + format += Tcl_UtfToUniChar(format, &ch); + } else { + width = 0; + } + + /* + * Ignore size specifier. + */ + + if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + format += Tcl_UtfToUniChar(format, &ch); + } + + /* + * Handle the various field types. + */ + + switch (ch) { + case 'n': + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj(string - baseString); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + nconversions++; + continue; + + case 'd': + op = 'i'; + base = 10; + fn = (long (*)())strtol; + break; + case 'i': + op = 'i'; + base = 0; + fn = (long (*)())strtol; + break; + case 'o': + op = 'i'; + base = 8; + fn = (long (*)())strtol; + break; + case 'x': + op = 'i'; + base = 16; + fn = (long (*)())strtol; + break; + case 'u': + op = 'i'; + base = 10; + flags |= SCAN_UNSIGNED; + fn = (long (*)())strtoul; + break; + + case 'f': + case 'e': + case 'g': + op = 'f'; + break; + + case 's': + op = 's'; + break; + + case 'c': + op = 'c'; + flags |= SCAN_NOSKIP; + break; + case '[': + op = '['; + flags |= SCAN_NOSKIP; + break; + } + + /* + * At this point, we will need additional characters from the + * string to proceed. + */ + + if (*string == '\0') { + underflow = 1; + goto done; + } + + /* + * Skip any leading whitespace at the beginning of a field unless + * the format suppresses this behavior. + */ + + if (!(flags & SCAN_NOSKIP)) { + while (*string != '\0') { + offset = Tcl_UtfToUniChar(string, &sch); + if (!Tcl_UniCharIsSpace(sch)) { + break; + } + string += offset; + } + if (*string == '\0') { + underflow = 1; + goto done; + } + } + + /* + * Perform the requested scanning operation. + */ + + switch (op) { + case 's': + /* + * Scan a string up to width characters or whitespace. + */ + + if (width == 0) { + width = (size_t) ~0; + } + end = string; + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (Tcl_UniCharIsSpace(sch)) { + break; + } + end += offset; + if (--width == 0) { + break; + } + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + break; + + case '[': { + CharSet cset; + + if (width == 0) { + width = (size_t) ~0; + } + end = string; + + format = BuildCharSet(&cset, format); + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (!CharInSet(&cset, (int)sch)) { + break; + } + end += offset; + if (--width == 0) { + break; + } + } + ReleaseCharSet(&cset); + + if (string == end) { + /* + * Nothing matched the range, stop processing + */ + goto done; + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + + break; + } + case 'c': + /* + * Scan a single Unicode character. + */ + + string += Tcl_UtfToUniChar(string, &sch); + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj((int)sch); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; + + case 'i': + /* + * Scan an unsigned or signed integer. + */ + + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; + for (end = buf; width > 0; width--) { + switch (*string) { + /* + * The 0 digit has special meaning at the beginning of + * a number. If we are unsure of the base, it + * indicates that we are in base 8 or base 16 (if it is + * followed by an 'x'). + */ + case '0': + if (base == 0) { + base = 8; + flags |= SCAN_XOK; + } + if (flags & SCAN_NOZERO) { + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS + | SCAN_NOZERO); + } else { + flags &= ~(SCAN_SIGNOK | SCAN_XOK + | SCAN_NODIGITS); + } + goto addToInt; + + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + if (base == 0) { + base = 10; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '8': case '9': + if (base == 0) { + base = 10; + } + if (base <= 8) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case 'A': case 'B': case 'C': + case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': + case 'd': case 'e': case 'f': + if (base <= 10) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToInt; + } + break; + + case 'x': case 'X': + if ((flags & SCAN_XOK) && (end == buf+1)) { + base = 16; + flags &= ~SCAN_XOK; + goto addToInt; + } + break; + } + + /* + * We got an illegal character so we are done accumulating. + */ + + break; + + addToInt: + /* + * Add the character to the temporary buffer. + */ + + *end++ = *string++; + if (*string == '\0') { + break; + } + } + + /* + * Check to see if we need to back up because we only got a + * sign or a trailing x after a 0. + */ + + if (flags & SCAN_NODIGITS) { + if (*string == '\0') { + underflow = 1; + } + goto done; + } else if (end[-1] == 'x' || end[-1] == 'X') { + end--; + string--; + } + + + /* + * Scan the value from the temporary buffer. If we are + * returning a large unsigned value, we have to convert it back + * to a string since Tcl only supports signed values. + */ + + if (!(flags & SCAN_SUPPRESS)) { + *end = '\0'; + value = (int) (*fn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%u", value); /* INTL: ISO digit */ + objPtr = Tcl_NewStringObj(buf, -1); + } else { + objPtr = Tcl_NewIntObj(value); + } + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + + break; + + case 'f': + /* + * Scan a floating point number + */ + + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; + for (end = buf; width > 0; width--) { + switch (*string) { + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + case '8': case '9': + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS); + goto addToFloat; + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToFloat; + } + break; + case '.': + if (flags & SCAN_PTOK) { + flags &= ~(SCAN_SIGNOK | SCAN_PTOK); + goto addToFloat; + } + break; + case 'e': case 'E': + /* + * An exponent is not allowed until there has + * been at least one digit. + */ + + if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) + == SCAN_EXPOK) { + flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK)) + | SCAN_SIGNOK | SCAN_NODIGITS; + goto addToFloat; + } + break; + } + + /* + * We got an illegal character so we are done accumulating. + */ + + break; + + addToFloat: + /* + * Add the character to the temporary buffer. + */ + + *end++ = *string++; + if (*string == '\0') { + break; + } + } + + /* + * Check to see if we need to back up because we saw a + * trailing 'e' or sign. + */ + + if (flags & SCAN_NODIGITS) { + if (flags & SCAN_EXPOK) { + /* + * There were no digits at all so scanning has + * failed and we are done. + */ + if (*string == '\0') { + underflow = 1; + } + goto done; + } + + /* + * We got a bad exponent ('e' and maybe a sign). + */ + + end--; + string--; + if (*end != 'e' && *end != 'E') { + end--; + string--; + } + } + + /* + * Scan the value from the temporary buffer. + */ + + if (!(flags & SCAN_SUPPRESS)) { + double dvalue; + *end = '\0'; + dvalue = strtod(buf, NULL); + objPtr = Tcl_NewDoubleObj(dvalue); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; + } + nconversions++; + } + + done: + result = 0; + code = TCL_OK; + + if (numVars) { + /* + * In this case, variables were specified (classic scan) + */ + for (i = 0; i < totalVars; i++) { + if (objs[i] != NULL) { + result++; + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, + objs[i], 0) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't set variable \"", + Tcl_GetString(objv[i+3]), "\"", (char *) NULL); + code = TCL_ERROR; + } + Tcl_DecrRefCount(objs[i]); + } + } + } else { + /* + * Here no vars were specified, we want a list returned (inline scan) + */ + objPtr = Tcl_NewObj(); + for (i = 0; i < totalVars; i++) { + if (objs[i] != NULL) { + Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); + Tcl_DecrRefCount(objs[i]); + } else { + /* + * More %-specifiers than matching chars, so we + * just spit out empty strings for these + */ + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); + } + } + } + ckfree((char*) objs); + if (code == TCL_OK) { + if (underflow && (nconversions == 0)) { + if (numVars) { + objPtr = Tcl_NewIntObj(-1); + } else { + if (objPtr) { + Tcl_SetListObj(objPtr, 0, NULL); + } else { + objPtr = Tcl_NewObj(); + } + } + } else if (numVars) { + objPtr = Tcl_NewIntObj(result); + } + Tcl_SetObjResult(interp, objPtr); + } + return code; +} + +/* End of tclscan.c */