summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2006-11-22 23:22:22 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2006-11-22 23:22:22 (GMT)
commitf4d65f439e4de5c04bfafc2ce2b2678776c35248 (patch)
treeaceb52ba2f7536827cffb58f78663e39d37e1836
parente5bdc0bb15ab53d292970dabeb6f288fadd3849f (diff)
downloadtcl-f4d65f439e4de5c04bfafc2ce2b2678776c35248.zip
tcl-f4d65f439e4de5c04bfafc2ce2b2678776c35248.tar.gz
tcl-f4d65f439e4de5c04bfafc2ce2b2678776c35248.tar.bz2
TIP#269 implementation
-rw-r--r--ChangeLog9
-rw-r--r--doc/string.n7
-rw-r--r--generic/tclCmdMZ.c75
-rw-r--r--tests/string.test51
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