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 <steveb@workware.net.au>

1 files changed, 113 insertions, 69 deletions

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 ===="
 }