diff options
Diffstat (limited to 'tests')
-rw-r--r-- | tests/proc-new.test | 79 | ||||
-rw-r--r-- | tests/proc.test | 11 | ||||
-rw-r--r-- | tests/testing.tcl | 13 |
3 files changed, 96 insertions, 7 deletions
diff --git a/tests/proc-new.test b/tests/proc-new.test new file mode 100644 index 0000000..324a976 --- /dev/null +++ b/tests/proc-new.test @@ -0,0 +1,79 @@ +source testing.tcl + +proc aproc {} { + list +} +proc bproc {b} { + list b $b +} +proc cproc {b c} { + list b $b c $c +} +proc dproc {b c {d dd}} { + list b $b c $c d $d +} +proc eproc {b c {d dd} e} { + list b $b c $c d $d e $e +} +proc fproc {b c {d dd} args} { + list b $b c $c d $d args $args +} +proc gproc {b c {d dd} args e} { + list b $b c $c d $d args $args e $e +} +proc hproc {{a aa} args} { + list a $a args $args +} + +section "Proc - TIP #288" + +set n 1 +foreach {proc params result} { + aproc {} {} + bproc B {b B} + cproc {B C} {b B c C} + dproc {B C} {b B c C d dd} + dproc {B C D} {b B c C d D} + eproc {B C D E} {b B c C d D e E} + eproc {B C E} {b B c C d dd e E} + fproc {B C} {b B c C d dd args {}} + fproc {B C D} {b B c C d D args {}} + fproc {B C D E} {b B c C d D args E} + fproc {B C D E F} {b B c C d D args {E F}} + gproc {B C E} {b B c C d dd args {} e E} + gproc {B C D E} {b B c C d D args {} e E} + gproc {B C D X E} {b B c C d D args X e E} + gproc {B C D X Y Z E} {b B c C d D args {X Y Z} e E} + hproc {} {a aa args {}} + hproc {A} {a A args {}} + hproc {A X Y Z} {a A args {X Y Z}} +} { + test proc-1.$n "Proc args combos" [list $proc {*}$params] $result + incr n +} + +proc onearg_search {{nocase ""} value list} { + lsearch {*}$nocase $list $value +} + +proc multiarg_search {args value list} { + lsearch {*}$args $list $value +} + +test proc-2.1 "Real test of optional switches" { + onearg_search c {A a B b C c D d} +} 5 + +test proc-2.2 "Real test of optional switches" { + onearg_search -nocase c {A a B b C c D d} +} 4 + +test proc-2.3 "Real test of optional switches" { + multiarg_search -glob c* {A a B b C c D d} +} 5 + +test proc-2.4 "Real test of optional switches" { + multiarg_search -nocase -glob c* {A a B b C c D d} +} 4 + +testreport diff --git a/tests/proc.test b/tests/proc.test index 2e65c35..56ed59a 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -174,14 +174,15 @@ test proc-old-3.7 {arguments and defaults} { } list [catch {tproc} msg] } {1} +# Note: This requires new TIP #288 support test proc-old-3.8 {arguments and defaults} { list [catch { proc tproc {x {y y-default} z} { return [list $x $y $z] } tproc 2 3 - } msg] -} {1} + } msg] $msg +} {0 {2 y-default 3}} test proc-old-3.9 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] @@ -246,13 +247,13 @@ test proc-old-5.3 {error conditions} { test proc-old-5.5 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} +} {1 {procedure has argument with no name}} test proc-old-5.6 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} +} {1 {procedure has argument with no name}} test proc-old-5.7 {error conditions} { list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg -} {1 {too many fields in argument specifier "x 1 2"}} +} {1 {procedure has argument with too many fields}} test proc-old-5.8 {error conditions} { catch {return} } 2 diff --git a/tests/testing.tcl b/tests/testing.tcl index 221d6be..a675c5e 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -38,13 +38,20 @@ set testresults(numpass) 0 set testresults(failed) {} proc test {id descr script expected} { - puts -nonewline "$id " + if {!$::testquiet} { + puts -nonewline "$id " + } set rc [catch {uplevel 1 $script} result] # Note that rc=2 is return if {($rc == 0 || $rc == 2) && $result eq $expected} { - puts "OK $descr" + if {!$::testquiet} { + puts "OK $descr" + } incr ::testresults(numpass) } else { + if {$::testquiet} { + puts -nonewline "$id " + } puts "ERR $descr" puts "Expected: '$expected'" puts "Got : '$result'" @@ -71,3 +78,5 @@ proc testerror {} { puts [string repeat = 40] puts $argv0 puts [string repeat = 40] + +set ::testquiet [info exists ::env(testquiet)] |