tcl/tests/switch.test

   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$
  15
  16 if {[lsearch [namespace children] ::tcltest] == -1} {
  17     package require tcltest
  18     namespace import -force ::tcltest::*
  19 }
  20
  21 test switch-1.1 {simple patterns} {
  22     switch a a {format 1} b {format 2} c {format 3} default {format 4}
  23 } 1
  24 test switch-1.2 {simple patterns} {
  25     switch b a {format 1} b {format 2} c {format 3} default {format 4}
  26 } 2
  27 test switch-1.3 {simple patterns} {
  28     switch x a {format 1} b {format 2} c {format 3} default {format 4}
  29 } 4
  30 test switch-1.4 {simple patterns} {
  31     switch x a {format 1} b {format 2} c {format 3}
  32 } {}
  33 test switch-1.5 {simple pattern matches many times} {
  34     switch b a {format 1} b {format 2} b {format 3} b {format 4}
  35 } 2
  36 test switch-1.6 {simple patterns} {
  37     switch default a {format 1} default {format 2} c {format 3} default {format 4}
  38 } 2
  39 test switch-1.7 {simple patterns} {
  40     switch x a {format 1} default {format 2} c {format 3} default {format 4}
  41 } 4
  42
  43 test switch-2.1 {single-argument form for pattern/command pairs} {
  44     switch b {
  45         a {format 1}
  46         b {format 2}
  47         default {format 6}
  48     }
  49 } {2}
  50 test switch-2.2 {single-argument form for pattern/command pairs} {
  51     list [catch {switch z {a 2 b}} msg] $msg
  52 } {1 {extra switch pattern with no body}}
  53
  54 test switch-3.1 {-exact vs. -glob vs. -regexp} {
  55     switch -exact aaaab {
  56         ^a*b$   {concat regexp}
  57         *b      {concat glob}
  58         aaaab   {concat exact}
  59         default {concat none}
  60     }
  61 } exact
  62 test switch-3.2 {-exact vs. -glob vs. -regexp} {
  63     switch -regexp aaaab {
  64         ^a*b$   {concat regexp}
  65         *b      {concat glob}
  66         aaaab   {concat exact}
  67         default {concat none}
  68     }
  69 } regexp
  70 test switch-3.3 {-exact vs. -glob vs. -regexp} {
  71     switch -glob aaaab {
  72         ^a*b$   {concat regexp}
  73         *b      {concat glob}
  74         aaaab   {concat exact}
  75         default {concat none}
  76     }
  77 } glob
  78 test switch-3.4 {-exact vs. -glob vs. -regexp} {
  79     switch aaaab {^a*b$} {concat regexp} *b {concat glob} \
  80             aaaab {concat exact} default {concat none}
  81 } exact
  82 test switch-3.5 {-exact vs. -glob vs. -regexp} {
  83     switch -- -glob {
  84         ^g.*b$  {concat regexp}
  85         -*      {concat glob}
  86         -glob   {concat exact}
  87         default {concat none}
  88     }
  89 } exact
  90 test switch-3.6 {-exact vs. -glob vs. -regexp} {
  91     list [catch {switch -foo a b c} msg] $msg
  92 } {1 {bad option "-foo": must be -exact, -glob, -regexp, or --}}
  93
  94 test switch-4.1 {error in executed command} {
  95     list [catch {switch a a {error "Just a test"} default {format 1}} msg] \
  96             $msg $errorInfo
  97 } {1 {Just a test} {Just a test
  98     while executing
  99 "error "Just a test""
 100     ("a" arm line 1)
 101     invoked from within
 102 "switch a a {error "Just a test"} default {format 1}"}}
 103 test switch-4.2 {error: not enough args} {
 104     list [catch {switch} msg] $msg
 105 } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
 106 test switch-4.3 {error: pattern with no body} {
 107     list [catch {switch a b} msg] $msg
 108 } {1 {extra switch pattern with no body}}
 109 test switch-4.4 {error: pattern with no body} {
 110     list [catch {switch a b {format 1} c} msg] $msg
 111 } {1 {extra switch pattern with no body}}
 112 test switch-4.5 {error in default command} {
 113     list [catch {switch foo a {error switch1} b {error switch 3} \
 114             default {error switch2}} msg] $msg $errorInfo
 115 } {1 switch2 {switch2
 116     while executing
 117 "error switch2"
 118     ("default" arm line 1)
 119     invoked from within
 120 "switch foo a {error switch1} b {error switch 3}  default {error switch2}"}}
 121
 122 test switch-5.1 {errors in -regexp matching} {
 123     list [catch {switch -regexp aaaab {
 124         *b      {concat glob}
 125         aaaab   {concat exact}
 126         default {concat none}
 127     }} msg] $msg
 128 } {1 {couldn't compile regular expression pattern: quantifier operand invalid}}
 129
 130 test switch-6.1 {backslashes in patterns} {
 131     switch -exact {\a\$\.\[} {
 132         \a\$\.\[        {concat first}
 133         \a\\$\.\\[      {concat second}
 134         \\a\\$\\.\\[    {concat third}
 135         {\a\\$\.\\[}    {concat fourth}
 136         {\\a\\$\\.\\[}  {concat fifth}
 137         default         {concat none}
 138     }
 139 } third
 140 test switch-6.2 {backslashes in patterns} {
 141     switch -exact {\a\$\.\[} {
 142         \a\$\.\[        {concat first}
 143         {\a\$\.\[}      {concat second}
 144         {{\a\$\.\[}}    {concat third}
 145         default         {concat none}
 146     }
 147 } second
 148
 149 test switch-7.1 {"-" bodies} {
 150     switch a {
 151         a -
 152         b -
 153         c {concat 1}
 154         default {concat 2}
 155     }
 156 } 1
 157 test switch-7.2 {"-" bodies} {
 158     list [catch {
 159         switch a {
 160             a -
 161             b -
 162             c -
 163         }
 164     } msg] $msg
 165 } {1 {no body specified for pattern "c"}}
 166 test switch-7.3 {"-" bodies} {
 167     list [catch {
 168         switch a {
 169             a -
 170             b -foo
 171             c -
 172         }
 173     } msg] $msg
 174 } {1 {no body specified for pattern "c"}}
 175
 176 test switch-8.1 {empty body} {
 177     set msg {}
 178     switch {2} {
 179         1 {set msg 1}
 180         2 {}
 181         default {set msg 2}
 182     }
 183 } {}
 184
 185 test switch-9.1 {empty pattern/body list} {
 186     list [catch {switch x} msg] $msg
 187 } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
 188 test switch-9.2 {empty pattern/body list} {
 189     list [catch {switch -- x} msg] $msg
 190 } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
 191 test switch-9.3 {empty pattern/body list} {
 192     list [catch {switch x {}} msg] $msg
 193 } {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}}
 194 test switch-9.4 {empty pattern/body list} {
 195     list [catch {switch -- x {}} msg] $msg
 196 } {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}}
 197 test switch-9.5 {unpaired pattern} {
 198     list [catch {switch x a {} b} msg] $msg
 199 } {1 {extra switch pattern with no body}}
 200 test switch-9.6 {unpaired pattern} {
 201     list [catch {switch x {a {} b}} msg] $msg
 202 } {1 {extra switch pattern with no body}}
 203 test switch-9.7 {unpaired pattern} {
 204     list [catch {switch x a {} # comment b} msg] $msg
 205 } {1 {extra switch pattern with no body}}
 206 test switch-9.8 {unpaired pattern} {
 207     list [catch {switch x {a {} # comment b}} msg] $msg
 208 } {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}}
 209 test switch-9.9 {unpaired pattern} {
 210     list [catch {switch x a {} x {} # comment b} msg] $msg
 211 } {1 {extra switch pattern with no body}}
 212 test switch-9.10 {unpaired pattern} {
 213     list [catch {switch x {a {} x {} # comment b}} msg] $msg
 214 } {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}}
 215
 216 # cleanup
 217 ::tcltest::cleanupTests
 218 return