From 192056900583884bc1f07f371df6478d856ada3b Mon Sep 17 00:00:00 2001 From: Steve Bennett Date: Sat, 30 Oct 2010 15:21:21 +1000 Subject: Overhaul unit test framework Much closer to tcltest now, including constraints. Try to get all appropriate tests running under both Jim and Tcl. Signed-off-by: Steve Bennett --- tests/testing.tcl | 182 +++++++++++++++++++++++++++++++++--------------------- 1 file changed, 113 insertions(+), 69 deletions(-) (limited to 'tests/testing.tcl') diff --git a/tests/testing.tcl b/tests/testing.tcl index 33e3a7e..4bb19a5 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -1,3 +1,65 @@ +# Common code +array set testinfo {verbose 0 numpass 0 numfail 0 numskip 0 numtests 0 failed {}} + +set testdir [file dirname [info script]] + +if {[lsearch $argv "-verbose"] >= 0 || [info exists env(testverbose)]} { + incr testinfo(verbose) +} + +proc needs {type what {packages {}}} { + if {$type eq "constraint"} { + if {![info exists ::tcltest::testConstraints($what)]} { + set ::tcltest::testConstraints($what) 0 + } + if {![set ::tcltest::testConstraints($what)]} { + skiptest " (constraint $what)" + } + return + } + if {$type eq "cmd"} { + # Does it exist already? + if {[info commands $what] ne ""} { + return + } + if {$packages eq ""} { + # e.g. exec command is in exec package + set packages $what + } + foreach p $packages { + catch {package require $p} + } + if {[info commands $what] ne ""} { + return + } + skiptest " (command $what)" + } + error "Unknown needs type: $type" +} + +proc skiptest {{msg {}}} { + puts [format "%16s: --- skipped$msg" $::argv0] + exit 0 +} + +# If tcl, just use tcltest +if {[catch {info version}]} { + package require Tcl 8.5 + package require tcltest 2.1 + namespace import tcltest::* + + if {$testinfo(verbose)} { + configure -verbose bps + } + testConstraint utf8 1 + testConstraint tcl 1 + proc testreport {} { + ::tcltest::cleanupTests + } + return +} + +# For Jim, this is reasonable compatible tcltest proc makeFile {contents name} { set f [open $name w] puts $f $contents @@ -24,93 +86,82 @@ proc package-or-skip {name} { if {[catch { package require $name }]} { - puts " --- skipped" + puts [format "%16s: --- skipped" $::argv0] exit 0 } } -set test(utf8) 0 -if {[string length "\xc2\xb5"] == 1} { - set test(utf8) 1 -} -proc bytestring {x} { - return $x +proc testConstraint {constraint bool} { + set ::tcltest::testConstraints($constraint) $bool } -catch { - # Tcl-only things - info tclversion - proc errorInfo {msg} { - return $::errorInfo - } - proc error_source {} { - } - proc script_source {script} { - } - set test(utf8) 1 - rename bytestring "" - package require tcltest - interp alias {} bytestring {} ::tcltest::bytestring -} - -proc ifutf8 {code} { - if {$::test(utf8)} { - uplevel 1 $code - } -} +testConstraint {utf8} [expr {[string length "\xc2\xb5"] == 1}] +testConstraint {references} [expr {[info commands ref] ne ""}] +testConstraint {jim} 1 -proc section {name} { - if {!$::test(quiet)} { - puts "-- $name ----------------" - } +proc bytestring {x} { + return $x } -set test(numfail) 0 -set test(numpass) 0 -set test(failed) {} - -proc test {id descr script expected} { - if {!$::test(quiet)} { +proc test {id descr script {constraints {}} expected} { + incr ::testinfo(numtests) + if {$::testinfo(verbose)} { puts -nonewline "$id " } + foreach c $constraints { + if {![info exists ::tcltest::testConstraints($c)]} { + incr ::testinfo(numskip) + if {$::testinfo(verbose)} { + puts "SKIP" + } + return + } + } set rc [catch {uplevel 1 $script} result] # Note that rc=2 is return if {($rc == 0 || $rc == 2) && $result eq $expected} { - if {!$::test(quiet)} { + if {$::testinfo(verbose)} { puts "OK $descr" } - incr ::test(numpass) + incr ::testinfo(numpass) + return + } + + if {!$::testinfo(verbose)} { + puts -nonewline "$id " + } + puts "ERR $descr" + if {$rc == 0} { + set source [script_source $script] } else { - if {$::test(quiet)} { - puts -nonewline "$id " - } - puts "ERR $descr" - if {$rc == 0} { - set source [script_source $script] - } else { - set source [error_source] - } - puts "Expected: '$expected'" - puts "Got : '$result'" - incr ::test(numfail) - lappend ::test(failed) [list $id $descr $source $expected $result] + set source [error_source] } + puts "Expected: '$expected'" + puts "Got : '$result'" + incr ::testinfo(numfail) + lappend ::testinfo(failed) [list $id $descr $source $expected $result] } proc testreport {} { - if {!$::test(quiet) || $::test(numfail)} { - puts "----------------------------------------------------------------------" - puts "FAILED: $::test(numfail)" - foreach failed $::test(failed) { + if {$::testinfo(verbose)} { + puts -nonewline "\n$::argv0" + } else { + puts -nonewline [format "%16s" $::argv0] + } + puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \ + $::testinfo(numtests) $::testinfo(numpass) $::testinfo(numskip) $::testinfo(numfail)] + if {$::testinfo(numfail)} { + puts [string repeat - 60] + puts "FAILED: $::testinfo(numfail)" + foreach failed $::testinfo(failed) { foreach {id descr source expected result} $failed {} puts "$source\t$id" } - puts "PASSED: $::test(numpass)" - puts "----------------------------------------------------------------------\n" + puts [string repeat - 60] } - if {$::test(numfail)} { + if {$::testinfo(numfail)} { exit 1 } } @@ -119,13 +170,6 @@ proc testerror {} { error "deliberate error" } -set test(quiet) [info exists ::env(testquiet)] -if {[lindex $argv 0] eq "-quiet"} { - incr test(quiet) -} - -if {!$test(quiet)} { - puts [string repeat = 40] - puts $argv0 - puts [string repeat = 40] +if {$testinfo(verbose)} { + puts "==== $argv0 ====" } -- cgit v1.1