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