TIP#269 implementation

4 files changed, 128 insertions, 14 deletions

diff --git a/ChangeLog b/ChangeLog
index 0921f93..9e82b1f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2006-11-22  Donal K. Fellows  <dkf@users.sf.net>
+
+	TIP#269 IMPLEMENTATION
+
+	* generic/tclCmdMZ.c (Tcl_StringObjCmd): Implementation of the [string
+	* tests/string.test (string-25.*):	 is list] command, based on
+	* doc/string.n:				 work by Joe Mistachkin, with
+	enhancements by Donal Fellows for better failindex behaviour.
+
 2006-11-12  Don Porter  <dgp@users.sourceforge.net>
 
 	* tools/genWinImage.tcl (removed):	Removed two files used in
diff --git a/doc/string.n b/doc/string.n
index a54091d..1e174c1 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.31 2006/11/09 15:37:56 dkf Exp $
+'\" RCS: @(#) $Id: string.n,v 1.32 2006/11/22 23:22:23 dkf Exp $
 '\" 
 .so man.macros
 .TH string n 8.1 Tcl "Tcl Built-In Commands"
@@ -142,6 +142,11 @@ Any Unicode printing character, except space.
 Any of the valid string formats for a 32-bit integer value 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 \fBlist\fR 12
+Any proper list structure, with optional surrounding whitespace. In
+case of improper list structure, 0 is returned and the \fIvarname\fR
+will contain the index of the "element" where the list parsing fails,
+or \-1 if this cannot be determined.
 .IP \fBlower\fR 12
 Any Unicode lower case alphabet character.
 .IP \fBprint\fR 12
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 66811ed..21a54e0 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.141 2006/11/15 20:08:43 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.142 2006/11/22 23:22:23 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1421,18 +1421,19 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	Tcl_WideInt w;
 
 	static CONST char *isOptions[] = {
-	    "alnum",	   "alpha",	"ascii",	"control",
-	    "boolean",	   "digit",	"double",	"false",
-	    "graph",	   "integer",	"lower",	"print",
-	    "punct",	   "space",	"true",		"upper",
-	    "wideinteger", "wordchar",	"xdigit",	NULL
+	    "alnum",	"alpha",	"ascii",	"control",
+	    "boolean",	"digit",	"double",	"false",
+	    "graph",	"integer",	"list",		"lower",
+	    "print",	"punct",	"space",	"true",
+	    "upper",	"wideinteger",	"wordchar",	"xdigit",
+	    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_WIDE,  STR_IS_WORD,	STR_IS_XDIGIT
+	    STR_IS_GRAPH, STR_IS_INT,	STR_IS_LIST,   STR_IS_LOWER,
+	    STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,  STR_IS_TRUE,
+	    STR_IS_UPPER, STR_IS_WIDE,	STR_IS_WORD,   STR_IS_XDIGIT
 	};
 
 	if (objc < 4 || objc > 7) {
@@ -1475,7 +1476,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 
 	objPtr = objv[objc-1];
 	string1 = Tcl_GetStringFromObj(objPtr, &length1);
-	if (length1 == 0) {
+	if (length1 == 0 && index != STR_IS_LIST) {
 	    if (strict) {
 		result = 0;
 	    }
@@ -1598,6 +1599,60 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	    }
 	    break;
 	}
+	case STR_IS_LIST:
+	    /*
+	     * We ignore the strictness here, since empty strings are always
+	     * well-formed lists.
+	     */
+
+	    if (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length2)) {
+		break;
+	    }
+
+	    if (failVarObj != NULL) {
+		/*
+		 * Need to figure out where the list parsing failed, which is
+		 * fairly expensive. This is adapted from the core of
+		 * SetListFromAny().
+		 */
+
+		const char *elemStart, *nextElem, *limit;
+		int lenRemain, elemSize, hasBrace;
+		register const char *p;
+
+		limit = string1 + length1;
+		failat = -1;
+		for (p=string1, lenRemain=length1; lenRemain > 0;
+			p = nextElem, lenRemain = (limit-nextElem)) {
+		    if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
+			    &elemStart, &nextElem, &elemSize, &hasBrace)) {
+			/*
+			 * This is the simplest way of getting the number of
+			 * characters parsed. Note that this is not the same
+			 * as the number of bytes when parsing strings with
+			 * non-ASCII characters in them.
+			 */
+
+			Tcl_Obj *tmpStr;
+
+			/*
+			 * Skip leading spaces first. This is only really an
+			 * issue if it is the first "element" that has the
+			 * failure.
+			 */
+
+			while (isspace(UCHAR(*p))) {		/* INTL: ? */
+			    p++;
+			}
+			tmpStr = Tcl_NewStringObj(string1, p-string1);
+			failat = Tcl_GetCharLength(tmpStr);
+			TclDecrRefCount(tmpStr);
+			break;
+		    }
+		}
+	    }
+	    result = 0;
+	    break;
 	case STR_IS_LOWER:
 	    chcomp = Tcl_UniCharIsLower;
 	    break;
diff --git a/tests/string.test b/tests/string.test
index 6bdffb4..463bcd3 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.59 2006/11/09 16:11:46 dkf Exp $
+# RCS: @(#) $Id: string.test,v 1.60 2006/11/22 23:22:23 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -311,10 +311,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, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, 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, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, 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
@@ -1513,6 +1513,51 @@ test string-24.4 {string reverse command - unshared string} {
     string reverse $x$y
 } edcba
 
+test string-25.1 {string is list} {
+    string is list {a b c}
+} 1
+test string-25.2 {string is list} {
+    string is list "a \{b c"
+} 0
+test string-25.3 {string is list} {
+    string is list {a {b c}d e}
+} 0
+test string-25.4 {string is list} {
+    string is list {}
+} 1
+test string-25.5 {string is list} {
+    string is list -strict {a b c}
+} 1
+test string-25.6 {string is list} {
+    string is list -strict "a \{b c"
+} 0
+test string-25.7 {string is list} {
+    string is list -strict {a {b c}d e}
+} 0
+test string-25.8 {string is list} {
+    string is list -strict {}
+} 1
+test string-25.9 {string is list} {
+    set x {}
+    list [string is list -failindex x {a b c}] $x
+} {1 {}}
+test string-25.10 {string is list} {
+    set x {}
+    list [string is list -failindex x "a \{b c"] $x
+} {0 2}
+test string-25.11 {string is list} {
+    set x {}
+    list [string is list -failindex x {a b {b c}d e}] $x
+} {0 4}
+test string-25.12 {string is list} {
+    set x {}
+    list [string is list -failindex x {}] $x
+} {1 {}}
+test string-25.11 {string is list} {
+    set x {}
+    list [string is list -failindex x {  {b c}d e}] $x
+} {0 2}
+
 # cleanup
 ::tcltest::cleanupTests
 return