Logo Search packages:      
Sourcecode: tcl8.4 version File versions  Download package

tclScan.c

/* 
 * 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.12.2.2 2005/10/23 22:01:30 msofer Exp $
 */

#include "tclInt.h"
/*
 * For strtoll() and strtoull() declarations on some platforms...
 */
#include "tclPort.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. */

#define SCAN_LONGER     0x400         /* Asked for a wide value. */

/*
 * 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;
    char buf[TCL_UTF_MAX+1];

    /*
     * 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);
      }

      /*
       * Handle any size specifier.
       */

      switch (ch) {
      case 'l':
      case 'L':
          flags |= SCAN_LONGER;
      case 'h':
          format += Tcl_UtfToUniChar(format, &ch);
      }

      if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
          goto badIndex;
      }

      /*
       * Handle the various field types.
       */

      switch (ch) {
          case 'c':
                if (flags & SCAN_WIDTH) {
                Tcl_SetResult(interp,
                      "field width may not be specified in %c conversion",
                      TCL_STATIC);
                goto error;
                }
            /*
             * Fall through!
             */
          case 'n':
          case 's':
            if (flags & SCAN_LONGER) {
            invalidLonger:
                buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                     "'l' modifier may not be specified in %", buf,
                     " conversion", NULL);
                goto error;
            }
            /*
             * Fall through!
             */
          case 'd':
          case 'e':
          case 'f':
          case 'g':
          case 'i':
          case 'o':
          case 'u':
          case 'x':
            break;
            /*
             * Bracket terms need special checking
             */
          case '[':
            if (flags & SCAN_LONGER) {
                goto invalidLonger;
            }
            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, result, code;
    long value;
    char *string, *end, *baseString;
    char op = 0;
    int base = 0;
    int underflow = 0;
    size_t width;
    long (*fn)() = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn)() = NULL;
    Tcl_WideInt wideValue;
#endif
    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 = (int) 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;
      }

      /*
       * Handle any size specifier.
       */

      switch (ch) {
      case 'l':
      case 'L':
          flags |= SCAN_LONGER;
          /*
           * Fall through so we skip to the next character.
           */
      case '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;
#ifndef TCL_WIDE_INT_IS_LONG
            lfn = (Tcl_WideInt (*)())strtoll;
#endif
            break;
          case 'i':
            op = 'i';
            base = 0;
            fn = (long (*)())strtol;
#ifndef TCL_WIDE_INT_IS_LONG
            lfn = (Tcl_WideInt (*)())strtoll;
#endif
            break;
          case 'o':
            op = 'i';
            base = 8;
            fn = (long (*)())strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
            lfn = (Tcl_WideInt (*)())strtoull;
#endif
            break;
          case 'x':
            op = 'i';
            base = 16;
            fn = (long (*)())strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
            lfn = (Tcl_WideInt (*)())strtoull;
#endif
            break;
          case 'u':
            op = 'i';
            base = 10;
            flags |= SCAN_UNSIGNED;
            fn = (long (*)())strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
            lfn = (Tcl_WideInt (*)())strtoull;
#endif
            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').
                   *
                   * 8.1 - 8.3.4 incorrectly handled 0x... base-16
                   * cases for %x by not reading the 0x as the
                   * auto-prelude for base-16. [Bug #495213]
                   */
                  case '0':
                      if (base == 0) {
                        base = 8;
                        flags |= SCAN_XOK;
                      }
                      if (base == 16) {
                        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';
#ifndef TCL_WIDE_INT_IS_LONG
                if (flags & SCAN_LONGER) {
                  wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base);
                  if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
                      /* INTL: ISO digit */
                      sprintf(buf, "%" TCL_LL_MODIFIER "u",
                            (Tcl_WideUInt)wideValue);
                      objPtr = Tcl_NewStringObj(buf, -1);
                  } else {
                      objPtr = Tcl_NewWideIntObj(wideValue);
                  }
                } else {
#endif /* !TCL_WIDE_INT_IS_LONG */
                  value = (long) (*fn)(buf, NULL, base);
                  if ((flags & SCAN_UNSIGNED) && (value < 0)) {
                      sprintf(buf, "%lu", value); /* INTL: ISO digit */
                      objPtr = Tcl_NewStringObj(buf, -1);
                  } else if ((flags & SCAN_LONGER)
                        || (unsigned long) value > UINT_MAX) {
                      objPtr = Tcl_NewLongObj(value);
                  } else {
                      objPtr = Tcl_NewIntObj(value);
                  }
#ifndef TCL_WIDE_INT_IS_LONG
                }
#endif
                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_LONGER;
            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) {
            Tcl_Obj *tmpPtr;
            
            result++;
            tmpPtr = Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0);
            Tcl_DecrRefCount(objs[i]);
            if (tmpPtr == NULL) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                      "couldn't set variable \"",
                      Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
                code = TCL_ERROR;
            }
          }
      }
    } 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());
          }
      }
    }
    if (objs != NULL) {
      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;
}

Generated by  Doxygen 1.6.0   Back to index