summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog16
-rw-r--r--generic/tclCmdMZ.c17
-rw-r--r--tests/for.test53
-rw-r--r--tests/switch.test57
4 files changed, 138 insertions, 5 deletions
diff --git a/ChangeLog b/ChangeLog
index cd2dae3..d182cbc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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?"}}