From 854f85bb1700aa6f106cc6a443cb0eb2e917f2de Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jun 2005 11:00:24 +0000 Subject: Implementation of TIP#241 from Joe Mistachkin Also compilation of [switch -glob -nocase] from Donal Fellows --- ChangeLog | 12 ++++++++ doc/lsearch.n | 9 +++++- doc/lsort.n | 11 ++++++-- doc/switch.n | 7 +++-- generic/tclCmdIL.c | 62 +++++++++++++++++++++++++++++++---------- generic/tclCmdMZ.c | 24 ++++++++++------ generic/tclCompCmds.c | 76 ++++++++++++++++++++++++++++++--------------------- tests/cmdIL.test | 10 +++++-- tests/lsearch.test | 35 +++++++++++++++++++++--- tests/switch.test | 52 +++++++++++++++++++++++++++++++++-- win/tclWinPort.h | 9 +++++- 11 files changed, 240 insertions(+), 67 deletions(-) diff --git a/ChangeLog b/ChangeLog index b00587a..6dbbf82 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,17 @@ 2005-06-01 Donal K. Fellows + * generic/tclCompCmds.c (TclCompileSwitchCmd): Allow compilation + of -nocase -glob [switch]es (only one we know how to compile). + + TIP#241 IMPLEMENTATION from Joe Mistachkin + + * generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd): + * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Implementation of -nocase + option for [lsearch], [lsort] and [switch] commands. + * win/tclWinPort.h: Win uses nonstandard function names... + * tests/cmdIL.test, tests/lsearch.test, tests/switch.test: Tests + * doc/lsearch.n, doc/lsort.n, doc/switch.n: Docs + * generic/tclCompCmds.c (TclCompileLindexCmd): Compile the most common case of [lindex] more efficiently. diff --git a/doc/lsearch.n b/doc/lsearch.n index 823be5e..afe601f 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -7,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lsearch.n,v 1.24 2005/05/10 18:34:01 kennykb Exp $ +'\" RCS: @(#) $Id: lsearch.n,v 1.25 2005/06/01 11:00:33 dkf Exp $ '\" .so man.macros .TH lsearch n 8.5 Tcl "Tcl Built-In Commands" @@ -95,6 +95,13 @@ dictionary-equal when exactly equal. .TP \fB\-integer\fR The list elements are to be compared as integers. +.VS 8.5 +.TP +\fB\-nocase\fR +Causes comparisons to be handled in a case-insensitive manner. Has no +effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or +\fB\-real\fR options. +.VE 8.5 .TP \fB\-real\fR The list elements are to be compared as floating-point values. diff --git a/doc/lsort.n b/doc/lsort.n index a921745..09962d2 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -7,10 +7,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lsort.n,v 1.20 2005/05/10 18:34:02 kennykb Exp $ +'\" RCS: @(#) $Id: lsort.n,v 1.21 2005/06/01 11:00:33 dkf Exp $ '\" .so man.macros -.TH lsort n 8.3 Tcl "Tcl Built-In Commands" +.TH lsort n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -104,6 +104,13 @@ returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE +.VS 8.5 +.TP 20 +\fB\-nocase\fR +Causes comparisons to be handled in a case-insensitive manner. Has no +effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or +\fB\-real\fR options. +.VE 8.5 .TP 20 \fB\-unique\fR If this option is specified, then only the last set of duplicate diff --git a/doc/switch.n b/doc/switch.n index c508262..83103cb 100644 --- a/doc/switch.n +++ b/doc/switch.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: switch.n,v 1.8 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: switch.n,v 1.9 2005/06/01 11:00:33 dkf Exp $ '\" .so man.macros -.TH switch n 7.0 Tcl "Tcl Built-In Commands" +.TH switch n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -51,6 +51,9 @@ expression matching '\" Options defined by TIP#75 .VS 8.5 .TP 10 +\fB\-nocase\fR +Causes comparisons to be handled in a case-insensitive manner. +.TP 10 \fB\-matchvar\fR \fIvarName\fR This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of matches diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b68f7ba..883ed45 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.75 2005/05/30 00:04:46 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.76 2005/06/01 11:00:34 dkf Exp $ */ #include "tclInt.h" @@ -36,6 +36,15 @@ typedef struct SortElement { } SortElement; /* + * These function pointer types are used with the "lsearch" and "lsort" + * commands to facilitate the "-nocase" option. + */ + +typedef int (*SortStrCmpFn_t) _ANSI_ARGS_((const char *, const char *)); +typedef int (*SortMemCmpFn_t) _ANSI_ARGS_((const void *, const void *, + size_t)); + +/* * The "lsort" command needs to pass certain information down to the * function that compares two list elements, and the comparison function * needs to pass success or failure information back up to the top-level @@ -47,6 +56,8 @@ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* * values defined below */ + SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with + * ASCII mode). */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode * is SORTMODE_COMMAND. Pre-initialized to * hold base of command.*/ @@ -3201,7 +3212,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) char *bytes, *patternBytes; int i, match, mode, index, result, listc, length, elemLen; int dataType, isIncreasing, lower, upper, patInt, objInt; - int offset, allMatches, inlineReturn, negatedMatch, returnSubindices; + int offset, allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; @@ -3209,15 +3220,17 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) static CONST char *options[] = { "-all", "-ascii", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", - "-inline", "-integer", "-not", "-real", - "-regexp", "-sorted", "-start", "-subindices", + "-inline", "-integer", "-nocase", "-not", + "-real", "-regexp", "-sorted", "-start", + "-subindices", NULL }; enum options { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, - LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, - LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, LSEARCH_SUBINDICES + LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, + LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, + LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -3225,6 +3238,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) enum modes { EXACT, GLOB, REGEXP, SORTED }; + SortStrCmpFn_t strCmpFn = strcmp; mode = GLOB; dataType = ASCII; @@ -3236,6 +3250,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) listPtr = NULL; startPtr = NULL; offset = 0; + noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 0; sortInfo.sortMode = 0; @@ -3288,6 +3303,10 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case LSEARCH_INTEGER: /* -integer */ dataType = INTEGER; break; + case LSEARCH_NOCASE: /* -nocase */ + strCmpFn = strcasecmp; + noCase = 1; + break; case LSEARCH_NOT: /* -not */ negatedMatch = 1; break; @@ -3422,7 +3441,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * regexp rep before the list rep. */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], - TCL_REG_ADVANCED | TCL_REG_NOSUB); + TCL_REG_ADVANCED | TCL_REG_NOSUB | + (noCase ? TCL_REG_NOCASE : 0)); if (regexp == NULL) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); @@ -3531,7 +3551,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); - match = strcmp(patternBytes, bytes); + match = strCmpFn(patternBytes, bytes); break; case DICTIONARY: bytes = TclGetString(itemPtr); @@ -3629,8 +3649,16 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case ASCII: bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { - match = (memcmp(bytes, patternBytes, - (size_t) length) == 0); + /* + * This split allows for more optimal + * compilation of memcmp + */ + if (noCase) { + match = (strcasecmp(bytes, patternBytes) == 0); + } else { + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); + } } break; case DICTIONARY: @@ -3669,7 +3697,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) break; case GLOB: - match = Tcl_StringMatch(TclGetString(itemPtr), patternBytes); + match = Tcl_StringCaseMatch(TclGetString(itemPtr), + patternBytes, noCase); break; case REGEXP: match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); @@ -3871,12 +3900,13 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) * comparison function */ static CONST char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", - "-index", "-indices", "-integer", "-real", "-unique", (char *) NULL + "-index", "-indices", "-integer", "-nocase", "-real", "-unique", + (char *) NULL }; enum Lsort_Switches { LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, - LSORT_REAL, LSORT_UNIQUE + LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE }; if (objc < 2) { @@ -3890,6 +3920,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; + sortInfo.strCmpFn = strcmp; sortInfo.indexv = NULL; sortInfo.indexc = 0; sortInfo.interp = interp; @@ -3988,6 +4019,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) case LSORT_INTEGER: sortInfo.sortMode = SORTMODE_INTEGER; break; + case LSORT_NOCASE: + sortInfo.strCmpFn = strcasecmp; + break; case LSORT_REAL: sortInfo.sortMode = SORTMODE_REAL; break; @@ -4262,7 +4296,7 @@ SortCompare(objPtr1, objPtr2, infoPtr) } if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(TclGetString(objPtr1), TclGetString(objPtr2)); + order = infoPtr->strCmpFn(TclGetString(objPtr1), TclGetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare( TclGetString(objPtr1), TclGetString(objPtr2)); diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b507fe5..99182f3 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.122 2005/05/25 19:27:10 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.123 2005/06/01 11:00:34 dkf Exp $ */ #include "tclInt.h" @@ -2520,7 +2520,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, j, index, mode, result, splitObjs, numMatchesSaved; + int i, j, index, mode, result, splitObjs, numMatchesSaved, noCase; char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; @@ -2531,17 +2531,21 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * parser as well. */ static CONST char *options[] = { - "-exact", "-glob", "-indexvar", "-matchvar", "-regexp", "--", - NULL + "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", + "--", NULL }; enum options { - OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_REGEXP, OPT_LAST + OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, + OPT_LAST }; + typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *)); + strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; indexVarObj = NULL; matchVarObj = NULL; numMatchesSaved = 0; + noCase = 0; for (i = 1; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; @@ -2580,6 +2584,9 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } matchVarObj = objv[i]; numMatchesSaved = -1; + } else if (index == OPT_NOCASE) { + strCmpFn = strcasecmp; + noCase = 1; } else { mode = index; } @@ -2718,18 +2725,19 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } else { switch (mode) { case OPT_EXACT: - if (strcmp(TclGetString(stringObj), pattern) == 0) { + if (strCmpFn(TclGetString(stringObj), pattern) == 0) { goto matchFound; } break; case OPT_GLOB: - if (Tcl_StringMatch(TclGetString(stringObj), pattern)) { + if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, + noCase)) { goto matchFound; } break; case OPT_REGEXP: regExpr = Tcl_GetRegExpFromObj(interp, objv[i], - TCL_REG_ADVANCED); + TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); if (regExpr == NULL) { return TCL_ERROR; } else { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c412329..9598d84 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.69 2005/06/01 10:02:19 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.70 2005/06/01 11:00:35 dkf Exp $ */ #include "tclInt.h" @@ -2723,6 +2723,7 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) * to the current (or next) real body. */ int savedStackDepth = envPtr->currStackDepth; + int noCase; int i; /* @@ -2753,50 +2754,55 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) * interpreted code falls apart if it encounters them, so we punt * if we *might* encounter them as that is the easiest way of * emulating the behaviour). - * - * Note that this parsing would probably be better done with a - * loop, but it works for now... */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } else { - register int size = tokenPtr[1].size; + noCase = 0; + mode = Switch_Exact; + for (; numWords>=3 ; tokenPtr+=2,numWords--) { + register unsigned size = tokenPtr[1].size; register CONST char *chrs = tokenPtr[1].start; /* - * Assume that -e and -g are unique prefixes of -exact and -glob + * We only process literal options, and we assume that -e, -g + * and -n are unique prefixes of -exact, -glob and -nocase + * respectively (true at time of writing). */ - if (size < 2) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { return TCL_ERROR; } - if ((size <= 6) && (numWords >= 4) - && !strncmp(chrs, "-exact", (unsigned) TclMin(size, 6))) { + + if ((size <= 6) && !memcmp(chrs, "-exact", size)) { mode = Switch_Exact; - tokenPtr += 2; - numWords--; - } else if ((size <= 5) && (numWords >= 4) - && !strncmp(chrs, "-glob", (unsigned) TclMin(size, 5))) { + continue; + } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { mode = Switch_Glob; - tokenPtr += 2; - numWords--; - } else if ((size == 2) && (numWords >= 3) && !strncmp(chrs, "--", 2)) { - /* - * If no control flag present, use exact matching (the default). - * - * We end up re-checking this word, but that's the way things are. - */ - mode = Switch_Exact; - } else { - return TCL_ERROR; + continue; + } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { + noCase = 1; + continue; + } else if ((size == 2) && !memcmp(chrs, "--", 2)) { + break; } + + /* + * The switch command has many flags we cannot compile at all + * (e.g. all the RE-related ones) which we must have + * encountered. Either that or we have run off the end. The + * action here is the same: punt to interpreted version. + */ + return TCL_ERROR; } - if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (tokenPtr[1].size != 2) - || strncmp(tokenPtr[1].start, "--", 2)) { + if (numWords < 3) { return TCL_ERROR; } tokenPtr += 2; numWords--; + if (noCase && (mode == Switch_Exact)) { + /* + * Can't compile this case! + */ + return TCL_ERROR; + } /* * The value to test against is going to always get pushed on the @@ -2902,6 +2908,14 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { + /* + * Odd number of words (>1) available, or no words at all + * available. Both are error cases, so punt and let the + * interpreted-version generate the error message. Note that + * the second case probably should get caught earlier, but + * it's easy to check here again anyway because it'd cause a + * nasty crash otherwise. + */ return TCL_ERROR; } else { bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); @@ -2962,7 +2976,7 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) int nextArmFixupIndex = -1; envPtr->currStackDepth = savedStackDepth + 1; if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || - strncmp(bodyToken[numWords-2]->start, "default", 7)) { + memcmp(bodyToken[numWords-2]->start, "default", 7)) { /* * Generate the test for the arm. This code is slightly * inefficient, but much simpler than the first version. @@ -2975,7 +2989,7 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) TclEmitOpcode(INST_STR_EQ, envPtr); break; case Switch_Glob: - TclEmitInstInt1(INST_STR_MATCH, /*nocase*/0, envPtr); + TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); break; default: Tcl_Panic("unknown switch mode: %d",mode); diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 644111e..f1653b4 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdIL.test,v 1.25 2005/05/10 18:35:01 kennykb Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.26 2005/06/01 11:00:35 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -23,7 +23,7 @@ test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { } {1 {wrong # args: should be "lsort ?options? list"}} test cmdIL-1.2 {Tcl_LsortObjCmd procedure} { list [catch {lsort -foo {1 3 2 5}} msg] $msg -} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -real, or -unique}} +} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique}} test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} { lsort {d e c b a \{ d35 d300} } {a b c d d300 d35 e \{} @@ -383,6 +383,12 @@ test cmdIL-4.32 {DictionaryCompare procedure, chars between Z and a in ASCII} { test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA ! c CC `] } [list ! ` AA c CC] +test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { + lsort -ascii -nocase {d e c b a d35 d300 100 20} +} {100 20 a b c d d300 d35 e} +test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { + lsort -ascii -nocase {d E c B a D35 d300 100 20} +} {100 20 a B c d d300 D35 E} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { diff --git a/tests/lsearch.test b/tests/lsearch.test index ec04689..0155bdd 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lsearch.test,v 1.15 2005/05/10 18:35:22 kennykb Exp $ +# RCS: @(#) $Id: lsearch.test,v 1.16 2005/06/01 11:00:35 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -61,7 +61,25 @@ test lsearch-2.9 {search modes} { } 1 test lsearch-2.10 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg -} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} +} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} +test lsearch-2.11 {search modes with -nocase} { + lsearch -exact -nocase {a b c A B C} A +} 0 +test lsearch-2.12 {search modes with -nocase} { + lsearch -glob -nocase {a b c A B C} A* +} 0 +test lsearch-2.13 {search modes with -nocase} { + lsearch -regexp -nocase {a b c A B C} ^A\$ +} 0 +test lsearch-2.14 {search modes without -nocase} { + lsearch -exact {a b c A B C} A +} 3 +test lsearch-2.15 {search modes without -nocase} { + lsearch -glob {a b c A B C} A* +} 3 +test lsearch-2.16 {search modes without -nocase} { + lsearch -regexp {a b c A B C} ^A\$ +} 3 test lsearch-3.1 {lsearch errors} { list [catch lsearch msg] $msg @@ -71,10 +89,10 @@ test lsearch-3.2 {lsearch errors} { } {1 {wrong # args: should be "lsearch ?options? list pattern"}} test lsearch-3.3 {lsearch errors} { list [catch {lsearch a b c} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} +} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.4 {lsearch errors} { list [catch {lsearch a b c d} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} +} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.5 {lsearch errors} { list [catch {lsearch "\{" b} msg] $msg } {1 {unmatched open brace in list}} @@ -320,6 +338,15 @@ test lsearch-13.1 {search for all matches} { test lsearch-13.2 {search for all matches} { lsearch -all {a b a c a d} a } {0 2 4} +test lsearch-13.3 {search for all matches with -nocase} { + lsearch -all -exact -nocase {a b c A B C} A +} {0 3} +test lsearch-13.4 {search for all matches with -nocase} { + lsearch -all -glob -nocase {a b c A B C} A* +} {0 3} +test lsearch-13.5 {search for all matches with -nocase} { + lsearch -all -regexp -nocase {a b c A B C} ^A\$ +} {0 3} test lsearch-14.1 {combinations: -all and -inline} { lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a* diff --git a/tests/switch.test b/tests/switch.test index b06155c..e05f2ca 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: switch.test,v 1.12 2005/05/10 18:35:24 kennykb Exp $ +# RCS: @(#) $Id: switch.test,v 1.13 2005/06/01 11:00:35 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -39,6 +39,18 @@ test switch-1.6 {simple patterns} { test switch-1.7 {simple patterns} { switch x a {format 1} default {format 2} c {format 3} default {format 4} } 4 +test switch-1.8 {simple patterns with -nocase} { + switch -nocase b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.9 {simple patterns with -nocase} { + switch -nocase B a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.10 {simple patterns with -nocase} { + switch -nocase b a {format 1} B {format 2} c {format 3} default {format 4} +} 2 +test switch-1.11 {simple patterns with -nocase} { + switch -nocase x a {format 1} default {format 2} c {format 3} default {format 4} +} 4 test switch-2.1 {single-argument form for pattern/command pairs} { switch b { @@ -89,7 +101,43 @@ test switch-3.5 {-exact vs. -glob vs. -regexp} { } exact test switch-3.6 {-exact vs. -glob vs. -regexp} { list [catch {switch -foo a b c} msg] $msg -} {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -regexp, or --}} +} {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}} +test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} { + switch -exact -nocase aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} exact +test switch-3.8 {-exact vs. -glob vs. -regexp with -nocase} { + switch -regexp -nocase aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} regexp +test switch-3.9 {-exact vs. -glob vs. -regexp with -nocase} { + switch -glob -nocase aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} glob +test switch-3.10 {-exact vs. -glob vs. -regexp with -nocase} { + switch -nocase aaaab {^a*b$} {concat regexp} *b {concat glob} \ + aaaab {concat exact} default {concat none} +} exact +test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} { + switch -nocase -- -glob { + ^g.*b$ {concat regexp} + -* {concat glob} + -glob {concat exact} + default {concat none} + } +} exact test switch-4.1 {error in executed command} { list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ diff --git a/win/tclWinPort.h b/win/tclWinPort.h index ac82929..1263e12 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPort.h,v 1.43 2004/11/03 21:07:01 davygrvy Exp $ + * RCS: @(#) $Id: tclWinPort.h,v 1.44 2005/06/01 11:00:36 dkf Exp $ */ #ifndef _TCLWINPORT @@ -45,6 +45,13 @@ #include /* + * These string functions are not defined with the same names on Windows. + */ + +#define strcasecmp stricmp +#define strncasecmp strnicmp + +/* * Need to block out these includes for building extensions with MetroWerks * compiler for Win32. */ -- cgit v0.12