PATCH 2/3: add mocks for recording output of library tests and use them with clone_output

This patch improves the tests for clone_output to actually verify 
output.  Note that the testsuite will fail after applying this patch -- 
the improved tests uncover a bug in clone_output!

----
ChangeLog entry:
	* testsuite/runtest.libs/clone_output.test: Use new test harness
	for verifying output of clone_output.

	* testsuite/runtest.libs/default_procs.tcl (send_error): Roll into
	template using store_test_output.
	(send_log): Likewise.
	(send_user): Likewise.
	(clear_test_output): New proc.
	(store_test_output): New proc.
---
 testsuite/runtest.libs/clone_output.test |   61 +++++++++++++++------
 testsuite/runtest.libs/default_procs.tcl |   90 ++++++++++++++++++++++++++---
 2 files changed, 124 insertions(+), 27 deletions(-)

diff --git a/testsuite/runtest.libs/clone_output.test b/testsuite/runtest.libs/clone_output.test
index 91ca9f9..cc20be6 100644
--- a/testsuite/runtest.libs/clone_output.test
+++ b/testsuite/runtest.libs/clone_output.test
@@ -11,48 +11,75 @@ if [ file exists $srcdir/../lib/framework.exp] {
     puts "ERROR: $srcdir/../lib/framework.exp doesn't exist"
 }
 
-# TODO: override { send_error send_log send_user } to verify correct output
-
 set all_flag 0
 set errno ""
 
+# The results in these tests are slightly convoluted because everything
+# sent to the error or user stream is also copied to the log stream when
+# actually using Expect, but the test harness records exactly what is
+# explicitly passed, rather than what Expect will do with it.
+
 # stuff that shouldn't print anything without all_flag set
 set all_flag 0
 run_tests {
-    { lib_pat_test clone_output {"PASS: Foo"} ""
+    { lib_output_test clone_output {"PASS: Foo"}
+	{ tty "" log "PASS: Foo\n" user "" error "" }
 	"clone_output(pass) without all_flag set" }
-    { lib_pat_test clone_output {"UNRESOLVED: Foo"} ""
+    { lib_output_test clone_output {"XFAIL: Foo"}
+	{ tty "" log "XFAIL: Foo\n" user "" error "" }
+	"clone_output(xfail) without all_flag set" }
+    { lib_output_test clone_output {"KFAIL: Foo"}
+	{ tty "" log "KFAIL: Foo\n" user "" error "" }
+	"clone_output(kfail) without all_flag set" }
+    { lib_output_test clone_output {"UNRESOLVED: Foo"}
+	{ tty "" log "UNRESOLVED: Foo\n" user "" error "" }
 	"clone_output(unresolved) without all_flag set" }
-    { lib_pat_test clone_output {"UNSUPPORTED: Foo"} ""
+    { lib_output_test clone_output {"UNSUPPORTED: Foo"}
+	{ tty "" log "UNSUPPORTED: Foo\n" user "" error "" }
 	"clone_output(unsupported) without all_flag set" }
-    { lib_pat_test clone_output {"UNTESTED: Foo"} ""
+    { lib_output_test clone_output {"UNTESTED: Foo"}
+	{ tty "" log "UNTESTED: Foo\n" user "" error "" }
 	"clone_output(untested) without all_flag set" }
-    { lib_pat_test clone_output {"ERROR: Bar"} "ERROR: Bar"
+    { lib_output_test clone_output {"ERROR: Bar"}
+	{ tty "" log "" user "" error "ERROR: Bar\n" }
 	"clone_output(error) without all_flag set" }
-    { lib_pat_test clone_output {"WARNING: Bar"} "WARNING: Bar"
+    { lib_output_test clone_output {"WARNING: Bar"}
+	{ tty "" log "" user "" error "WARNING: Bar\n" }
 	"clone_output(warning) without all_flag set" }
-    { lib_pat_test clone_output {"NOTE: Bar"} "NOTE: Bar"
+    { lib_output_test clone_output {"NOTE: Bar"}
+	{ tty "" log "" user "" error "NOTE: Bar\n" }
 	"clone_output(note) without all_flag set" }
 }
 
 # tests for all_flag set to 1
 set all_flag 1
 run_tests {
-    { lib_pat_test clone_output {"PASS: Foo"} "PASS: Foo"
+    { lib_output_test clone_output {"PASS: Foo"}
+	{ tty "" log "" user "PASS: Foo\n" error "" }
 	"clone_output(pass) with all_flag set" }
-    { lib_pat_test clone_output {"XFAIL: Foo"} "XFAIL: Foo"
+    { lib_output_test clone_output {"XFAIL: Foo"}
+	{ tty "" log "" user "XFAIL: Foo\n" error "" }
 	"clone_output(xfail) with all_flag set" }
-    { lib_pat_test clone_output {"UNRESOLVED: Foo"} "UNRESOLVED: Foo"
+    { lib_output_test clone_output {"KFAIL: Foo"}
+	{ tty "" log "" user "KFAIL: Foo\n" error "" }
+	"clone_output(kfail) with all_flag set" }
+    { lib_output_test clone_output {"UNRESOLVED: Foo"}
+	{ tty "" log "" user "UNRESOLVED: Foo\n" error "" }
 	"clone_output(unresolved) with all_flag set" }
-    { lib_pat_test clone_output {"UNSUPPORTED: Foo"} "UNSUPPORTED: Foo"
+    { lib_output_test clone_output {"UNSUPPORTED: Foo"}
+	{ tty "" log "" user "UNSUPPORTED: Foo\n" error "" }
 	"clone_output(unsupported) with all_flag set" }
-    { lib_pat_test clone_output {"UNTESTED: Foo"} "UNTESTED: Foo"
+    { lib_output_test clone_output {"UNTESTED: Foo"}
+	{ tty "" log "" user "UNTESTED: Foo\n" error "" }
 	"clone_output(untested) with all_flag set" }
-    { lib_pat_test clone_output {"ERROR: Foo"} "ERROR: Foo"
+    { lib_output_test clone_output {"ERROR: Bar"}
+	{ tty "" log "" user "" error "ERROR: Bar\n" }
 	"clone_output(error) with all_flag set" }
-    { lib_pat_test clone_output {"WARNING: Foo"} "WARNING: Foo"
+    { lib_output_test clone_output {"WARNING: Bar"}
+	{ tty "" log "" user "" error "WARNING: Bar\n" }
 	"clone_output(warning) with all_flag set" }
-    { lib_pat_test clone_output {"NOTE: Foo"} "NOTE: Foo"
+    { lib_output_test clone_output {"NOTE: Bar"}
+	{ tty "" log "" user "" error "NOTE: Bar\n" }
 	"clone_output(note) with all_flag set" }
 }
 
diff --git a/testsuite/runtest.libs/default_procs.tcl b/testsuite/runtest.libs/default_procs.tcl
index 2d21392..1305672 100644
--- a/testsuite/runtest.libs/default_procs.tcl
+++ b/testsuite/runtest.libs/default_procs.tcl
@@ -118,6 +118,86 @@ proc lib_err_test { cmd arglist val } {
     }
 }
 
+# support for testing output procs
+proc clear_test_output {} {
+    global test_output
+
+    array unset test_output
+    array set test_output { error {} log {} tty {} user {} }
+}
+
+proc store_test_output { dest argv } {
+    global test_output
+
+    set argc [llength $argv]
+    for { set argi 0 } { $argi < $argc } { incr argi } {
+	set arg [lindex $argv $argi]
+	if { $arg eq "--" } {
+	    set stri [expr $argi + 1]
+	    break
+	} elseif { ![string match "-*" $arg] } {
+	    set stri $argi
+	}
+    }
+    # the string must be the last argument
+    if { $stri != ($argc - 1) } {
+	error "bad call: send_${dest} $argv"
+    }
+    append test_output($dest) [lindex $argv $stri]
+}
+foreach dest { error log tty user } {
+    proc send_${dest} { args } [concat store_test_output $dest {$args}]
+}
+
+# this checks output against VAL, which is a list of key-value pairs
+#  each key specifies an output channel (from { error log tty user }) and a
+#  matching mode (from { "", pat, re }) separated by "_" unless mode is ""
+proc lib_output_test { cmd arglist val } {
+    global test_output
+
+    puts "CMD(lib_output_test) is: $cmd $arglist"
+    clear_test_output
+    if { ([llength $val] % 2) != 0 } {
+	puts "ERROR(lib_output_test): expected result is invalid"
+	return -1
+    }
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
+	puts "RESULT(lib_output_test) was: $result"
+	foreach dest { error log tty user } {
+	    puts "OUTPUT(lib_output_test/$dest) was: <<$test_output($dest)>>"
+	}
+    } else {
+	puts "RESULT(lib_output_test) was error \"${result}\""
+	return -1
+    }
+    foreach { check expected } $val {
+	if { [regexp {(error|log|tty|user)(?:_(pat|re))?} $check\
+		  -> dest mode] != 1 } {
+	    puts "ERROR(lib_output_test): unknown check token: $check"
+	    return -1
+	}
+	switch -- $mode {
+	    "" {
+		if { ![string equal $expected $test_output($dest)] } {
+		    return 0
+		}
+	    }
+	    pat {
+		if { ![string match $expected $test_output($dest)] } {
+		    return 0
+		}
+	    }
+	    re {
+		if { ![regexp -- $expected $test_output($dest)] } {
+		    return 0
+		}
+	    }
+	}
+    }
+    # if we get here, all checks have passed
+    return 1
+}
+
 #
 # This runs a standard test for a proc. The list is set up as:
 # |test proc|proc being tested|args|pattern|message|
@@ -145,16 +225,6 @@ proc run_tests { tests } {
     }
 }
 
-proc send_log { args } {
-    # this is just a stub for testing
-}
-proc send_error { args } {
-    # this is just a stub for testing
-}
-proc send_user { args } {
-    # this is just a stub for testing
-}
-
 proc pass { msg } {
     puts "PASSED: $msg"
 }
----


-- Jacob