[25] | 1 | # Commands covered: switch |
---|
| 2 | # |
---|
| 3 | # This file contains a collection of tests for one or more of the Tcl |
---|
| 4 | # built-in commands. Sourcing this file into Tcl runs the tests and |
---|
| 5 | # generates output for errors. No output means no errors were found. |
---|
| 6 | # |
---|
| 7 | # Copyright (c) 1993 The Regents of the University of California. |
---|
| 8 | # Copyright (c) 1994 Sun Microsystems, Inc. |
---|
| 9 | # Copyright (c) 1998-1999 by Scriptics Corporation. |
---|
| 10 | # |
---|
| 11 | # See the file "license.terms" for information on usage and redistribution |
---|
| 12 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 13 | # |
---|
| 14 | # RCS: @(#) $Id: switch.test,v 1.21 2008/03/21 19:09:13 dkf Exp $ |
---|
| 15 | |
---|
| 16 | if {[lsearch [namespace children] ::tcltest] == -1} { |
---|
| 17 | package require tcltest 2 |
---|
| 18 | namespace import -force ::tcltest::* |
---|
| 19 | } |
---|
| 20 | |
---|
| 21 | test switch-1.1 {simple patterns} { |
---|
| 22 | switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4} |
---|
| 23 | } 1 |
---|
| 24 | test switch-1.2 {simple patterns} { |
---|
| 25 | switch b a {subst 1} b {subst 2} c {subst 3} default {subst 4} |
---|
| 26 | } 2 |
---|
| 27 | test switch-1.3 {simple patterns} { |
---|
| 28 | switch x a {subst 1} b {subst 2} c {subst 3} default {subst 4} |
---|
| 29 | } 4 |
---|
| 30 | test switch-1.4 {simple patterns} { |
---|
| 31 | switch x a {subst 1} b {subst 2} c {subst 3} |
---|
| 32 | } {} |
---|
| 33 | test switch-1.5 {simple pattern matches many times} { |
---|
| 34 | switch b a {subst 1} b {subst 2} b {subst 3} b {subst 4} |
---|
| 35 | } 2 |
---|
| 36 | test switch-1.6 {simple patterns} { |
---|
| 37 | switch default a {subst 1} default {subst 2} c {subst 3} default {subst 4} |
---|
| 38 | } 2 |
---|
| 39 | test switch-1.7 {simple patterns} { |
---|
| 40 | switch x a {subst 1} default {subst 2} c {subst 3} default {subst 4} |
---|
| 41 | } 4 |
---|
| 42 | test switch-1.8 {simple patterns with -nocase} { |
---|
| 43 | switch -nocase b a {subst 1} b {subst 2} c {subst 3} default {subst 4} |
---|
| 44 | } 2 |
---|
| 45 | test switch-1.9 {simple patterns with -nocase} { |
---|
| 46 | switch -nocase B a {subst 1} b {subst 2} c {subst 3} default {subst 4} |
---|
| 47 | } 2 |
---|
| 48 | test switch-1.10 {simple patterns with -nocase} { |
---|
| 49 | switch -nocase b a {subst 1} B {subst 2} c {subst 3} default {subst 4} |
---|
| 50 | } 2 |
---|
| 51 | test switch-1.11 {simple patterns with -nocase} { |
---|
| 52 | switch -nocase x a {subst 1} default {subst 2} c {subst 3} default {subst 4} |
---|
| 53 | } 4 |
---|
| 54 | |
---|
| 55 | test switch-2.1 {single-argument form for pattern/command pairs} { |
---|
| 56 | switch b { |
---|
| 57 | a {subst 1} |
---|
| 58 | b {subst 2} |
---|
| 59 | default {subst 6} |
---|
| 60 | } |
---|
| 61 | } {2} |
---|
| 62 | test switch-2.2 {single-argument form for pattern/command pairs} -body { |
---|
| 63 | switch z {a 2 b} |
---|
| 64 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 65 | |
---|
| 66 | test switch-3.1 {-exact vs. -glob vs. -regexp} { |
---|
| 67 | switch -exact aaaab { |
---|
| 68 | ^a*b$ {subst regexp} |
---|
| 69 | *b {subst glob} |
---|
| 70 | aaaab {subst exact} |
---|
| 71 | default {subst none} |
---|
| 72 | } |
---|
| 73 | } exact |
---|
| 74 | test switch-3.2 {-exact vs. -glob vs. -regexp} { |
---|
| 75 | switch -regexp aaaab { |
---|
| 76 | ^a*b$ {subst regexp} |
---|
| 77 | *b {subst glob} |
---|
| 78 | aaaab {subst exact} |
---|
| 79 | default {subst none} |
---|
| 80 | } |
---|
| 81 | } regexp |
---|
| 82 | test switch-3.3 {-exact vs. -glob vs. -regexp} { |
---|
| 83 | switch -glob aaaab { |
---|
| 84 | ^a*b$ {subst regexp} |
---|
| 85 | *b {subst glob} |
---|
| 86 | aaaab {subst exact} |
---|
| 87 | default {subst none} |
---|
| 88 | } |
---|
| 89 | } glob |
---|
| 90 | test switch-3.4 {-exact vs. -glob vs. -regexp} { |
---|
| 91 | switch aaaab {^a*b$} {subst regexp} *b {subst glob} \ |
---|
| 92 | aaaab {subst exact} default {subst none} |
---|
| 93 | } exact |
---|
| 94 | test switch-3.5 {-exact vs. -glob vs. -regexp} { |
---|
| 95 | switch -- -glob { |
---|
| 96 | ^g.*b$ {subst regexp} |
---|
| 97 | -* {subst glob} |
---|
| 98 | -glob {subst exact} |
---|
| 99 | default {subst none} |
---|
| 100 | } |
---|
| 101 | } exact |
---|
| 102 | test switch-3.6 {-exact vs. -glob vs. -regexp} -body { |
---|
| 103 | switch -foo a b c |
---|
| 104 | } -returnCodes error -result {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --} |
---|
| 105 | test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} { |
---|
| 106 | switch -exact -nocase aaaab { |
---|
| 107 | ^a*b$ {subst regexp} |
---|
| 108 | *b {subst glob} |
---|
| 109 | aaaab {subst exact} |
---|
| 110 | default {subst none} |
---|
| 111 | } |
---|
| 112 | } exact |
---|
| 113 | test switch-3.8 {-exact vs. -glob vs. -regexp with -nocase} { |
---|
| 114 | switch -regexp -nocase aaaab { |
---|
| 115 | ^a*b$ {subst regexp} |
---|
| 116 | *b {subst glob} |
---|
| 117 | aaaab {subst exact} |
---|
| 118 | default {subst none} |
---|
| 119 | } |
---|
| 120 | } regexp |
---|
| 121 | test switch-3.9 {-exact vs. -glob vs. -regexp with -nocase} { |
---|
| 122 | switch -glob -nocase aaaab { |
---|
| 123 | ^a*b$ {subst regexp} |
---|
| 124 | *b {subst glob} |
---|
| 125 | aaaab {subst exact} |
---|
| 126 | default {subst none} |
---|
| 127 | } |
---|
| 128 | } glob |
---|
| 129 | test switch-3.10 {-exact vs. -glob vs. -regexp with -nocase} { |
---|
| 130 | switch -nocase aaaab {^a*b$} {subst regexp} *b {subst glob} \ |
---|
| 131 | aaaab {subst exact} default {subst none} |
---|
| 132 | } exact |
---|
| 133 | test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} { |
---|
| 134 | switch -nocase -- -glob { |
---|
| 135 | ^g.*b$ {subst regexp} |
---|
| 136 | -* {subst glob} |
---|
| 137 | -glob {subst exact} |
---|
| 138 | default {subst none} |
---|
| 139 | } |
---|
| 140 | } exact |
---|
| 141 | test switch-3.12 {-exact vs. -glob vs. -regexp} { |
---|
| 142 | switch -exa Foo Foo {set result OK} |
---|
| 143 | } OK |
---|
| 144 | test switch-3.13 {-exact vs. -glob vs. -regexp} { |
---|
| 145 | switch -gl Foo Fo? {set result OK} |
---|
| 146 | } OK |
---|
| 147 | test switch-3.14 {-exact vs. -glob vs. -regexp} { |
---|
| 148 | switch -re Foo Fo. {set result OK} |
---|
| 149 | } OK |
---|
| 150 | test switch-3.15 {-exact vs. -glob vs. -regexp} -body { |
---|
| 151 | switch -exact -exact Foo Foo {set result OK} |
---|
| 152 | } -returnCodes error -result {bad option "-exact": -exact option already found} |
---|
| 153 | test switch-3.16 {-exact vs. -glob vs. -regexp} -body { |
---|
| 154 | switch -exact -glob Foo Foo {set result OK} |
---|
| 155 | } -returnCodes error -result {bad option "-glob": -exact option already found} |
---|
| 156 | test switch-3.17 {-exact vs. -glob vs. -regexp} -body { |
---|
| 157 | switch -glob -regexp Foo Foo {set result OK} |
---|
| 158 | } -returnCodes error -result {bad option "-regexp": -glob option already found} |
---|
| 159 | test switch-3.18 {-exact vs. -glob vs. -regexp} -body { |
---|
| 160 | switch -regexp -glob Foo Foo {set result OK} |
---|
| 161 | } -returnCodes error -result {bad option "-glob": -regexp option already found} |
---|
| 162 | |
---|
| 163 | test switch-4.1 {error in executed command} { |
---|
| 164 | list [catch {switch a a {error "Just a test"} default {subst 1}} msg] \ |
---|
| 165 | $msg $::errorInfo |
---|
| 166 | } {1 {Just a test} {Just a test |
---|
| 167 | while executing |
---|
| 168 | "error "Just a test"" |
---|
| 169 | ("a" arm line 1) |
---|
| 170 | invoked from within |
---|
| 171 | "switch a a {error "Just a test"} default {subst 1}"}} |
---|
| 172 | test switch-4.2 {error: not enough args} -returnCodes error -body { |
---|
| 173 | switch |
---|
| 174 | } -result {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"} |
---|
| 175 | test switch-4.3 {error: pattern with no body} -body { |
---|
| 176 | switch a b |
---|
| 177 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 178 | test switch-4.4 {error: pattern with no body} -body { |
---|
| 179 | switch a b {subst 1} c |
---|
| 180 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 181 | test switch-4.5 {error in default command} { |
---|
| 182 | list [catch {switch foo a {error switch1} b {error switch 3} \ |
---|
| 183 | default {error switch2}} msg] $msg $::errorInfo |
---|
| 184 | } {1 switch2 {switch2 |
---|
| 185 | while executing |
---|
| 186 | "error switch2" |
---|
| 187 | ("default" arm line 1) |
---|
| 188 | invoked from within |
---|
| 189 | "switch foo a {error switch1} b {error switch 3} default {error switch2}"}} |
---|
| 190 | |
---|
| 191 | test switch-5.1 {errors in -regexp matching} -returnCodes error -body { |
---|
| 192 | switch -regexp aaaab { |
---|
| 193 | *b {subst glob} |
---|
| 194 | aaaab {subst exact} |
---|
| 195 | default {subst none} |
---|
| 196 | } |
---|
| 197 | } -result {couldn't compile regular expression pattern: quantifier operand invalid} |
---|
| 198 | |
---|
| 199 | test switch-6.1 {backslashes in patterns} { |
---|
| 200 | switch -exact {\a\$\.\[} { |
---|
| 201 | \a\$\.\[ {subst first} |
---|
| 202 | \a\\$\.\\[ {subst second} |
---|
| 203 | \\a\\$\\.\\[ {subst third} |
---|
| 204 | {\a\\$\.\\[} {subst fourth} |
---|
| 205 | {\\a\\$\\.\\[} {subst fifth} |
---|
| 206 | default {subst none} |
---|
| 207 | } |
---|
| 208 | } third |
---|
| 209 | test switch-6.2 {backslashes in patterns} { |
---|
| 210 | switch -exact {\a\$\.\[} { |
---|
| 211 | \a\$\.\[ {subst first} |
---|
| 212 | {\a\$\.\[} {subst second} |
---|
| 213 | {{\a\$\.\[}} {subst third} |
---|
| 214 | default {subst none} |
---|
| 215 | } |
---|
| 216 | } second |
---|
| 217 | |
---|
| 218 | test switch-7.1 {"-" bodies} { |
---|
| 219 | switch a { |
---|
| 220 | a - |
---|
| 221 | b - |
---|
| 222 | c {subst 1} |
---|
| 223 | default {subst 2} |
---|
| 224 | } |
---|
| 225 | } 1 |
---|
| 226 | test switch-7.2 {"-" bodies} -body { |
---|
| 227 | switch a { |
---|
| 228 | a - |
---|
| 229 | b - |
---|
| 230 | c - |
---|
| 231 | } |
---|
| 232 | } -returnCodes error -result {no body specified for pattern "c"} |
---|
| 233 | test switch-7.3 {"-" bodies} -body { |
---|
| 234 | switch a { |
---|
| 235 | a - |
---|
| 236 | b -foo |
---|
| 237 | c - |
---|
| 238 | } |
---|
| 239 | } -returnCodes error -result {no body specified for pattern "c"} |
---|
| 240 | test switch-7.4 {"-" bodies} -body { |
---|
| 241 | switch a { |
---|
| 242 | a - |
---|
| 243 | b -foo |
---|
| 244 | c {} |
---|
| 245 | } |
---|
| 246 | } -returnCodes error -result {invalid command name "-foo"} |
---|
| 247 | |
---|
| 248 | test switch-8.1 {empty body} { |
---|
| 249 | set msg {} |
---|
| 250 | switch {2} { |
---|
| 251 | 1 {set msg 1} |
---|
| 252 | 2 {} |
---|
| 253 | default {set msg 2} |
---|
| 254 | } |
---|
| 255 | } {} |
---|
| 256 | proc test_switch_body {} { |
---|
| 257 | return "INVOKED" |
---|
| 258 | } |
---|
| 259 | test switch-8.2 {weird body text, variable} { |
---|
| 260 | set cmd {test_switch_body} |
---|
| 261 | switch Foo { |
---|
| 262 | Foo $cmd |
---|
| 263 | } |
---|
| 264 | } {INVOKED} |
---|
| 265 | test switch-8.3 {weird body text, variable} { |
---|
| 266 | set cmd {test_switch_body} |
---|
| 267 | switch Foo { |
---|
| 268 | Foo {$cmd} |
---|
| 269 | } |
---|
| 270 | } {INVOKED} |
---|
| 271 | |
---|
| 272 | test switch-9.1 {empty pattern/body list} -returnCodes error -body { |
---|
| 273 | switch x |
---|
| 274 | } -result {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"} |
---|
| 275 | test switch-9.2 {unpaired pattern} -returnCodes error -body { |
---|
| 276 | switch -- x |
---|
| 277 | } -result {extra switch pattern with no body} |
---|
| 278 | test switch-9.3 {empty pattern/body list} -body { |
---|
| 279 | switch x {} |
---|
| 280 | } -returnCodes error -result {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"} |
---|
| 281 | test switch-9.4 {empty pattern/body list} -body { |
---|
| 282 | switch -- x {} |
---|
| 283 | } -returnCodes error -result {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"} |
---|
| 284 | test switch-9.5 {unpaired pattern} -body { |
---|
| 285 | switch x a {} b |
---|
| 286 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 287 | test switch-9.6 {unpaired pattern} -body { |
---|
| 288 | switch x {a {} b} |
---|
| 289 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 290 | test switch-9.7 {unpaired pattern} -body { |
---|
| 291 | switch x a {} # comment b |
---|
| 292 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 293 | test switch-9.8 {unpaired pattern} -returnCodes error -body { |
---|
| 294 | switch x {a {} # comment b} |
---|
| 295 | } -result {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation} |
---|
| 296 | test switch-9.9 {unpaired pattern} -body { |
---|
| 297 | switch x a {} x {} # comment b |
---|
| 298 | } -returnCodes error -result {extra switch pattern with no body} |
---|
| 299 | test switch-9.10 {unpaired pattern} -returnCodes error -body { |
---|
| 300 | switch x {a {} x {} # comment b} |
---|
| 301 | } -result {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation} |
---|
| 302 | |
---|
| 303 | test switch-10.1 {compiled -exact switch} { |
---|
| 304 | if 1 {switch -exact -- a {a {subst 1} b {subst 2}}} |
---|
| 305 | } 1 |
---|
| 306 | test switch-10.1a {compiled -exact switch} { |
---|
| 307 | if 1 {switch -exact a {a {subst 1} b {subst 2}}} |
---|
| 308 | } 1 |
---|
| 309 | test switch-10.2 {compiled -exact switch} { |
---|
| 310 | if 1 {switch -exact -- b {a {subst 1} b {subst 2}}} |
---|
| 311 | } 2 |
---|
| 312 | test switch-10.2a {compiled -exact switch} { |
---|
| 313 | if 1 {switch -exact b {a {subst 1} b {subst 2}}} |
---|
| 314 | } 2 |
---|
| 315 | test switch-10.3 {compiled -exact switch} { |
---|
| 316 | if 1 {switch -exact -- c {a {subst 1} b {subst 2}}} |
---|
| 317 | } {} |
---|
| 318 | test switch-10.3a {compiled -exact switch} { |
---|
| 319 | if 1 {switch -exact c {a {subst 1} b {subst 2}}} |
---|
| 320 | } {} |
---|
| 321 | test switch-10.4 {compiled -exact switch} { |
---|
| 322 | if 1 { |
---|
| 323 | set x 0 |
---|
| 324 | switch -exact -- c {a {subst 1} b {subst 2}} |
---|
| 325 | } |
---|
| 326 | } {} |
---|
| 327 | test switch-10.5 {compiled -exact switch} { |
---|
| 328 | if 1 {switch -exact -- a {a - aa {subst 1} b {subst 2}}} |
---|
| 329 | } 1 |
---|
| 330 | test switch-10.6 {compiled -exact switch} { |
---|
| 331 | if 1 {switch -exact -- b {a { |
---|
| 332 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 333 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 334 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 335 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 336 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 337 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 338 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 339 | set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 |
---|
| 340 | } b {subst 2}}} |
---|
| 341 | } 2 |
---|
| 342 | |
---|
| 343 | # Command variants are: |
---|
| 344 | # c* are compiled switches, i* are interpreted |
---|
| 345 | # *-glob use glob matching, *-exact use exact matching |
---|
| 346 | # *2* include a default clause (different results too.) |
---|
| 347 | proc cswtest-glob s { |
---|
| 348 | set x 0; set y 0 |
---|
| 349 | foreach c [split $s {}] { |
---|
| 350 | switch -glob $c { |
---|
| 351 | a {incr x} |
---|
| 352 | b {incr y} |
---|
| 353 | } |
---|
| 354 | } |
---|
| 355 | set x [expr {$x*100}]; set y [expr {$y*100}] |
---|
| 356 | foreach c [split $s {}] { |
---|
| 357 | switch -glob -- $c a {incr x} b {incr y} |
---|
| 358 | } |
---|
| 359 | return $x,$y |
---|
| 360 | } |
---|
| 361 | proc iswtest-glob s { |
---|
| 362 | set x 0; set y 0; set switch switch |
---|
| 363 | foreach c [split $s {}] { |
---|
| 364 | $switch -glob $c { |
---|
| 365 | a {incr x} |
---|
| 366 | b {incr y} |
---|
| 367 | } |
---|
| 368 | } |
---|
| 369 | set x [expr {$x*100}]; set y [expr {$y*100}] |
---|
| 370 | foreach c [split $s {}] { |
---|
| 371 | $switch -glob -- $c a {incr x} b {incr y} |
---|
| 372 | } |
---|
| 373 | return $x,$y |
---|
| 374 | } |
---|
| 375 | proc cswtest-exact s { |
---|
| 376 | set x 0; set y 0 |
---|
| 377 | foreach c [split $s {}] { |
---|
| 378 | switch -exact $c { |
---|
| 379 | a {incr x} |
---|
| 380 | b {incr y} |
---|
| 381 | } |
---|
| 382 | } |
---|
| 383 | set x [expr {$x*100}]; set y [expr {$y*100}] |
---|
| 384 | foreach c [split $s {}] { |
---|
| 385 | switch -exact -- $c a {incr x} b {incr y} |
---|
| 386 | } |
---|
| 387 | return $x,$y |
---|
| 388 | } |
---|
| 389 | proc iswtest-exact s { |
---|
| 390 | set x 0; set y 0; set switch switch |
---|
| 391 | foreach c [split $s {}] { |
---|
| 392 | $switch -exact $c { |
---|
| 393 | a {incr x} |
---|
| 394 | b {incr y} |
---|
| 395 | } |
---|
| 396 | } |
---|
| 397 | set x [expr {$x*100}]; set y [expr {$y*100}] |
---|
| 398 | foreach c [split $s {}] { |
---|
| 399 | $switch -exact -- $c a {incr x} b {incr y} |
---|
| 400 | } |
---|
| 401 | return $x,$y |
---|
| 402 | } |
---|
| 403 | proc cswtest2-glob s { |
---|
| 404 | set x 0; set y 0; set z 0 |
---|
| 405 | foreach c [split $s {}] { |
---|
| 406 | switch -glob $c { |
---|
| 407 | a {incr x} |
---|
| 408 | b {incr y} |
---|
| 409 | default {incr z} |
---|
| 410 | } |
---|
| 411 | } |
---|
| 412 | set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] |
---|
| 413 | foreach c [split $s {}] { |
---|
| 414 | switch -glob -- $c a {incr x} b {incr y} default {incr z} |
---|
| 415 | } |
---|
| 416 | return $x,$y,$z |
---|
| 417 | } |
---|
| 418 | proc iswtest2-glob s { |
---|
| 419 | set x 0; set y 0; set z 0; set switch switch |
---|
| 420 | foreach c [split $s {}] { |
---|
| 421 | $switch -glob $c { |
---|
| 422 | a {incr x} |
---|
| 423 | b {incr y} |
---|
| 424 | default {incr z} |
---|
| 425 | } |
---|
| 426 | } |
---|
| 427 | set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] |
---|
| 428 | foreach c [split $s {}] { |
---|
| 429 | $switch -glob -- $c a {incr x} b {incr y} default {incr z} |
---|
| 430 | } |
---|
| 431 | return $x,$y,$z |
---|
| 432 | } |
---|
| 433 | proc cswtest2-exact s { |
---|
| 434 | set x 0; set y 0; set z 0 |
---|
| 435 | foreach c [split $s {}] { |
---|
| 436 | switch -exact $c { |
---|
| 437 | a {incr x} |
---|
| 438 | b {incr y} |
---|
| 439 | default {incr z} |
---|
| 440 | } |
---|
| 441 | } |
---|
| 442 | set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] |
---|
| 443 | foreach c [split $s {}] { |
---|
| 444 | switch -exact -- $c a {incr x} b {incr y} default {incr z} |
---|
| 445 | } |
---|
| 446 | return $x,$y,$z |
---|
| 447 | } |
---|
| 448 | proc iswtest2-exact s { |
---|
| 449 | set x 0; set y 0; set z 0; set switch switch |
---|
| 450 | foreach c [split $s {}] { |
---|
| 451 | $switch -exact $c { |
---|
| 452 | a {incr x} |
---|
| 453 | b {incr y} |
---|
| 454 | default {incr z} |
---|
| 455 | } |
---|
| 456 | } |
---|
| 457 | set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] |
---|
| 458 | foreach c [split $s {}] { |
---|
| 459 | $switch -exact -- $c a {incr x} b {incr y} default {incr z} |
---|
| 460 | } |
---|
| 461 | return $x,$y,$z |
---|
| 462 | } |
---|
| 463 | |
---|
| 464 | test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} { |
---|
| 465 | cswtest-exact abcb |
---|
| 466 | } [iswtest-exact abcb] |
---|
| 467 | test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} { |
---|
| 468 | cswtest-glob abcb |
---|
| 469 | } [iswtest-glob abcb] |
---|
| 470 | test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} { |
---|
| 471 | cswtest2-exact abcb |
---|
| 472 | } [iswtest2-exact abcb] |
---|
| 473 | test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} { |
---|
| 474 | cswtest2-glob abcb |
---|
| 475 | } [iswtest2-glob abcb] |
---|
| 476 | proc cswtest-default-exact {x} { |
---|
| 477 | switch -- $x { |
---|
| 478 | a* {return b} |
---|
| 479 | aa {return c} |
---|
| 480 | default {return d} |
---|
| 481 | } |
---|
| 482 | } |
---|
| 483 | test switch-10.11 {default to exact matching when compiled} { |
---|
| 484 | cswtest-default-exact a |
---|
| 485 | } d |
---|
| 486 | test switch-10.12 {default to exact matching when compiled} { |
---|
| 487 | cswtest-default-exact aa |
---|
| 488 | } c |
---|
| 489 | test switch-10.13 {default to exact matching when compiled} { |
---|
| 490 | cswtest-default-exact a* |
---|
| 491 | } b |
---|
| 492 | test switch-10.14 {default to exact matching when compiled} { |
---|
| 493 | cswtest-default-exact a** |
---|
| 494 | } d |
---|
| 495 | rename cswtest-default-exact {} |
---|
| 496 | rename cswtest-glob {} |
---|
| 497 | rename iswtest-glob {} |
---|
| 498 | rename cswtest2-glob {} |
---|
| 499 | rename iswtest2-glob {} |
---|
| 500 | rename cswtest-exact {} |
---|
| 501 | rename iswtest-exact {} |
---|
| 502 | rename cswtest2-exact {} |
---|
| 503 | rename iswtest2-exact {} |
---|
| 504 | # Bug 1891827 |
---|
| 505 | test switch-10.15 {(not) compiled exact nocase regression} { |
---|
| 506 | apply {{} { |
---|
| 507 | switch -nocase -- A { a {return yes} default {return no} } |
---|
| 508 | }} |
---|
| 509 | } yes |
---|
| 510 | |
---|
| 511 | # Added due to TIP#75 |
---|
| 512 | test switch-11.1 {regexp matching with -matchvar} { |
---|
| 513 | switch -regexp -matchvar x -- abc {.(.). {set x}} |
---|
| 514 | } {abc b} |
---|
| 515 | test switch-11.2 {regexp matching with -matchvar} { |
---|
| 516 | set x GOOD |
---|
| 517 | switch -regexp -matchvar x -- abc {.(.).. {list $x z}} |
---|
| 518 | set x |
---|
| 519 | } GOOD |
---|
| 520 | test switch-11.3 {regexp matching with -matchvar} { |
---|
| 521 | switch -regexp -matchvar x -- "a b c" {.(.). {set x}} |
---|
| 522 | } {{a b} { }} |
---|
| 523 | test switch-11.4 {regexp matching with -matchvar} { |
---|
| 524 | set x BAD |
---|
| 525 | switch -regexp -matchvar x -- "a b c" { |
---|
| 526 | bc {list $x YES} |
---|
| 527 | default {list $x NO} |
---|
| 528 | } |
---|
| 529 | } {{} NO} |
---|
| 530 | test switch-11.5 {-matchvar without -regexp} { |
---|
| 531 | set x {} |
---|
| 532 | list [catch {switch -glob -matchvar x -- abc . {set x}} msg] $x $msg |
---|
| 533 | } {1 {} {-matchvar option requires -regexp option}} |
---|
| 534 | test switch-11.6 {-matchvar unwritable} { |
---|
| 535 | set x {} |
---|
| 536 | list [catch {switch -regexp -matchvar x(x) -- abc . {set x}} msg] $x $msg |
---|
| 537 | } {1 {} {can't set "x(x)": variable isn't array}} |
---|
| 538 | |
---|
| 539 | test switch-12.1 {regexp matching with -indexvar} { |
---|
| 540 | switch -regexp -indexvar x -- abc {.(.). {set x}} |
---|
| 541 | } {{0 3} {1 2}} |
---|
| 542 | test switch-12.2 {regexp matching with -indexvar} { |
---|
| 543 | set x GOOD |
---|
| 544 | switch -regexp -indexvar x -- abc {.(.).. {list $x z}} |
---|
| 545 | set x |
---|
| 546 | } GOOD |
---|
| 547 | test switch-12.3 {regexp matching with -indexvar} { |
---|
| 548 | switch -regexp -indexvar x -- "a b c" {.(.). {set x}} |
---|
| 549 | } {{0 3} {1 2}} |
---|
| 550 | test switch-12.4 {regexp matching with -indexvar} { |
---|
| 551 | set x BAD |
---|
| 552 | switch -regexp -indexvar x -- "a b c" { |
---|
| 553 | bc {list $x YES} |
---|
| 554 | default {list $x NO} |
---|
| 555 | } |
---|
| 556 | } {{} NO} |
---|
| 557 | test switch-12.5 {-indexvar without -regexp} { |
---|
| 558 | set x {} |
---|
| 559 | list [catch {switch -glob -indexvar x -- abc . {set x}} msg] $x $msg |
---|
| 560 | } {1 {} {-indexvar option requires -regexp option}} |
---|
| 561 | test switch-12.6 {-indexvar unwritable} { |
---|
| 562 | set x {} |
---|
| 563 | list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg |
---|
| 564 | } {1 {} {can't set "x(x)": variable isn't array}} |
---|
| 565 | |
---|
| 566 | test switch-13.1 {-indexvar -matchvar combinations} { |
---|
| 567 | switch -regexp -indexvar x -matchvar y abc { |
---|
| 568 | . {list $x $y} |
---|
| 569 | } |
---|
| 570 | } {{{0 1}} a} |
---|
| 571 | test switch-13.2 {-indexvar -matchvar combinations} { |
---|
| 572 | switch -regexp -indexvar x -matchvar y abc { |
---|
| 573 | .$ {list $x $y} |
---|
| 574 | } |
---|
| 575 | } {{{2 3}} c} |
---|
| 576 | test switch-13.3 {-indexvar -matchvar combinations} { |
---|
| 577 | switch -regexp -indexvar x -matchvar y abc { |
---|
| 578 | (.)(.)(.) {list $x $y} |
---|
| 579 | } |
---|
| 580 | } {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}} |
---|
| 581 | test switch-13.4 {-indexvar -matchvar combinations} { |
---|
| 582 | set x - |
---|
| 583 | set y - |
---|
| 584 | switch -regexp -indexvar x -matchvar y abc { |
---|
| 585 | (.)(.)(.). - |
---|
| 586 | default {list $x $y} |
---|
| 587 | } |
---|
| 588 | } {{} {}} |
---|
| 589 | test switch-13.5 {-indexvar -matchvar combinations} { |
---|
| 590 | set x - |
---|
| 591 | set y - |
---|
| 592 | list [catch { |
---|
| 593 | switch -regexp -indexvar x(x) -matchvar y abc {. {list $x $y}} |
---|
| 594 | } msg] $x $y $msg |
---|
| 595 | } {1 - - {can't set "x(x)": variable isn't array}} |
---|
| 596 | test switch-13.6 {-indexvar -matchvar combinations} { |
---|
| 597 | set x - |
---|
| 598 | set y - |
---|
| 599 | list [catch { |
---|
| 600 | switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}} |
---|
| 601 | } msg] $x $y $msg |
---|
| 602 | } {1 {{0 1}} - {can't set "y(y)": variable isn't array}} |
---|
| 603 | |
---|
| 604 | test switch-14.1 {-regexp -- compilation [Bug 1854399]} { |
---|
| 605 | switch -regexp -- 0 { |
---|
| 606 | {[0-9]+} {return yes} |
---|
| 607 | default {return no} |
---|
| 608 | } |
---|
| 609 | foo |
---|
| 610 | } yes |
---|
| 611 | test switch-14.2 {-regexp -- compilation [Bug 1854399]} { |
---|
| 612 | proc foo {} { |
---|
| 613 | switch -regexp -- 0 { |
---|
| 614 | {[0-9]+} {return yes} |
---|
| 615 | default {return no} |
---|
| 616 | } |
---|
| 617 | } |
---|
| 618 | foo |
---|
| 619 | } yes |
---|
| 620 | test switch-14.3 {-regexp -- compilation [Bug 1854399]} { |
---|
| 621 | proc foo {} { |
---|
| 622 | switch -regexp -- 0 { |
---|
| 623 | {\d+} {return yes} |
---|
| 624 | default {return no} |
---|
| 625 | } |
---|
| 626 | } |
---|
| 627 | foo |
---|
| 628 | } yes |
---|
| 629 | test switch-14.4 {-regexp -- compilation [Bug 1854399]} { |
---|
| 630 | proc foo {} { |
---|
| 631 | switch -regexp -- 0 { |
---|
| 632 | {0} {return yes} |
---|
| 633 | default {return no} |
---|
| 634 | } |
---|
| 635 | } |
---|
| 636 | foo |
---|
| 637 | } yes |
---|
| 638 | test switch-14.5 {switch -regexp compilation} { |
---|
| 639 | apply {{} { |
---|
| 640 | switch -regexp -- 0 { |
---|
| 641 | {0|1|2} {return yes} |
---|
| 642 | default {return no} |
---|
| 643 | } |
---|
| 644 | }} |
---|
| 645 | } yes |
---|
| 646 | test switch-14.6 {switch -regexp compilation} { |
---|
| 647 | apply {{} { |
---|
| 648 | switch -regexp -- 0 { |
---|
| 649 | {0|11|222} {return yes} |
---|
| 650 | default {return no} |
---|
| 651 | } |
---|
| 652 | }} |
---|
| 653 | } yes |
---|
| 654 | test switch-14.7 {switch -regexp compilation} { |
---|
| 655 | apply {{} { |
---|
| 656 | switch -regexp -- 0 { |
---|
| 657 | {[012]} {return yes} |
---|
| 658 | default {return no} |
---|
| 659 | } |
---|
| 660 | }} |
---|
| 661 | } yes |
---|
| 662 | test switch-14.8 {switch -regexp compilation} { |
---|
| 663 | apply {{} { |
---|
| 664 | switch -regexp -- x { |
---|
| 665 | {0|1|2} {return yes} |
---|
| 666 | default {return no} |
---|
| 667 | } |
---|
| 668 | }} |
---|
| 669 | } no |
---|
| 670 | test switch-14.9 {switch -regexp compilation} { |
---|
| 671 | apply {{} { |
---|
| 672 | switch -regexp -- x { |
---|
| 673 | {0|11|222} {return yes} |
---|
| 674 | default {return no} |
---|
| 675 | } |
---|
| 676 | }} |
---|
| 677 | } no |
---|
| 678 | test switch-14.10 {switch -regexp compilation} { |
---|
| 679 | apply {{} { |
---|
| 680 | switch -regexp -- x { |
---|
| 681 | {[012]} {return yes} |
---|
| 682 | default {return no} |
---|
| 683 | } |
---|
| 684 | }} |
---|
| 685 | } no |
---|
| 686 | test switch-14.11 {switch -regexp compilation} { |
---|
| 687 | apply {{} { |
---|
| 688 | switch -regexp -- x { |
---|
| 689 | {0|1|2} {return yes} |
---|
| 690 | .+ {return yes2} |
---|
| 691 | default {return no} |
---|
| 692 | } |
---|
| 693 | }} |
---|
| 694 | } yes2 |
---|
| 695 | test switch-14.12 {switch -regexp compilation} { |
---|
| 696 | apply {{} { |
---|
| 697 | switch -regexp -- x { |
---|
| 698 | {0|11|222} {return yes} |
---|
| 699 | .+ {return yes2} |
---|
| 700 | default {return no} |
---|
| 701 | } |
---|
| 702 | }} |
---|
| 703 | } yes2 |
---|
| 704 | test switch-14.13 {switch -regexp compilation} { |
---|
| 705 | apply {{} { |
---|
| 706 | switch -regexp -- x { |
---|
| 707 | {[012]} {return yes} |
---|
| 708 | .+ {return yes2} |
---|
| 709 | default {return no} |
---|
| 710 | } |
---|
| 711 | }} |
---|
| 712 | } yes2 |
---|
| 713 | test switch-14.14 {switch -regexp compilation} { |
---|
| 714 | apply {{} { |
---|
| 715 | switch -regexp -- {} { |
---|
| 716 | {0|1|2} {return yes} |
---|
| 717 | .+ {return yes2} |
---|
| 718 | default {return no} |
---|
| 719 | } |
---|
| 720 | }} |
---|
| 721 | } no |
---|
| 722 | test switch-14.15 {switch -regexp compilation} { |
---|
| 723 | apply {{} { |
---|
| 724 | switch -regexp -- {} { |
---|
| 725 | {0|11|222} {return yes} |
---|
| 726 | .+ {return yes2} |
---|
| 727 | default {return no} |
---|
| 728 | } |
---|
| 729 | }} |
---|
| 730 | } no |
---|
| 731 | test switch-14.16 {switch -regexp compilation} { |
---|
| 732 | apply {{} { |
---|
| 733 | switch -regexp -- {} { |
---|
| 734 | {[012]} {return yes} |
---|
| 735 | .+ {return yes2} |
---|
| 736 | default {return no} |
---|
| 737 | } |
---|
| 738 | }} |
---|
| 739 | } no |
---|
| 740 | |
---|
| 741 | # cleanup |
---|
| 742 | ::tcltest::cleanupTests |
---|
| 743 | return |
---|
| 744 | |
---|
| 745 | # Local Variables: |
---|
| 746 | # mode: tcl |
---|
| 747 | # End: |
---|