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

[Jacob Bachmeyer]

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