Small improvements to tests

Make exec-9.7 test more reliable
Quieten jim tests unless running manually
Add jim pipe example

Signed-off-by: Steve Bennett <steveb@workware.net.au>

6 files changed, 51 insertions, 24 deletions

diff --git a/examples/pipe.tcl b/examples/pipe.tcl
new file mode 100644
index 0000000..6b10dbd
--- /dev/null
+++ b/examples/pipe.tcl
@@ -0,0 +1,16 @@
+lassign [socket pipe] r w
+
+# Note, once the exec has the fh (via dup), close it
+# so that the pipe data is accessible
+exec ps aux >@$w &
+$w close
+
+$r readable {
+	puts [$r gets]
+	if {[eof $r]} {
+		$r close
+		set done 1
+	}
+}
+
+vwait done
diff --git a/tests/concat.test b/tests/concat.test
index 333b634..65d6e1b 100644
--- a/tests/concat.test
+++ b/tests/concat.test
@@ -13,11 +13,11 @@ test concat-1.4 {special characters} {
     concat a\{ {b \{c d} \{d
 } "a{ b \\{c d {d"
 
-test concat-2.1 {error: one empty argument} {
+test concat-2.1 {error check: one empty argument} {
     concat {}
 } {}
 
-test concat-3.1 {error: no arguments} {
+test concat-3.1 {error check: no arguments} {
     list [catch concat msg] $msg
 } {0 {}}
 
diff --git a/tests/exec.test b/tests/exec.test
index 47b246f..e1b6e36 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -313,10 +313,11 @@ test exec-9.6 {commands returning errors} {
     list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg
 } {0 {error msg}}
 test exec-9.7 {commands returning errors} {
-    list [catch {exec sh -c "echo error msg 1>&2" \
-		     | sh -c "echo error msg 1>&2"} msg] $msg
-} {0 {error msg
-error msg}}
+    # Note: Use sleep here to ensure the order
+    list [catch {exec sh -c "echo error msg 1 1>&2" \
+		     | sh -c "sleep 1; echo error msg 2 1>&2"} msg] $msg
+} {0 {error msg 1
+error msg 2}}
 
 # Errors in executing the Tcl command, as opposed to errors in the
 # processes that are invoked.
diff --git a/tests/regexp.test b/tests/regexp.test
index 037fc8e..41d0620 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -28,8 +28,6 @@ test regexp-1.1 {effect of caching} {
 	set t1 [lindex $t1 0]
 	set t2 [lindex $t2 0]
 
-	puts "t1=$t1, t2=$t2"
-
 	# If these two times are within 20% of each other, caching isn't working
 	expr {$t2 * 1.0 / $t1 < 1.2 && $t1 * 1.0 / $t2 < 1.2}
 } {0}
diff --git a/tests/testing.tcl b/tests/testing.tcl
index 3142c72..9c0b4ec 100644
--- a/tests/testing.tcl
+++ b/tests/testing.tcl
@@ -20,7 +20,9 @@ catch {
 }
 
 proc section {name} {
-	puts "-- $name ----------------"
+	if {!$::testquiet} {
+		puts "-- $name ----------------"
+	}
 }
 
 set testresults(numfail) 0
@@ -52,22 +54,32 @@ proc test {id descr script expected} {
 }
 
 proc testreport {} {
-	puts "----------------------------------------------------------------------"
-	puts "FAILED: $::testresults(numfail)"
-	foreach failed $::testresults(failed) {
-		foreach {id descr script expected result} $failed {}
-		puts "\t[info_source $script]\t$id"
+	if {!$::testquiet || $::testresults(numfail)} {
+		puts "----------------------------------------------------------------------"
+		puts "FAILED: $::testresults(numfail)"
+		foreach failed $::testresults(failed) {
+			foreach {id descr script expected result} $failed {}
+			puts "\t[info_source $script]\t$id"
+		}
+		puts "PASSED: $::testresults(numpass)"
+		puts "----------------------------------------------------------------------\n"
+	}
+	if {$::testresults(numfail)} {
+		exit 1
 	}
-	puts "PASSED: $::testresults(numpass)"
-	puts "----------------------------------------------------------------------\n"
 }
 
 proc testerror {} {
 	error "deliberate error"
 }
 
-puts [string repeat = 40]
-puts $argv0
-puts [string repeat = 40]
+incr testquiet [info exists ::env(testquiet)]
+if {[lindex $argv 0] eq "-quiet"} {
+	incr testquiet
+}
 
-set ::testquiet [info exists ::env(testquiet)]
+if {!$testquiet} {
+	puts [string repeat = 40]
+	puts $argv0
+	puts [string repeat = 40]
+}
diff --git a/tests/uplevel.test b/tests/uplevel.test
index b3a7714..0d38c13 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -82,17 +82,17 @@ test uplevel-3.4 {uplevel to same level} {
     a1
 } 55
 
-test uplevel-4.1 {error: non-existent level} {
+test uplevel-4.1 {error check: non-existent level} {
     list [catch c1 msg] $msg
 } {1 {bad level "#2"}}
-test uplevel-4.2 {error: non-existent level} {
+test uplevel-4.2 {error check: non-existent level} {
     proc c2 {} {uplevel 3 {set a b}}
     list [catch c2 msg] $msg
 } {1 {bad level "3"}}
-test uplevel-4.3 {error: not enough args} {
+test uplevel-4.3 {error check: not enough args} {
     list [catch uplevel msg] $msg
 } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
-test uplevel-4.4 {error: not enough args} {
+test uplevel-4.4 {error check: not enough args} {
     proc upBug {} {uplevel 1}
     list [catch upBug msg] $msg
 } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}