diff options
author | Steve Bennett <steveb@workware.net.au> | 2011-04-21 11:57:29 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2011-04-21 11:57:29 +1000 |
commit | b9e7448cc5560d4f945d648f099be3219dfb2d81 (patch) | |
tree | 879e2f49879bb1d5d0ebf499469ec87c32a889a8 /tests/testing.tcl | |
parent | 1d7380ccd226e9dc9e55b85635ba7da25848cca3 (diff) | |
download | jimtcl-b9e7448cc5560d4f945d648f099be3219dfb2d81.zip jimtcl-b9e7448cc5560d4f945d648f099be3219dfb2d81.tar.gz jimtcl-b9e7448cc5560d4f945d648f099be3219dfb2d81.tar.bz2 |
Add some tcltest v2 support
Makes it easier to import Tcl tests
Signed-off-by: Steve Bennett <steveb@workware.net.au>
Diffstat (limited to 'tests/testing.tcl')
-rw-r--r-- | tests/testing.tcl | 50 |
1 files changed, 44 insertions, 6 deletions
diff --git a/tests/testing.tcl b/tests/testing.tcl index d5eedd3..83f74cb 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -109,13 +109,28 @@ proc bytestring {x} { return $x } -proc test {id descr {constraints {}} script expected} { +# Note: We don't support -output or -errorOutput yet +proc test {id descr args} { + if {[lindex $args 0] ni {-returnCodes -body -match -constraints -result -output -errorOutput}} { + if {[llength $args] == 2} { + lassign $args body result constraints + } elseif {[llength $args] == 3} { + lassign $args constraints body result + } else { + return -code error "$id: Wrong syntax for tcltest::test v1" + } + tailcall test $id $descr -body $body -result $result -constraints $constraints + } + # tcltest::test v2 syntax + set a {-returnCodes {ok return} -match exact -result {} -constraints {} -body {} -setup {} -cleanup {}} + array set a $args + incr ::testinfo(numtests) if {$::testinfo(verbose)} { puts -nonewline "$id " } - foreach c $constraints { + foreach c $a(-constraints) { if {[info exists ::tcltest::testConstraints($c)]} { if {$::tcltest::testConstraints($c)} { continue @@ -127,10 +142,29 @@ proc test {id descr {constraints {}} script expected} { return } } - set rc [catch {uplevel 1 $script} result] - # Note that rc=2 is return - if {($rc == 0 || $rc == 2) && $result eq $expected} { + catch {uplevel 1 $a(-setup)} + set rc [catch {uplevel 1 $a(-body)} result] + catch {uplevel 1 $a(-cleanup)} + + if {[info return $rc] ni $a(-returnCodes)} { + set ok 0 + set expected "rc=$a(-returnCodes) result=$a(-result)" + set result "rc=[info return $rc] result=$result" + } else { + if {$a(-match) eq "exact"} { + set ok [string equal $a(-result) $result] + } elseif {$a(-match) eq "glob"} { + set ok [string match $a(-result) $result] + } elseif {$a(-match) eq "regexp"} { + set ok [regexp $a(-result) $result] + } else { + return -code error "$id: unknown match type: $a(-match)" + } + set expected $a(-result) + } + + if {$ok} { if {$::testinfo(verbose)} { puts "OK $descr" } @@ -143,7 +177,7 @@ proc test {id descr {constraints {}} script expected} { } puts "ERR $descr" if {$rc == 0} { - set source [script_source $script] + set source [script_source $a(-body)] } else { set source [error_source] } @@ -153,6 +187,10 @@ proc test {id descr {constraints {}} script expected} { lappend ::testinfo(failed) [list $id $descr $source $expected $result] } +proc ::tcltest::cleanupTests {} { + tailcall testreport +} + proc testreport {} { if {$::testinfo(verbose)} { puts -nonewline "\n$::argv0" |