summaryrefslogtreecommitdiffstats
path: root/generic/tclScan.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclScan.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclScan.c')
-rw-r--r--generic/tclScan.c1032
1 files changed, 1032 insertions, 0 deletions
diff --git a/generic/tclScan.c b/generic/tclScan.c
new file mode 100644
index 0000000..92b192c
--- /dev/null
+++ b/generic/tclScan.c
@@ -0,0 +1,1032 @@
+/*
+ * 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.2 1999/04/16 00:46:53 stanton 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));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+ Tcl_Interp *interp; /* Current interpreter. */
+ char *format; /* The format string. */
+ int numVars; /* The number of variables passed to the
+ * scan command. */
+{
+ int gotXpg, gotSequential, value, i, flags;
+ char *end;
+ Tcl_UniChar ch;
+ int *nassign = (int*)ckalloc(sizeof(int) * numVars);
+ int objIndex;
+
+ /*
+ * 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.
+ */
+
+ for (i = 0; i < numVars; i++) {
+ nassign[i] = 0;
+ }
+
+ 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) || (objIndex >= numVars)) {
+ goto badIndex;
+ }
+ 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) && 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)) {
+ nassign[objIndex]++;
+ objIndex++;
+ }
+ }
+
+ /*
+ * Verify that all of the variable were assigned exactly once.
+ */
+
+ 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 (nassign[i] == 0) {
+ Tcl_SetResult(interp, "variable is not assigend by any conversion specifiers", TCL_STATIC);
+ goto error;
+ }
+ }
+
+ 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:
+ ckfree((char *)nassign);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ 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, *objPtr;
+ 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) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate space for the result objects.
+ */
+
+ objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * numVars);
+ for (i = 0; i < numVars; 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 (!(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;
+
+ for (i = 0; i < numVars; 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]);
+ }
+ }
+ ckfree((char*) objs);
+ if (code == TCL_OK) {
+ if (underflow && (nconversions == 0)) {
+ result = -1;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ }
+ return code;
+}