summaryrefslogtreecommitdiffstats
path: root/tcl8.6/generic/tclScan.c
diff options
context:
space:
mode:
Diffstat (limited to 'tcl8.6/generic/tclScan.c')
-rw-r--r--tcl8.6/generic/tclScan.c1079
1 files changed, 1079 insertions, 0 deletions
diff --git a/tcl8.6/generic/tclScan.c b/tcl8.6/generic/tclScan.c
new file mode 100644
index 0000000..17069eb
--- /dev/null
+++ b/tcl8.6/generic/tclScan.c
@@ -0,0 +1,1079 @@
+/*
+ * 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.
+ */
+
+#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_LONGER 0x400 /* Asked for a wide value. */
+#define SCAN_BIG 0x800 /* Asked for a bignum 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 const char * BuildCharSet(CharSet *cset, const char *format);
+static int CharInSet(CharSet *cset, int ch);
+static void ReleaseCharSet(CharSet *cset);
+static int ValidateFormat(Tcl_Interp *interp, const 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 const char *
+BuildCharSet(
+ CharSet *cset,
+ const char *format) /* Points to first char of set. */
+{
+ Tcl_UniChar ch, start;
+ int offset, nranges;
+ const char *end;
+
+ memset(cset, 0, sizeof(CharSet));
+
+ offset = TclUtfToUniChar(format, &ch);
+ if (ch == '^') {
+ cset->exclude = 1;
+ format += offset;
+ offset = TclUtfToUniChar(format, &ch);
+ }
+ end = format + offset;
+
+ /*
+ * Find the close bracket so we can overallocate the set.
+ */
+
+ if (ch == ']') {
+ end += TclUtfToUniChar(end, &ch);
+ }
+ nranges = 0;
+ while (ch != ']') {
+ if (ch == '-') {
+ nranges++;
+ }
+ end += TclUtfToUniChar(end, &ch);
+ }
+
+ cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
+ if (nranges > 0) {
+ cset->ranges = ckalloc(sizeof(struct Range) * nranges);
+ } else {
+ cset->ranges = NULL;
+ }
+
+ /*
+ * Now build the character set.
+ */
+
+ cset->nchars = cset->nranges = 0;
+ format += TclUtfToUniChar(format, &ch);
+ start = ch;
+ if (ch == ']' || ch == '-') {
+ cset->chars[cset->nchars++] = ch;
+ format += TclUtfToUniChar(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 += TclUtfToUniChar(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 += TclUtfToUniChar(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(
+ 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(
+ CharSet *cset)
+{
+ ckfree(cset->chars);
+ if (cset->ranges) {
+ ckfree(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(
+ Tcl_Interp *interp, /* Current interpreter. */
+ const 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. */
+{
+ int gotXpg, gotSequential, value, i, flags;
+ char *end;
+ Tcl_UniChar ch;
+ int objIndex, xpgSize, nspace = numVars;
+ int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
+ char buf[TCL_UTF_MAX+1];
+ Tcl_Obj *errorMsg; /* Place to build an error messages. Note that
+ * these are messy operations because we do
+ * not want to use the formatting engine;
+ * we're inside there! */
+
+ /*
+ * 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 < nspace; i++) {
+ nassign[i] = 0;
+ }
+
+ xpgSize = objIndex = gotXpg = gotSequential = 0;
+
+ while (*format != '\0') {
+ format += TclUtfToUniChar(format, &ch);
+
+ flags = 0;
+
+ if (ch != '%') {
+ continue;
+ }
+ format += TclUtfToUniChar(format, &ch);
+ if (ch == '%') {
+ continue;
+ }
+ if (ch == '*') {
+ flags |= SCAN_SUPPRESS;
+ format += TclUtfToUniChar(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 += TclUtfToUniChar(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_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot mix \"%\" and \"%n$\" conversion specifiers",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
+ goto error;
+ }
+
+ xpgCheckDone:
+ /*
+ * Parse any width specifier.
+ */
+
+ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ value = strtoul(format-1, (char **) &format, 10); /* INTL: "C" locale. */
+ flags |= SCAN_WIDTH;
+ format += TclUtfToUniChar(format, &ch);
+ }
+
+ /*
+ * Handle any size specifier.
+ */
+
+ switch (ch) {
+ case 'l':
+ if (*format == 'l') {
+ flags |= SCAN_BIG;
+ format += 1;
+ format += TclUtfToUniChar(format, &ch);
+ break;
+ }
+ case 'L':
+ flags |= SCAN_LONGER;
+ case 'h':
+ format += TclUtfToUniChar(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_SetObjResult(interp, Tcl_NewStringObj(
+ "field width may not be specified in %c conversion",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
+ goto error;
+ }
+ /*
+ * Fall through!
+ */
+ case 'n':
+ case 's':
+ if (flags & (SCAN_LONGER|SCAN_BIG)) {
+ invalidFieldSize:
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ errorMsg = Tcl_NewStringObj(
+ "field size modifier may not be specified in %", -1);
+ Tcl_AppendToObj(errorMsg, buf, -1);
+ Tcl_AppendToObj(errorMsg, " conversion", -1);
+ Tcl_SetObjResult(interp, errorMsg);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
+ goto error;
+ }
+ /*
+ * Fall through!
+ */
+ case 'd':
+ case 'e':
+ case 'E':
+ case 'f':
+ case 'g':
+ case 'G':
+ case 'i':
+ case 'o':
+ case 'x':
+ case 'X':
+ case 'b':
+ break;
+ case 'u':
+ if (flags & SCAN_BIG) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
+ goto error;
+ }
+ break;
+ /*
+ * Bracket terms need special checking
+ */
+ case '[':
+ if (flags & (SCAN_LONGER|SCAN_BIG)) {
+ goto invalidFieldSize;
+ }
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += TclUtfToUniChar(format, &ch);
+ if (ch == '^') {
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += TclUtfToUniChar(format, &ch);
+ }
+ if (ch == ']') {
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += TclUtfToUniChar(format, &ch);
+ }
+ while (ch != ']') {
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += TclUtfToUniChar(format, &ch);
+ }
+ break;
+ badSet:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched [ in format string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
+ goto error;
+ default:
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ errorMsg = Tcl_NewStringObj(
+ "bad scan conversion character \"", -1);
+ Tcl_AppendToObj(errorMsg, buf, -1);
+ Tcl_AppendToObj(errorMsg, "\"", -1);
+ Tcl_SetObjResult(interp, errorMsg);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", 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 += 16; /* formerly STATIC_LIST_SIZE */
+ }
+ nassign = TclStackRealloc(interp, 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_SetObjResult(interp, Tcl_NewStringObj(
+ "variable is assigned by multiple \"%n$\" conversion specifiers",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
+ 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_SetObjResult(interp, Tcl_NewStringObj(
+ "variable is not assigned by any conversion specifiers",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
+ goto error;
+ }
+ }
+
+ TclStackFree(interp, nassign);
+ return TCL_OK;
+
+ badIndex:
+ if (gotXpg) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"%n$\" argument index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "different numbers of variable names and field specifiers",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
+ }
+
+ error:
+ TclStackFree(interp, nassign);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ScanObjCmd --
+ *
+ * This function 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(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *format;
+ int numVars, nconversions, totalVars = -1;
+ int objIndex, offset, i, result, code;
+ long value;
+ const char *string, *end, *baseString;
+ char op = 0;
+ int width, underflow = 0;
+ Tcl_WideInt wideValue;
+ 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 ...?");
+ return TCL_ERROR;
+ }
+
+ format = Tcl_GetString(objv[2]);
+ 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 = ckalloc(sizeof(Tcl_Obj *) * totalVars);
+ for (i = 0; i < totalVars; i++) {
+ objs[i] = NULL;
+ }
+ }
+
+ string = Tcl_GetString(objv[1]);
+ 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') {
+ int parseFlag = TCL_PARSE_NO_WHITESPACE;
+ format += TclUtfToUniChar(format, &ch);
+
+ flags = 0;
+
+ /*
+ * If we see whitespace in the format, skip whitespace in the string.
+ */
+
+ if (Tcl_UniCharIsSpace(ch)) {
+ offset = TclUtfToUniChar(string, &sch);
+ while (Tcl_UniCharIsSpace(sch)) {
+ if (*string == '\0') {
+ goto done;
+ }
+ string += offset;
+ offset = TclUtfToUniChar(string, &sch);
+ }
+ continue;
+ }
+
+ if (ch != '%') {
+ literal:
+ if (*string == '\0') {
+ underflow = 1;
+ goto done;
+ }
+ string += TclUtfToUniChar(string, &sch);
+ if (ch != sch) {
+ goto done;
+ }
+ continue;
+ }
+
+ format += TclUtfToUniChar(format, &ch);
+ if (ch == '%') {
+ goto literal;
+ }
+
+ /*
+ * Check for assignment suppression ('*') or an XPG3-style assignment
+ * ('%n$').
+ */
+
+ if (ch == '*') {
+ flags |= SCAN_SUPPRESS;
+ format += TclUtfToUniChar(format, &ch);
+ } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ char *formatEnd;
+ value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
+ if (*formatEnd == '$') {
+ format = formatEnd+1;
+ format += TclUtfToUniChar(format, &ch);
+ objIndex = (int) value - 1;
+ }
+ }
+
+ /*
+ * Parse any width specifier.
+ */
+
+ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */
+ format += TclUtfToUniChar(format, &ch);
+ } else {
+ width = 0;
+ }
+
+ /*
+ * Handle any size specifier.
+ */
+
+ switch (ch) {
+ case 'l':
+ if (*format == 'l') {
+ flags |= SCAN_BIG;
+ format += 1;
+ format += TclUtfToUniChar(format, &ch);
+ break;
+ }
+ case 'L':
+ flags |= SCAN_LONGER;
+ /*
+ * Fall through so we skip to the next character.
+ */
+ case 'h':
+ format += TclUtfToUniChar(format, &ch);
+ }
+
+ /*
+ * Handle the various field types.
+ */
+
+ switch (ch) {
+ case 'n':
+ if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewIntObj(string - baseString);
+ Tcl_IncrRefCount(objPtr);
+ CLANG_ASSERT(objs);
+ objs[objIndex++] = objPtr;
+ }
+ nconversions++;
+ continue;
+
+ case 'd':
+ op = 'i';
+ parseFlag |= TCL_PARSE_DECIMAL_ONLY;
+ break;
+ case 'i':
+ op = 'i';
+ parseFlag |= TCL_PARSE_SCAN_PREFIXES;
+ break;
+ case 'o':
+ op = 'i';
+ parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
+ break;
+ case 'x':
+ case 'X':
+ op = 'i';
+ parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
+ break;
+ case 'b':
+ op = 'i';
+ parseFlag |= TCL_PARSE_BINARY_ONLY;
+ break;
+ case 'u':
+ op = 'i';
+ parseFlag |= TCL_PARSE_DECIMAL_ONLY;
+ flags |= SCAN_UNSIGNED;
+ break;
+
+ case 'f':
+ case 'e':
+ case 'E':
+ case 'g':
+ 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 = TclUtfToUniChar(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 = ~0;
+ }
+ end = string;
+ while (*end != '\0') {
+ offset = TclUtfToUniChar(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);
+ CLANG_ASSERT(objs);
+ objs[objIndex++] = objPtr;
+ }
+ string = end;
+ break;
+
+ case '[': {
+ CharSet cset;
+
+ if (width == 0) {
+ width = ~0;
+ }
+ end = string;
+
+ format = BuildCharSet(&cset, format);
+ while (*end != '\0') {
+ offset = TclUtfToUniChar(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 += TclUtfToUniChar(string, &sch);
+ if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewIntObj((int)sch);
+ Tcl_IncrRefCount(objPtr);
+ CLANG_ASSERT(objs);
+ objs[objIndex++] = objPtr;
+ }
+ break;
+
+ case 'i':
+ /*
+ * Scan an unsigned or signed integer.
+ */
+ objPtr = Tcl_NewLongObj(0);
+ Tcl_IncrRefCount(objPtr);
+ if (width == 0) {
+ width = ~0;
+ }
+ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
+ &end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
+ Tcl_DecrRefCount(objPtr);
+ if (width < 0) {
+ if (*end == '\0') {
+ underflow = 1;
+ }
+ } else {
+ if (end == string + width) {
+ underflow = 1;
+ }
+ }
+ goto done;
+ }
+ string = end;
+ if (flags & SCAN_SUPPRESS) {
+ Tcl_DecrRefCount(objPtr);
+ break;
+ }
+ if (flags & SCAN_LONGER) {
+ if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
+ wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
+ if (TclGetString(objPtr)[0] == '-') {
+ wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
+ }
+ }
+ if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
+ sprintf(buf, "%" TCL_LL_MODIFIER "u",
+ (Tcl_WideUInt)wideValue);
+ Tcl_SetStringObj(objPtr, buf, -1);
+ } else {
+ Tcl_SetWideIntObj(objPtr, wideValue);
+ }
+ } else if (!(flags & SCAN_BIG)) {
+ if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
+ if (TclGetString(objPtr)[0] == '-') {
+ value = LONG_MIN;
+ } else {
+ value = LONG_MAX;
+ }
+ }
+ if ((flags & SCAN_UNSIGNED) && (value < 0)) {
+ sprintf(buf, "%lu", value); /* INTL: ISO digit */
+ Tcl_SetStringObj(objPtr, buf, -1);
+ } else {
+ Tcl_SetLongObj(objPtr, value);
+ }
+ }
+ objs[objIndex++] = objPtr;
+ break;
+
+ case 'f':
+ /*
+ * Scan a floating point number
+ */
+
+ objPtr = Tcl_NewDoubleObj(0.0);
+ Tcl_IncrRefCount(objPtr);
+ if (width == 0) {
+ width = ~0;
+ }
+ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
+ &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) {
+ Tcl_DecrRefCount(objPtr);
+ if (width < 0) {
+ if (*end == '\0') {
+ underflow = 1;
+ }
+ } else {
+ if (end == string + width) {
+ underflow = 1;
+ }
+ }
+ goto done;
+ } else if (flags & SCAN_SUPPRESS) {
+ Tcl_DecrRefCount(objPtr);
+ string = end;
+ } else {
+ double dvalue;
+ if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
+#ifdef ACCEPT_NAN
+ if (objPtr->typePtr == &tclDoubleType) {
+ dvalue = objPtr->internalRep.doubleValue;
+ } else
+#endif
+ {
+ Tcl_DecrRefCount(objPtr);
+ goto done;
+ }
+ }
+ Tcl_SetDoubleObj(objPtr, dvalue);
+ CLANG_ASSERT(objs);
+ objs[objIndex++] = objPtr;
+ string = end;
+ }
+ }
+ 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) {
+ continue;
+ }
+ result++;
+
+ /*
+ * In case of multiple errors in setting variables, just report
+ * the first one.
+ */
+
+ if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i],
+ (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == 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());
+ }
+ }
+ }
+ if (objs != NULL) {
+ ckfree(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;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */