diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 17 | ||||
| -rw-r--r-- | tests/for.test | 53 | ||||
| -rw-r--r-- | tests/switch.test | 57 |
4 files changed, 138 insertions, 5 deletions
@@ -1,3 +1,19 @@ +2005-06-20 Mo DeJong <mdejong@users.sourceforge.net> + + * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Generate + an error if a mode argument like -exact is passed + more than once to the switch command. The previous + implementation silently accepted invalid switch + invocations like [switch -exact -glob $str ...]. + * tests/for.test: Check some error cases when + invoking continue and break inside a for loop + next script. + * tests/switch.test: Add checks for shortened + version of a mode argument like -exact. Add + test for more than one mode argument. Add test + for odd case of passing a variable as a + body script. + 2005-06-18 Daniel Steffen <das@users.sourceforge.net> * generic/tclInt.h: ensure WORDS_BIGENDIAN is defined correctly with fat diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3c796a8..7d0f80f 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.125 2005/06/07 09:07:14 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.126 2005/06/20 07:49:11 mdejong 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, noCase; + int i, j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; @@ -2542,6 +2542,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; + foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; numMatchesSaved = 0; @@ -2588,6 +2589,18 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) strCmpFn = strcasecmp; noCase = 1; } else { + if ( foundmode ) { + /* Mode already set via -exact, -glob, or -regexp */ + Tcl_AppendResult(interp, + "bad option \"", + TclGetString(objv[i]), + "\": ", + options[mode], + " option already found", + (char *) NULL); + return TCL_ERROR; + } + foundmode = 1; mode = index; } } diff --git a/tests/for.test b/tests/for.test index 0217f78..7c968f6 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: for.test,v 1.11 2005/05/10 18:35:20 kennykb Exp $ +# RCS: @(#) $Id: for.test,v 1.12 2005/06/20 07:49:11 mdejong Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -763,7 +763,56 @@ test for-6.16 {Tcl_ForObjCmd: for command result} { set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}] set a } {} - +test for-6.17 {Tcl_ForObjCmd: for command result} { + list \ + [catch {for {break} {1} {} {}} err] $err \ + [catch {for {continue} {1} {} {}} err] $err \ + [catch {for {} {[break]} {} {}} err] $err \ + [catch {for {} {[continue]} {} {}} err] $err \ + [catch {for {} {1} {break} {}} err] $err \ + [catch {for {} {1} {continue} {}} err] $err \ +} [list \ + 3 {} \ + 4 {} \ + 3 {} \ + 4 {} \ + 0 {} \ + 4 {} \ + ] +test for-6.18 {Tcl_ForObjCmd: for command result} { + proc p6181 {} { + for {break} {1} {} {} + } + proc p6182 {} { + for {continue} {1} {} {} + } + proc p6183 {} { + for {} {[break]} {} {} + } + proc p6184 {} { + for {} {[continue]} {} {} + } + proc p6185 {} { + for {} {1} {break} {} + } + proc p6186 {} { + for {} {1} {continue} {} + } + list \ + [catch {p6181} err] $err \ + [catch {p6182} err] $err \ + [catch {p6183} err] $err \ + [catch {p6184} err] $err \ + [catch {p6185} err] $err \ + [catch {p6186} err] $err +} [list \ + 1 {invoked "break" outside of a loop} \ + 1 {invoked "continue" outside of a loop} \ + 1 {invoked "break" outside of a loop} \ + 1 {invoked "continue" outside of a loop} \ + 0 {} \ + 1 {invoked "continue" outside of a loop} \ + ] # cleanup diff --git a/tests/switch.test b/tests/switch.test index e05f2ca..ed1d38a 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.13 2005/06/01 11:00:35 dkf Exp $ +# RCS: @(#) $Id: switch.test,v 1.14 2005/06/20 07:49:12 mdejong Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -139,6 +139,34 @@ test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} { } } exact +test switch-3.7 {-exact vs. -glob vs. -regexp} { + list [catch {switch -exa Foo Foo {set result OK}} msg] $msg +} {0 OK} + +test switch-3.8 {-exact vs. -glob vs. -regexp} { + list [catch {switch -gl Foo Fo? {set result OK}} msg] $msg +} {0 OK} + +test switch-3.9 {-exact vs. -glob vs. -regexp} { + list [catch {switch -re Foo Fo. {set result OK}} msg] $msg +} {0 OK} + +test switch-3.10 {-exact vs. -glob vs. -regexp} { + list [catch {switch -exact -exact Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-exact": -exact option already found}} + +test switch-3.11 {-exact vs. -glob vs. -regexp} { + list [catch {switch -exact -glob Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-glob": -exact option already found}} + +test switch-3.12 {-exact vs. -glob vs. -regexp} { + list [catch {switch -glob -regexp Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-regexp": -glob option already found}} + +test switch-3.13 {-exact vs. -glob vs. -regexp} { + list [catch {switch -regexp -glob Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-glob": -regexp option already found}} + test switch-4.1 {error in executed command} { list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ $msg $errorInfo @@ -220,6 +248,15 @@ test switch-7.3 {"-" bodies} { } } msg] $msg } {1 {no body specified for pattern "c"}} +test switch-7.4 {"-" bodies} { + list [catch { + switch a { + a - + b -foo + c {} + } + } msg] $msg +} {1 {invalid command name "-foo"}} test switch-8.1 {empty body} { set msg {} @@ -230,6 +267,24 @@ test switch-8.1 {empty body} { } } {} +proc test_switch_body {} { + return "INVOKED" +} + +test switch-8.2 {weird body text, variable} { + set cmd {test_switch_body} + switch Foo { + Foo $cmd + } +} {INVOKED} + +test switch-8.3 {weird body text, variable} { + set cmd {test_switch_body} + switch Foo { + Foo {$cmd} + } +} {INVOKED} + test switch-9.1 {empty pattern/body list} { list [catch {switch x} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} |