sl@0: # Commands covered: switch sl@0: # sl@0: # This file contains a collection of tests for one or more of the Tcl sl@0: # built-in commands. Sourcing this file into Tcl runs the tests and sl@0: # generates output for errors. No output means no errors were found. sl@0: # sl@0: # Copyright (c) 1993 The Regents of the University of California. sl@0: # Copyright (c) 1994 Sun Microsystems, Inc. sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: # sl@0: # See the file "license.terms" for information on usage and redistribution sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: # sl@0: # RCS: @(#) $Id: switch.test,v 1.7 2001/11/27 13:30:54 dkf Exp $ sl@0: sl@0: if {[lsearch [namespace children] ::tcltest] == -1} { sl@0: package require tcltest sl@0: namespace import -force ::tcltest::* sl@0: } sl@0: sl@0: test switch-1.1 {simple patterns} { sl@0: switch a a {format 1} b {format 2} c {format 3} default {format 4} sl@0: } 1 sl@0: test switch-1.2 {simple patterns} { sl@0: switch b a {format 1} b {format 2} c {format 3} default {format 4} sl@0: } 2 sl@0: test switch-1.3 {simple patterns} { sl@0: switch x a {format 1} b {format 2} c {format 3} default {format 4} sl@0: } 4 sl@0: test switch-1.4 {simple patterns} { sl@0: switch x a {format 1} b {format 2} c {format 3} sl@0: } {} sl@0: test switch-1.5 {simple pattern matches many times} { sl@0: switch b a {format 1} b {format 2} b {format 3} b {format 4} sl@0: } 2 sl@0: test switch-1.6 {simple patterns} { sl@0: switch default a {format 1} default {format 2} c {format 3} default {format 4} sl@0: } 2 sl@0: test switch-1.7 {simple patterns} { sl@0: switch x a {format 1} default {format 2} c {format 3} default {format 4} sl@0: } 4 sl@0: sl@0: test switch-2.1 {single-argument form for pattern/command pairs} { sl@0: switch b { sl@0: a {format 1} sl@0: b {format 2} sl@0: default {format 6} sl@0: } sl@0: } {2} sl@0: test switch-2.2 {single-argument form for pattern/command pairs} { sl@0: list [catch {switch z {a 2 b}} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: sl@0: test switch-3.1 {-exact vs. -glob vs. -regexp} { sl@0: switch -exact aaaab { sl@0: ^a*b$ {concat regexp} sl@0: *b {concat glob} sl@0: aaaab {concat exact} sl@0: default {concat none} sl@0: } sl@0: } exact sl@0: test switch-3.2 {-exact vs. -glob vs. -regexp} { sl@0: switch -regexp aaaab { sl@0: ^a*b$ {concat regexp} sl@0: *b {concat glob} sl@0: aaaab {concat exact} sl@0: default {concat none} sl@0: } sl@0: } regexp sl@0: test switch-3.3 {-exact vs. -glob vs. -regexp} { sl@0: switch -glob aaaab { sl@0: ^a*b$ {concat regexp} sl@0: *b {concat glob} sl@0: aaaab {concat exact} sl@0: default {concat none} sl@0: } sl@0: } glob sl@0: test switch-3.4 {-exact vs. -glob vs. -regexp} { sl@0: switch aaaab {^a*b$} {concat regexp} *b {concat glob} \ sl@0: aaaab {concat exact} default {concat none} sl@0: } exact sl@0: test switch-3.5 {-exact vs. -glob vs. -regexp} { sl@0: switch -- -glob { sl@0: ^g.*b$ {concat regexp} sl@0: -* {concat glob} sl@0: -glob {concat exact} sl@0: default {concat none} sl@0: } sl@0: } exact sl@0: test switch-3.6 {-exact vs. -glob vs. -regexp} { sl@0: list [catch {switch -foo a b c} msg] $msg sl@0: } {1 {bad option "-foo": must be -exact, -glob, -regexp, or --}} sl@0: sl@0: test switch-4.1 {error in executed command} { sl@0: list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ sl@0: $msg $errorInfo sl@0: } {1 {Just a test} {Just a test sl@0: while executing sl@0: "error "Just a test"" sl@0: ("a" arm line 1) sl@0: invoked from within sl@0: "switch a a {error "Just a test"} default {format 1}"}} sl@0: test switch-4.2 {error: not enough args} { sl@0: list [catch {switch} msg] $msg sl@0: } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} sl@0: test switch-4.3 {error: pattern with no body} { sl@0: list [catch {switch a b} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: test switch-4.4 {error: pattern with no body} { sl@0: list [catch {switch a b {format 1} c} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: test switch-4.5 {error in default command} { sl@0: list [catch {switch foo a {error switch1} b {error switch 3} \ sl@0: default {error switch2}} msg] $msg $errorInfo sl@0: } {1 switch2 {switch2 sl@0: while executing sl@0: "error switch2" sl@0: ("default" arm line 1) sl@0: invoked from within sl@0: "switch foo a {error switch1} b {error switch 3} default {error switch2}"}} sl@0: sl@0: test switch-5.1 {errors in -regexp matching} { sl@0: list [catch {switch -regexp aaaab { sl@0: *b {concat glob} sl@0: aaaab {concat exact} sl@0: default {concat none} sl@0: }} msg] $msg sl@0: } {1 {couldn't compile regular expression pattern: quantifier operand invalid}} sl@0: sl@0: test switch-6.1 {backslashes in patterns} { sl@0: switch -exact {\a\$\.\[} { sl@0: \a\$\.\[ {concat first} sl@0: \a\\$\.\\[ {concat second} sl@0: \\a\\$\\.\\[ {concat third} sl@0: {\a\\$\.\\[} {concat fourth} sl@0: {\\a\\$\\.\\[} {concat fifth} sl@0: default {concat none} sl@0: } sl@0: } third sl@0: test switch-6.2 {backslashes in patterns} { sl@0: switch -exact {\a\$\.\[} { sl@0: \a\$\.\[ {concat first} sl@0: {\a\$\.\[} {concat second} sl@0: {{\a\$\.\[}} {concat third} sl@0: default {concat none} sl@0: } sl@0: } second sl@0: sl@0: test switch-7.1 {"-" bodies} { sl@0: switch a { sl@0: a - sl@0: b - sl@0: c {concat 1} sl@0: default {concat 2} sl@0: } sl@0: } 1 sl@0: test switch-7.2 {"-" bodies} { sl@0: list [catch { sl@0: switch a { sl@0: a - sl@0: b - sl@0: c - sl@0: } sl@0: } msg] $msg sl@0: } {1 {no body specified for pattern "c"}} sl@0: test switch-7.3 {"-" bodies} { sl@0: list [catch { sl@0: switch a { sl@0: a - sl@0: b -foo sl@0: c - sl@0: } sl@0: } msg] $msg sl@0: } {1 {no body specified for pattern "c"}} sl@0: sl@0: test switch-8.1 {empty body} { sl@0: set msg {} sl@0: switch {2} { sl@0: 1 {set msg 1} sl@0: 2 {} sl@0: default {set msg 2} sl@0: } sl@0: } {} sl@0: sl@0: test switch-9.1 {empty pattern/body list} { sl@0: list [catch {switch x} msg] $msg sl@0: } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} sl@0: test switch-9.2 {empty pattern/body list} { sl@0: list [catch {switch -- x} msg] $msg sl@0: } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} sl@0: test switch-9.3 {empty pattern/body list} { sl@0: list [catch {switch x {}} msg] $msg sl@0: } {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}} sl@0: test switch-9.4 {empty pattern/body list} { sl@0: list [catch {switch -- x {}} msg] $msg sl@0: } {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}} sl@0: test switch-9.5 {unpaired pattern} { sl@0: list [catch {switch x a {} b} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: test switch-9.6 {unpaired pattern} { sl@0: list [catch {switch x {a {} b}} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: test switch-9.7 {unpaired pattern} { sl@0: list [catch {switch x a {} # comment b} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: test switch-9.8 {unpaired pattern} { sl@0: list [catch {switch x {a {} # comment b}} msg] $msg sl@0: } {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}} sl@0: test switch-9.9 {unpaired pattern} { sl@0: list [catch {switch x a {} x {} # comment b} msg] $msg sl@0: } {1 {extra switch pattern with no body}} sl@0: test switch-9.10 {unpaired pattern} { sl@0: list [catch {switch x {a {} x {} # comment b}} msg] $msg sl@0: } {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}} sl@0: sl@0: # cleanup sl@0: ::tcltest::cleanupTests sl@0: return