path: root/tests/switch.test

# Commands covered:  switch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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.16.4.2 2008/01/23 16:42:21 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

test switch-1.1 {simple patterns} {
    switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 1
test switch-1.2 {simple patterns} {
    switch b a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 2
test switch-1.3 {simple patterns} {
    switch x a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 4
test switch-1.4 {simple patterns} {
    switch x a {subst 1} b {subst 2} c {subst 3}
} {}
test switch-1.5 {simple pattern matches many times} {
    switch b a {subst 1} b {subst 2} b {subst 3} b {subst 4}
} 2
test switch-1.6 {simple patterns} {
    switch default a {subst 1} default {subst 2} c {subst 3} default {subst 4}
} 2
test switch-1.7 {simple patterns} {
    switch x a {subst 1} default {subst 2} c {subst 3} default {subst 4}
} 4
test switch-1.8 {simple patterns with -nocase} {
    switch -nocase b a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 2
test switch-1.9 {simple patterns with -nocase} {
    switch -nocase B a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 2
test switch-1.10 {simple patterns with -nocase} {
    switch -nocase b a {subst 1} B {subst 2} c {subst 3} default {subst 4}
} 2
test switch-1.11 {simple patterns with -nocase} {
    switch -nocase x a {subst 1} default {subst 2} c {subst 3} default {subst 4}
} 4

test switch-2.1 {single-argument form for pattern/command pairs} {
    switch b {
	a {subst 1}
	b {subst 2}
	default {subst 6}
    }
} {2}
test switch-2.2 {single-argument form for pattern/command pairs} -body {
    switch z {a 2 b}
} -returnCodes error -result {extra switch pattern with no body}

test switch-3.1 {-exact vs. -glob vs. -regexp} {
    switch -exact aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} exact
test switch-3.2 {-exact vs. -glob vs. -regexp} {
    switch -regexp aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} regexp
test switch-3.3 {-exact vs. -glob vs. -regexp} {
    switch -glob aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} glob
test switch-3.4 {-exact vs. -glob vs. -regexp} {
    switch aaaab {^a*b$} {subst regexp} *b {subst glob} \
	    aaaab {subst exact} default {subst none}
} exact
test switch-3.5 {-exact vs. -glob vs. -regexp} {
    switch -- -glob {
	^g.*b$	{subst regexp}
	-*	{subst glob}
	-glob	{subst exact}
	default {subst none}
    }
} exact
test switch-3.6 {-exact vs. -glob vs. -regexp} -body {
    switch -foo a b c
} -returnCodes error -result {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}
test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -exact -nocase aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} exact
test switch-3.8 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -regexp -nocase aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} regexp
test switch-3.9 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -glob -nocase aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} glob
test switch-3.10 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -nocase aaaab {^a*b$} {subst regexp} *b {subst glob} \
	    aaaab {subst exact} default {subst none}
} exact
test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -nocase -- -glob {
	^g.*b$	{subst regexp}
	-*	{subst glob}
	-glob	{subst exact}
	default {subst none}
    }
} exact
test switch-3.12 {-exact vs. -glob vs. -regexp} {
    switch -exa Foo Foo {set result OK}
} OK
test switch-3.13 {-exact vs. -glob vs. -regexp} {
    switch -gl Foo Fo? {set result OK}
} OK
test switch-3.14 {-exact vs. -glob vs. -regexp} {
    switch -re Foo Fo. {set result OK}
} OK
test switch-3.15 {-exact vs. -glob vs. -regexp} -body {
    switch -exact -exact Foo Foo {set result OK}
} -returnCodes error -result {bad option "-exact": -exact option already found}
test switch-3.16 {-exact vs. -glob vs. -regexp} -body {
    switch -exact -glob Foo Foo {set result OK}
} -returnCodes error -result {bad option "-glob": -exact option already found}
test switch-3.17 {-exact vs. -glob vs. -regexp} -body {
    switch -glob -regexp Foo Foo {set result OK}
} -returnCodes error -result {bad option "-regexp": -glob option already found}
test switch-3.18 {-exact vs. -glob vs. -regexp} -body {
    switch -regexp -glob Foo Foo {set result OK}
} -returnCodes error -result {bad option "-glob": -regexp option already found}

test switch-4.1 {error in executed command} {
    list [catch {switch a a {error "Just a test"} default {subst 1}} msg] \
	    $msg $::errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"switch a a {error "Just a test"} default {subst 1}"}}
test switch-4.2 {error: not enough args} -returnCodes error -body {
    switch
} -result {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}
test switch-4.3 {error: pattern with no body} -body {
    switch a b
} -returnCodes error -result {extra switch pattern with no body}
test switch-4.4 {error: pattern with no body} -body {
    switch a b {subst 1} c
} -returnCodes error -result {extra switch pattern with no body}
test switch-4.5 {error in default command} {
    list [catch {switch foo a {error switch1} b {error switch 3} \
	    default {error switch2}} msg] $msg $::errorInfo
} {1 switch2 {switch2
    while executing
"error switch2"
    ("default" arm line 1)
    invoked from within
"switch foo a {error switch1} b {error switch 3}  default {error switch2}"}}

test switch-5.1 {errors in -regexp matching} -returnCodes error -body {
    switch -regexp aaaab {
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }
} -result {couldn't compile regular expression pattern: quantifier operand invalid}

test switch-6.1 {backslashes in patterns} {
    switch -exact {\a\$\.\[} {
	\a\$\.\[	{subst first}
	\a\\$\.\\[	{subst second}
	\\a\\$\\.\\[	{subst third}
	{\a\\$\.\\[}	{subst fourth}
	{\\a\\$\\.\\[}	{subst fifth}
	default		{subst none}
    }
} third
test switch-6.2 {backslashes in patterns} {
    switch -exact {\a\$\.\[} {
	\a\$\.\[	{subst first}
	{\a\$\.\[}	{subst second}
	{{\a\$\.\[}}	{subst third}
	default		{subst none}
    }
} second

test switch-7.1 {"-" bodies} {
    switch a {
	a -
	b -
	c {subst 1}
	default {subst 2}
    }
} 1
test switch-7.2 {"-" bodies} -body {
    switch a {
	a -
	b -
	c -
    }
} -returnCodes error -result {no body specified for pattern "c"}
test switch-7.3 {"-" bodies} -body {
    switch a {
	a -
	b -foo
	c -
    }
} -returnCodes error -result {no body specified for pattern "c"}
test switch-7.4 {"-" bodies} -body {
    switch a {
	a -
	b -foo
	c {}
    }
} -returnCodes error -result {invalid command name "-foo"}

test switch-8.1 {empty body} {
    set msg {}
    switch {2} {
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}
proc test_switch_body {} {
    return "INVOKED"
}
test switch-8.2 {weird body text, variable} {
    set cmd {test_switch_body}
    switch Foo {
    	Foo $cmd
    }
} {INVOKED}
test switch-8.3 {weird body text, variable} {
    set cmd {test_switch_body}
    switch Foo {
    	Foo {$cmd}
    }
} {INVOKED}

test switch-9.1 {empty pattern/body list} -returnCodes error -body {
    switch x
} -result {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}
test switch-9.2 {unpaired pattern} -returnCodes error -body {
    switch -- x
} -result {extra switch pattern with no body}
test switch-9.3 {empty pattern/body list} -body {
    switch x {}
} -returnCodes error -result {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}
test switch-9.4 {empty pattern/body list} -body {
    switch -- x {}
} -returnCodes error -result {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}
test switch-9.5 {unpaired pattern} -body {
    switch x a {} b
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.6 {unpaired pattern} -body {
    switch x {a {} b}
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.7 {unpaired pattern} -body {
    switch x a {} # comment b
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.8 {unpaired pattern} -returnCodes error -body {
    switch x {a {} # comment b}
} -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}
test switch-9.9 {unpaired pattern} -body {
    switch x a {} x {} # comment b
} -returnCodes error -result {extra switch pattern with no body}
test switch-9.10 {unpaired pattern} -returnCodes error -body {
    switch x {a {} x {} # comment b}
} -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}

test switch-10.1 {compiled -exact switch} {
    if 1 {switch -exact -- a {a {subst 1} b {subst 2}}}
} 1
test switch-10.1a {compiled -exact switch} {
    if 1 {switch -exact a {a {subst 1} b {subst 2}}}
} 1
test switch-10.2 {compiled -exact switch} {
    if 1 {switch -exact -- b {a {subst 1} b {subst 2}}}
} 2
test switch-10.2a {compiled -exact switch} {
    if 1 {switch -exact b {a {subst 1} b {subst 2}}}
} 2
test switch-10.3 {compiled -exact switch} {
    if 1 {switch -exact -- c {a {subst 1} b {subst 2}}}
} {}
test switch-10.3a {compiled -exact switch} {
    if 1 {switch -exact c {a {subst 1} b {subst 2}}}
} {}
test switch-10.4 {compiled -exact switch} {
    if 1 {
	set x 0
	switch -exact -- c {a {subst 1} b {subst 2}}
    }
} {}
test switch-10.5 {compiled -exact switch} {
    if 1 {switch -exact -- a {a - aa {subst 1} b {subst 2}}}
} 1
test switch-10.6 {compiled -exact switch} {
    if 1 {switch -exact -- b {a {
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
    } b {subst 2}}}
} 2

# Command variants are:
#    c* are compiled switches, i* are interpreted
#    *-glob use glob matching, *-exact use exact matching
#    *2* include a default clause (different results too.)
proc cswtest-glob s {
    set x 0; set y 0
    foreach c [split $s {}] {
	switch -glob $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	switch -glob -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc iswtest-glob s {
    set x 0; set y 0; set switch switch
    foreach c [split $s {}] {
	$switch -glob $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	$switch -glob -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc cswtest-exact s {
    set x 0; set y 0
    foreach c [split $s {}] {
	switch -exact $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	switch -exact -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc iswtest-exact s {
    set x 0; set y 0; set switch switch
    foreach c [split $s {}] {
	$switch -exact $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	$switch -exact -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc cswtest2-glob s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -glob $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	switch -glob -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc iswtest2-glob s {
    set x 0; set y 0; set z 0; set switch switch
    foreach c [split $s {}] {
	$switch -glob $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	$switch -glob -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc cswtest2-exact s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -exact $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	switch -exact -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc iswtest2-exact s {
    set x 0; set y 0; set z 0; set switch switch
    foreach c [split $s {}] {
	$switch -exact $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	$switch -exact -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}

test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} {
    cswtest-exact abcb
} [iswtest-exact abcb]
test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} {
    cswtest-glob abcb
} [iswtest-glob abcb]
test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} {
    cswtest2-exact abcb
} [iswtest2-exact abcb]
test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} {
    cswtest2-glob abcb
} [iswtest2-glob abcb]
proc cswtest-default-exact {x} {
    switch -- $x {
	a* {return b}
	aa {return c}
	default {return d}
    }
}
test switch-10.11 {default to exact matching when compiled} {
    cswtest-default-exact a
} d
test switch-10.12 {default to exact matching when compiled} {
    cswtest-default-exact aa
} c
test switch-10.13 {default to exact matching when compiled} {
    cswtest-default-exact a*
} b
test switch-10.14 {default to exact matching when compiled} {
    cswtest-default-exact a**
} d
rename cswtest-default-exact {}
rename cswtest-glob {}
rename iswtest-glob {}
rename cswtest2-glob {}
rename iswtest2-glob {}
rename cswtest-exact {}
rename iswtest-exact {}
rename cswtest2-exact {}
rename iswtest2-exact {}

# Added due to TIP#75
test switch-11.1 {regexp matching with -matchvar} {
    switch -regexp -matchvar x -- abc {.(.). {set x}}
} {abc b}
test switch-11.2 {regexp matching with -matchvar} {
    set x GOOD
    switch -regexp -matchvar x -- abc {.(.).. {list $x z}}
    set x
} GOOD
test switch-11.3 {regexp matching with -matchvar} {
    switch -regexp -matchvar x -- "a b c" {.(.). {set x}}
} {{a b} { }}
test switch-11.4 {regexp matching with -matchvar} {
    set x BAD
    switch -regexp -matchvar x -- "a b c" {
	bc {list $x YES}
	default {list $x NO}
    }
} {{} NO}
test switch-11.5 {-matchvar without -regexp} {
    set x {}
    list [catch {switch -glob -matchvar x -- abc . {set x}} msg] $x $msg
} {1 {} {-matchvar option requires -regexp option}}
test switch-11.6 {-matchvar unwritable} {
    set x {}
    list [catch {switch -regexp -matchvar x(x) -- abc . {set x}} msg] $x $msg
} {1 {} {can't set "x(x)": variable isn't array}}

test switch-12.1 {regexp matching with -indexvar} {
    switch -regexp -indexvar x -- abc {.(.). {set x}}
} {{0 3} {1 2}}
test switch-12.2 {regexp matching with -indexvar} {
    set x GOOD
    switch -regexp -indexvar x -- abc {.(.).. {list $x z}}
    set x
} GOOD
test switch-12.3 {regexp matching with -indexvar} {
    switch -regexp -indexvar x -- "a b c" {.(.). {set x}}
} {{0 3} {1 2}}
test switch-12.4 {regexp matching with -indexvar} {
    set x BAD
    switch -regexp -indexvar x -- "a b c" {
	bc {list $x YES}
	default {list $x NO}
    }
} {{} NO}
test switch-12.5 {-indexvar without -regexp} {
    set x {}
    list [catch {switch -glob -indexvar x -- abc . {set x}} msg] $x $msg
} {1 {} {-indexvar option requires -regexp option}}
test switch-12.6 {-indexvar unwritable} {
    set x {}
    list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg
} {1 {} {can't set "x(x)": variable isn't array}}

test switch-13.1 {-indexvar -matchvar combinations} {
    switch -regexp -indexvar x -matchvar y abc {
	. {list $x $y}
    }
} {{{0 1}} a}
test switch-13.2 {-indexvar -matchvar combinations} {
    switch -regexp -indexvar x -matchvar y abc {
	.$ {list $x $y}
    }
} {{{2 3}} c}
test switch-13.3 {-indexvar -matchvar combinations} {
    switch -regexp -indexvar x -matchvar y abc {
	(.)(.)(.) {list $x $y}
    }
} {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}}
test switch-13.4 {-indexvar -matchvar combinations} {
    set x -
    set y -
    switch -regexp -indexvar x -matchvar y abc {
	(.)(.)(.). -
	default {list $x $y}
    }
} {{} {}}
test switch-13.5 {-indexvar -matchvar combinations} {
    set x -
    set y -
    list [catch {
	switch -regexp -indexvar x(x) -matchvar y abc {. {list $x $y}}
    } msg] $x $y $msg
} {1 - - {can't set "x(x)": variable isn't array}}
test switch-13.6 {-indexvar -matchvar combinations} {
    set x -
    set y -
    list [catch {
	switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}}
    } msg] $x $y $msg
} {1 {{0 1}} - {can't set "y(y)": variable isn't array}}

test switch-14.1 {-regexp -- compilation [Bug 1854399]} {
    switch -regexp -- 0 {
	{[0-9]+} {return yes}
	default  {return no}
    }
    foo
} yes
test switch-14.2 {-regexp -- compilation [Bug 1854399]} {
    proc foo {} {
	switch -regexp -- 0 {
	    {[0-9]+} {return yes}
	    default  {return no}
	}
    }
    foo
} yes
test switch-14.3 {-regexp -- compilation [Bug 1854399]} {
    proc foo {} {
	switch -regexp -- 0 {
	    {\d+} {return yes}
	    default  {return no}
	}
    }
    foo
} yes
test switch-14.4 {-regexp -- compilation [Bug 1854399]} {
    proc foo {} {
	switch -regexp -- 0 {
	    {0} {return yes}
	    default  {return no}
	}
    }
    foo
} yes

# cleanup
::tcltest::cleanupTests
return