summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2001-11-27 13:30:54 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2001-11-27 13:30:54 (GMT)
commit13c3412b50a2103ed9425c67562e759c90f5230a (patch)
tree8d58510553bab658b7806be159dcf0686f170552
parenta0e747d0e5212069f116cfed10ddfc28bbbcf7f1 (diff)
downloadtcl-13c3412b50a2103ed9425c67562e759c90f5230a.zip
tcl-13c3412b50a2103ed9425c67562e759c90f5230a.tar.gz
tcl-13c3412b50a2103ed9425c67562e759c90f5230a.tar.bz2
Tightened up the argument passing for [switch] to promote robuster scripts.
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclCmdMZ.c90
-rw-r--r--tests/switch.test49
3 files changed, 103 insertions, 46 deletions
diff --git a/ChangeLog b/ChangeLog
index 1f78b96..5c0f30d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2001-11-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ * tests/switch.test (switch-9.*): Added tests to exercise more of
+ the argument checking. (switch-7.2,switch-7.3): Test changed
+ behaviour slightly.
+ * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reworked argument parsing
+ to be stricter about what it accepts. This should make uses of
+ the [switch] command be more maintainable. [Bug 475397, reported
+ by Don Porter.]
+
2001-11-26 Don Porter <dgp@users.sourceforge.net>
* generic/tclIntPlatDecls.h: 'make genstubs' after changes
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 22634d5..c43b926 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -13,7 +13,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.51 2001/11/21 17:17:17 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.52 2001/11/27 13:30:54 dkf Exp $
*/
#include "tclInt.h"
@@ -2482,9 +2482,10 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int i, j, index, mode, matched, result, splitObjs, seenComment;
+ int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
+ Tcl_Obj *CONST *savedObjv = objv;
static char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
@@ -2532,46 +2533,72 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
- objv = listv;
- splitObjs = 1;
- }
- seenComment = 0;
- for (i = 0; i < objc; i += 2) {
- if (i == objc - 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra switch pattern with no body", -1);
-
- /*
- * Check if this can be due to a badly placed comment
- * in the switch block
- */
-
- if (splitObjs && seenComment) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1);
- }
+ /*
+ * Ensure that the list is non-empty.
+ */
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, savedObjv,
+ "?switches? string {pattern body ... ?default body?}");
return TCL_ERROR;
}
+ objv = listv;
+ splitObjs = 1;
+ }
- /*
- * See if the pattern matches the string.
- */
+ /*
+ * Complain if there is an odd number of words in the list of
+ * patterns and bodies.
+ */
- pattern = Tcl_GetString(objv[i]);
+ if (objc % 2) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
/*
+ * Check if this can be due to a badly placed comment
+ * in the switch block.
+ *
* The following is an heuristic to detect the infamous
* "comment in switch" error: just check if a pattern
* begins with '#'.
*/
- if (splitObjs && *pattern == '#') {
- seenComment = 1;
+ if (splitObjs) {
+ for (i=0 ; i<objc ; i+=2) {
+ if (Tcl_GetString(objv[i])[0] == '#') {
+ Tcl_AppendResult(interp, ", this may be due to a ",
+ "comment incorrectly placed outside of a ",
+ "switch body - see the \"switch\" ",
+ "documentation", NULL);
+ break;
+ }
+ }
}
+ return TCL_ERROR;
+ }
+
+ /*
+ * Complain if the last body is a continuation. Note that this
+ * check assumes that the list is non-empty!
+ */
+
+ if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "no body specified for pattern \"",
+ Tcl_GetString(objv[objc-2]), "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i = 0; i < objc; i += 2) {
+ /*
+ * See if the pattern matches the string.
+ */
+
+ pattern = Tcl_GetString(objv[i]);
+
matched = 0;
if ((i == objc - 2)
&& (*pattern == 'd')
@@ -2605,10 +2632,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
for (j = i + 1; ; j += 2) {
if (j >= objc) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "no body specified for pattern \"", pattern,
- "\"", (char *) NULL);
- return TCL_ERROR;
+ /*
+ * This shouldn't happen since we've checked that the
+ * last body is not a continuation...
+ */
+ panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
diff --git a/tests/switch.test b/tests/switch.test
index 6f5b9c2..f1ae7c7 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.6 2000/04/10 17:19:05 ericm Exp $
+# RCS: @(#) $Id: switch.test,v 1.7 2001/11/27 13:30:54 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -162,7 +162,7 @@ test switch-7.2 {"-" bodies} {
c -
}
} msg] $msg
-} {1 {no body specified for pattern "a"}}
+} {1 {no body specified for pattern "c"}}
test switch-7.3 {"-" bodies} {
list [catch {
switch a {
@@ -171,7 +171,7 @@ test switch-7.3 {"-" bodies} {
c -
}
} msg] $msg
-} {1 {invalid command name "-foo"}}
+} {1 {no body specified for pattern "c"}}
test switch-8.1 {empty body} {
set msg {}
@@ -182,18 +182,37 @@ test switch-8.1 {empty body} {
}
} {}
+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?"}}
+test switch-9.2 {empty pattern/body list} {
+ list [catch {switch -- x} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
+test switch-9.3 {empty pattern/body list} {
+ list [catch {switch x {}} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}}
+test switch-9.4 {empty pattern/body list} {
+ list [catch {switch -- x {}} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}}
+test switch-9.5 {unpaired pattern} {
+ list [catch {switch x a {} b} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.6 {unpaired pattern} {
+ list [catch {switch x {a {} b}} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.7 {unpaired pattern} {
+ list [catch {switch x a {} # comment b} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.8 {unpaired pattern} {
+ list [catch {switch x {a {} # comment b}} msg] $msg
+} {1 {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation}}
+test switch-9.9 {unpaired pattern} {
+ list [catch {switch x a {} x {} # comment b} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.10 {unpaired pattern} {
+ list [catch {switch x {a {} x {} # comment b}} msg] $msg
+} {1 {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation}}
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-