Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 2451dbea818800c1743de02df8871ee6f6bd3080:

Attachment "iswide.patch" to ticket [940915ffff] added by kennykb 2004-04-28 02:31:45.
Index: doc/string.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/string.n,v
retrieving revision 1.18
diff -u -b -r1.18 string.n
--- doc/string.n	11 Apr 2003 20:50:47 -0000	1.18
+++ doc/string.n	27 Apr 2004 19:30:35 -0000
@@ -95,50 +95,56 @@
 will not be set if the function returns 1.  The following character
 classes are recognized (the class name can be abbreviated):
 .RS
-.IP \fBalnum\fR 10
+.IP \fBalnum\fR 12
 Any Unicode alphabet or digit character.
-.IP \fBalpha\fR 10
+.IP \fBalpha\fR 12
 Any Unicode alphabet character.
-.IP \fBascii\fR 10
+.IP \fBascii\fR 12
 Any character with a value less than \\u0080 (those that are in the
 7\-bit ascii range).
-.IP \fBboolean\fR 10
+.IP \fBboolean\fR 12
 Any of the forms allowed to \fBTcl_GetBoolean\fR.
-.IP \fBcontrol\fR 10
+.IP \fBcontrol\fR 12
 Any Unicode control character.
-.IP \fBdigit\fR 10
+.IP \fBdigit\fR 12
 Any Unicode digit character.  Note that this includes characters
 outside of the [0\-9] range.
-.IP \fBdouble\fR 10
+.IP \fBdouble\fR 12
 Any of the valid forms for a double in Tcl, with optional surrounding
 whitespace.  In case of under/overflow in the value, 0 is returned and
 the \fIvarname\fR will contain \-1.
-.IP \fBfalse\fR 10
+.IP \fBfalse\fR 12
 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
 false.
-.IP \fBgraph\fR 10
+.IP \fBgraph\fR 12
 Any Unicode printing character, except space.
-.IP \fBinteger\fR 10
-Any of the valid forms for a 32-bit integer in Tcl, with optional
+.IP \fBinteger\fR 12
+Any of the valid forms for an ordinary integer in Tcl, with optional
 surrounding whitespace.  In case of under/overflow in the value, 0 is
 returned and the \fIvarname\fR will contain \-1.
-.IP \fBlower\fR 10
+.IP \fBlower\fR 12
 Any Unicode lower case alphabet character.
-.IP \fBprint\fR 10
+.IP \fBprint\fR 12
 Any Unicode printing character, including space.
-.IP \fBpunct\fR 10
+.IP \fBpunct\fR 12
 Any Unicode punctuation character.
-.IP \fBspace\fR 10
+.IP \fBspace\fR 12
 Any Unicode space character.
-.IP \fBtrue\fR 10
+.IP \fBtrue\fR 12
 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
 true.
-.IP \fBupper\fR 10
+.IP \fBupper\fR 12
 Any upper case alphabet character in the Unicode character set.
-.IP \fBwordchar\fR 10
+.VS 8.5
+.IP \fBwideinteger\fR 12
+Any of the valid forms for a wide integer in Tcl, with optional
+surrounding whitespace.  In case of under/overflow in the value, 0 is
+returned and the \fIvarname\fR will contain \-1.
+.VE
+.IP \fBwordchar\fR 12
 Any Unicode word character.  That is any alphanumeric character, and
 any Unicode connector punctuation characters (e.g. underscore).
-.IP \fBxdigit\fR 10
+.IP \fBxdigit\fR 12
 Any hexadecimal digit character ([0\-9A\-Fa\-f]).
 .PP
 In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.101
diff -u -b -r1.101 tclCmdMZ.c
--- generic/tclCmdMZ.c	6 Apr 2004 22:25:49 -0000	1.101
+++ generic/tclCmdMZ.c	27 Apr 2004 19:30:39 -0000
@@ -1569,20 +1569,21 @@
 	    int (*chcomp)_ANSI_ARGS_((int)) = NULL; 
 	    int i, failat = 0, result = 1, strict = 0;
 	    Tcl_Obj *objPtr, *failVarObj = NULL;
+	    Tcl_WideInt w;
 
 	    static CONST char *isOptions[] = {
 		"alnum",	"alpha",	"ascii",	"control",
 		"boolean",	"digit",	"double",	"false",
 		"graph",	"integer",	"lower",	"print",
 		"punct",	"space",	"true",		"upper",
-		"wordchar",	"xdigit",	(char *) NULL
+		"wideinteger",  "wordchar",	"xdigit",	(char *) NULL
 	    };
 	    enum isOptions {
 		STR_IS_ALNUM,	STR_IS_ALPHA,	STR_IS_ASCII,	STR_IS_CONTROL,
 		STR_IS_BOOL,	STR_IS_DIGIT,	STR_IS_DOUBLE,	STR_IS_FALSE,
 		STR_IS_GRAPH,	STR_IS_INT,	STR_IS_LOWER,	STR_IS_PRINT,
 		STR_IS_PUNCT,	STR_IS_SPACE,	STR_IS_TRUE,	STR_IS_UPPER,
-		STR_IS_WORD,	STR_IS_XDIGIT
+		STR_IS_WIDE,    STR_IS_WORD,	STR_IS_XDIGIT
 	    };
 
 	    if (objc < 4 || objc > 7) {
@@ -1803,6 +1804,47 @@
 		case STR_IS_UPPER:
 		    chcomp = Tcl_UniCharIsUpper;
 		    break;
+		case STR_IS_WIDE: {
+		    char *stop;
+		    long int l = 0;
+
+		    if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
+			break;
+		    }
+		    /*
+		     * Like STR_IS_DOUBLE, but we use strtoul.
+		     * Since Tcl_GetIntFromObj already failed,
+		     * we set result to 0.
+		     */
+		    result = 0;
+		    errno = 0;
+		    w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */
+		    if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
+			/*
+			 * if (errno == ERANGE), then it was an over/underflow
+			 * problem, but in this method, we only want to know
+			 * yes or no, so bad flow returns 0 (false) and sets
+			 * the failVarObj to the string length.
+			 */
+			failat = -1;
+
+		    } else if (stop == string1) {
+			/*
+			 * In this case, nothing like a number was found
+			 */
+			failat = 0;
+		    } else {
+			/*
+			 * Assume we sucked up one char per byte
+			 * and then we go onto SPACE, since we are
+			 * allowed trailing whitespace
+			 */
+			failat = stop - string1;
+			string1 = stop;
+			chcomp = Tcl_UniCharIsSpace;
+		    }
+		    break;
+		}
 		case STR_IS_WORD:
 		    chcomp = Tcl_UniCharIsWordChar;
 		    break;
Index: tests/string.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/string.test,v
retrieving revision 1.39
diff -u -b -r1.39 string.test
--- tests/string.test	4 Jul 2003 10:30:27 -0000	1.39
+++ tests/string.test	27 Apr 2004 19:30:39 -0000
@@ -311,10 +311,10 @@
 } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
 test string-6.5 {string is, class check} {
     list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.6 {string is, ambiguous class} {
     list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.7 {string is alpha, all ok} {
     string is alpha -strict -failindex var abc
 } 1
@@ -614,6 +614,51 @@
     set x 0x100000000
     list [string is integer -failindex var [expr {$x}]] $var
 } {0 -1}
+test string-6.95 {string is wideinteger, true} {
+    string is wideinteger +1234567890
+} 1
+test string-6.96 {string is wideinteger, true on type} {
+    string is wideinteger [expr wide(50.0)]
+} 1
+test string-6.97 {string is wideinteger, true} {
+    string is wideinteger [list -10]
+} 1
+test string-6.98 {string is wideinteger, true as hex} {
+    string is wideinteger 0xabcdef
+} 1
+test string-6.99 {string is wideinteger, true as octal} {
+    string is wideinteger 0123456
+} 1
+test string-6.100 {string is wideinteger, true with whitespace} {
+    string is wideinteger "  \n1234\v"
+} 1
+test string-6.101 {string is wideinteger, false} {
+    list [string is wideinteger -fail var 123abc] $var
+} {0 3}
+test string-6.102 {string is wideinteger, false on overflow} {
+    list [string is wideinteger -fail var +[largest_int]0] $var
+} {0 -1}
+test string-6.103 {string is wideinteger, false} {
+    list [string is wideinteger -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.104 {string is wideinteger, false} {
+    list [string is wideinteger -fail var "    "] $var
+} {0 0}
+test string-6.105 {string is wideinteger, false on bad octal} {
+    list [string is wideinteger -fail var 036963] $var
+} {0 3}
+test string-6.106 {string is wideinteger, false on bad hex} {
+    list [string is wideinteger -fail var 0X345XYZ] $var
+} {0 5}
+test string-6.105 {string is integer, bad integers} {
+    # SF bug #634856
+    set result ""
+    set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
+    foreach num $numbers {
+	lappend result [string is wideinteger -strict $num]
+    }
+    set result
+} {1 1 0 0 0 1 0 0}
 
 catch {rename largest_int {}}
 
@@ -1343,3 +1388,7 @@
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
\ No newline at end of file