TIP#188 implementation. Thanks to KBK! [Patch 940915]

4 files changed, 140 insertions, 31 deletions

diff --git a/ChangeLog b/ChangeLog
index 02ea307..f36f3ed 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-06-30  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
+
+	TIP#188 IMPLEMENTATION
+
+	* doc/string.n, tests/string.test:	 Add 'wideinteger' to things
+	* generic/tclCmdMZ.c (Tcl_StringObjCmd): that can be tested for with
+	the [string is] subcommand. [Patch 940915, by Kevin Kenny]
+
 2004-06-29  Don Porter  <dgp@users.sourceforge.net>
 
 	* win/tclWinInit.c:	Corrected reference counting flaw in
diff --git a/doc/string.n b/doc/string.n
index bc7e210..26d1b10 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: string.n,v 1.19 2004/05/27 18:50:09 dkf Exp $
+'\" RCS: @(#) $Id: string.n,v 1.20 2004/06/30 12:34:35 dkf Exp $
 '\" 
 .so man.macros
 .TH string n 8.1 Tcl "Tcl Built-In Commands"
@@ -95,50 +95,56 @@ will be stored in the variable named \fIvarname\fR.  The \fIvarname\fR
 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 8.5
+.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
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 17620d2..eae5e28 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.102 2004/05/27 13:18:52 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.103 2004/06/30 12:34:35 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1573,20 +1573,21 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	    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) {
@@ -1758,23 +1759,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		    if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
 			break;
 		    }
+
 		    /*
 		     * Like STR_IS_DOUBLE, but we use strtoul.
 		     * Since Tcl_GetIntFromObj already failed,
 		     * we set result to 0.
 		     */
+
 		    result = 0;
 		    errno = 0;
 		    l = strtol(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.
+			 * if (errno == ERANGE) or the long value
+			 * won't fit in an int, 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
@@ -1807,6 +1811,48 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		case STR_IS_UPPER:
 		    chcomp = Tcl_UniCharIsUpper;
 		    break;
+		case STR_IS_WIDE: {
+		    char *stop;
+
+		    if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
+			break;
+		    }
+
+		    /*
+		     * Like STR_IS_DOUBLE, but we use strtoll.  Since
+		     * Tcl_GetWideIntFromObj already failed, we set
+		     * result to 0.
+		     */
+
+		    result = 0;
+		    errno = 0;
+		    w = strtoll(string1, &stop, 0);	/* INTL: Tcl source. */
+		    if (errno == ERANGE) {
+			/*
+			 * 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;
diff --git a/tests/string.test b/tests/string.test
index b64fc4d..4021feb 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: string.test,v 1.40 2004/05/19 20:15:32 dkf Exp $
+# RCS: @(#) $Id: string.test,v 1.41 2004/06/30 12:34:36 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -310,10 +310,10 @@ test string-6.4 {string is, too many args} {
 } {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
@@ -613,6 +613,51 @@ test string-6.94 {string is double, 32-bit overflow} {
     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 {}}
 
@@ -1342,3 +1387,7 @@ test string-22.13 {string wordstart, unicode} {
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
\ No newline at end of file