Attachment "switch.patch" to
ticket [1836519fff]
added by
pspjuth
2007-11-22 22:21:07.
diff -ur -x .git tclmaster/doc/switch.n tcl/doc/switch.n
--- tclmaster/doc/switch.n 2008-06-27 12:31:36.000000000 +0200
+++ tcl/doc/switch.n 2007-11-22 08:18:48.000000000 +0100
@@ -156,7 +156,7 @@
When matching against regular expressions, information about what
exactly matched is easily obtained using the \fB\-matchvar\fR option:
.CS
-\fBswitch\fR \-regexp \-matchvar foo \-\- $bar {
+\fBswitch\fR \-regexp \-matchvar foo $bar {
a(b*)c {
puts "Found [string length [lindex $foo 1]] 'b's"
}
diff -ur -x .git tclmaster/generic/tclCmdMZ.c tcl/generic/tclCmdMZ.c
--- tclmaster/generic/tclCmdMZ.c 2007-11-22 08:24:16.000000000 +0100
+++ tcl/generic/tclCmdMZ.c 2007-11-22 08:18:48.000000000 +0100
@@ -2560,8 +2560,9 @@
* to mess with the line information */
/*
- * If you add options that make -e and -g not unique prefixes of -exact or
- * -glob, you *must* fix TclCompileSwitchCmd's option parser as well.
+ * If you add options that make -e, -g or -n not unique prefixes of -exact
+ * -glob or -nocase, you *must* fix TclCompileSwitchCmd's option parser as
+ * well.
*/
static CONST char *options[] = {
@@ -2581,7 +2582,7 @@
matchVarObj = NULL;
numMatchesSaved = 0;
noCase = 0;
- for (i = 1; i < objc; i++) {
+ for (i = 1; i < (objc - 2); i++) {
if (TclGetString(objv[i])[0] != '-') {
break;
}
@@ -2601,7 +2602,7 @@
if (index == OPT_INDEXV) {
i++;
- if (i == objc) {
+ if (i == (objc - 2)) {
Tcl_AppendResult(interp,
"missing variable name argument to -indexvar option",
NULL);
@@ -2611,7 +2612,7 @@
numMatchesSaved = -1;
} else if (index == OPT_MATCHV) {
i++;
- if (i == objc) {
+ if (i == (objc - 2)) {
Tcl_AppendResult(interp,
"missing variable name argument to -matchvar option",
NULL);
diff -ur -x .git tclmaster/generic/tclCompCmds.c tcl/generic/tclCompCmds.c
--- tclmaster/generic/tclCompCmds.c 2007-11-22 08:24:16.000000000 +0100
+++ tcl/generic/tclCompCmds.c 2007-11-22 08:18:48.000000000 +0100
@@ -3605,11 +3605,16 @@
int noCase; /* Has the -nocase flag been given? */
int foundMode = 0; /* Have we seen a mode flag yet? */
int isListedArms = 0;
+ int optionEnd = 0;
int i, valueIndex;
DefineLineInformation; /* TIP #280 */
/*
* Only handle the following versions:
+ * switch word {pattern body ...}
+ * switch -exact word {pattern body ...}
+ * switch -glob word {pattern body ...}
+ * switch -regexp -- word {pattern body ...}
* switch -- word {pattern body ...}
* switch -exact -- word {pattern body ...}
* switch -glob -- word {pattern body ...}
@@ -3629,11 +3634,7 @@
numWords = parsePtr->numWords-1;
/*
- * Check for options. There must be at least one, --, because without that
- * there is no way to statically avoid the problems you get from strings-
- * -to-be-matched that start with a - (the 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).
+ * Check for options.
*/
noCase = 0;
@@ -3682,6 +3683,9 @@
valueIndex++;
continue;
} else if ((size == 2) && !memcmp(chrs, "--", 2)) {
+ optionEnd = 1;
+ tokenPtr=TokenAfter(tokenPtr);
+ numWords--;
valueIndex++;
break;
}
@@ -3695,11 +3699,16 @@
return TCL_ERROR;
}
- if (numWords < 3) {
+
+ /*
+ * If we haven't seen -- we can only compile the case where
+ * only two arguments remain.
+ */
+
+ if (!optionEnd && numWords != 2) {
return TCL_ERROR;
}
- tokenPtr = TokenAfter(tokenPtr);
- numWords--;
+
if (noCase && (mode != Switch_Exact)) {
/*
* Can't compile this case; no opcode for case-insensitive equality!
diff -ur -x .git tclmaster/tests/switch.test tcl/tests/switch.test
--- tclmaster/tests/switch.test 2008-06-27 12:31:36.000000000 +0200
+++ tcl/tests/switch.test 2007-11-22 08:18:48.000000000 +0100
@@ -288,9 +288,9 @@
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} {
+test switch-9.2 {unpaired pattern} {
list [catch {switch -- x} msg] $msg
-} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
+} {1 {extra switch pattern with no 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?}"}}
@@ -317,13 +317,13 @@
} {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-10.1 {compiled -exact switch} {
- if 1 {switch -exact -- a {a {format 1} b {format 2}}}
+ if 1 {switch -exact a {a {format 1} b {format 2}}}
} 1
test switch-10.2 {compiled -exact switch} {
if 1 {switch -exact -- b {a {format 1} b {format 2}}}
} 2
test switch-10.3 {compiled -exact switch} {
- if 1 {switch -exact -- c {a {format 1} b {format 2}}}
+ if 1 {switch -exact c {a {format 1} b {format 2}}}
} {}
test switch-10.4 {compiled -exact switch} {
if 1 {
@@ -354,7 +354,7 @@
proc cswtest-glob s {
set x 0; set y 0
foreach c [split $s {}] {
- switch -glob -- $c {
+ switch -glob $c {
a {incr x}
b {incr y}
}
@@ -368,7 +368,7 @@
proc iswtest-glob s {
set x 0; set y 0; set switch switch
foreach c [split $s {}] {
- $switch -glob -- $c {
+ $switch -glob $c {
a {incr x}
b {incr y}
}
@@ -382,7 +382,7 @@
proc cswtest-exact s {
set x 0; set y 0
foreach c [split $s {}] {
- switch -exact -- $c {
+ switch -exact $c {
a {incr x}
b {incr y}
}
@@ -396,7 +396,7 @@
proc iswtest-exact s {
set x 0; set y 0; set switch switch
foreach c [split $s {}] {
- $switch -exact -- $c {
+ $switch -exact $c {
a {incr x}
b {incr y}
}
@@ -410,7 +410,7 @@
proc cswtest2-glob s {
set x 0; set y 0; set z 0
foreach c [split $s {}] {
- switch -glob -- $c {
+ switch -glob $c {
a {incr x}
b {incr y}
default {incr z}
@@ -425,7 +425,7 @@
proc iswtest2-glob s {
set x 0; set y 0; set z 0; set switch switch
foreach c [split $s {}] {
- $switch -glob -- $c {
+ $switch -glob $c {
a {incr x}
b {incr y}
default {incr z}
@@ -440,7 +440,7 @@
proc cswtest2-exact s {
set x 0; set y 0; set z 0
foreach c [split $s {}] {
- switch -exact -- $c {
+ switch -exact $c {
a {incr x}
b {incr y}
default {incr z}
@@ -455,7 +455,7 @@
proc iswtest2-exact s {
set x 0; set y 0; set z 0; set switch switch
foreach c [split $s {}] {
- $switch -exact -- $c {
+ $switch -exact $c {
a {incr x}
b {incr y}
default {incr z}
@@ -481,7 +481,7 @@
cswtest2-glob abcb
} [iswtest2-glob abcb]
proc cswtest-default-exact {x} {
- switch -- $x {
+ switch $x {
a* {return b}
aa {return c}
default {return d}
