diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | doc/string.n | 7 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 75 | ||||
| -rw-r--r-- | tests/string.test | 51 |
4 files changed, 128 insertions, 14 deletions
@@ -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 |