Adding -output and -errorOutput to tcltest

[geoff1111]

The draft patch below adds -output and -errorOutput options to jimtcl tcltest.

As per the original tcltest suite, it uses a (simple) custom puts command which captures its output. For example, to capture stdout from a C/shell program, use puts [exec C-Program/shell-program] as the -body script. If an error is expected, exec C-Program should work (in -body).

It has been tested for the following testfile (and also using make test in jimtcl, just to confirm it does not cause problems, although it
is not really exercised by make test in jimtcl):

source tcltest.tcl

test test1 {test -output option} -body {puts hi} -output {hi
}

test test2 {test -errorOutput option} -body {
        puts hi hi
} -errorOutput {invalid command name "hi"
}

tcltest::cleanupTests

When there is an error, it prints the expected and actual values of -output and -errorOutput with \t, \r and \n indicated visibly so as to make certain whitespace discrepancies more obvious. This is a potential improvement on the original tcltest suite.

It uses a UUID value to signify absence of -output or -errorOutput values, so that a null -output or -errorOutput string can be used to easily capture the actual output. For example, to capture the output of test1 below, use an empty -output string for matching, as indicated. Then the actual string can be copied from the tcltest output into -output, although any \t, \r or \n have to be converted into a tab or carriage return respectively, and any visible \n characters have to be deleted (but leave the actual newline):

source tcltest.tcl

test test1 {test -output option} -body {puts hi} -output {}

tcltest::cleanupTests

Patch is:

diff --git a/tcltest.tcl b/tcltest.tcl
index 9027a44..eb778e2 100644
--- a/tcltest.tcl
+++ b/tcltest.tcl
@@ -11,6 +11,9 @@ set testinfo(numtests) 0
 set testinfo(reported) 0
 set testinfo(failed) {}
 set testinfo(source) [file tail $::argv0]
+set testinfo(outputChannel) stdout
+set testinfo(errorChannel) stderr
+set testinfo(null) f4e75b8b-758f-4a84-91b2-67b8f8d8a5e1

 # -verbose or $testverbose show OK/ERR of individual tests
 if {[lsearch $argv "-verbose"] >= 0 || [info exists env(testverbose)]} {
@@ -310,9 +313,75 @@ proc basename-source {list} {
        list [file tail [lindex $list 0]] [lindex $list 1]
 }

-# Note: We don't support -output or -errorOutput yet
+# Generate a custom "puts" to facilitate the -output and
+# -errorOutput options of tcltest. The original puts is saved as stdputs.
+#    puts ?-nonewline|-errorOut|-out? ?file? ?str?
+# The "str" argument _is required_ if using puts normally (i.e. not
+# using switches -errorOut or -out).
+proc putscreate {} {
+       if {![exists -proc stdputs]} {
+               rename puts stdputs
+       }
+       proc puts [string map [list NULLVAL $::testinfo(null)] {{opt1 NULLVAL} {opt2 NULLVAL} {str NULLVAL}}] {{output {}} {errorOutput {}}} {
+               set nonewline {}
+               set filename stdout
+               switch -- $opt1 {
+                       -nonewline {
+                               set nonewline -nonewline
+                               if {$opt2 eq $::testinfo(null)} {
+                                       error "empty argument after -nonewline"
+                               } elseif {$str eq $::testinfo(null)} {
+                                       set txt $opt2
+                               } else {
+                                       set filename $opt2
+                                       if {$filename ni {stdin stderr} || [catch {$filename stat}]} {
+                                               # there is an error and the standard puts command will raise it
+                                               stdputs $filename $str
+                                       }
+                                       set txt $str
+                               }
+                       }
+                       -out {
+                               return $output
+                       }
+                       -errorOut {
+                               return $errorOutput
+                       }
+                       default {
+                               if {$opt1 eq $::testinfo(null)} {
+                                       error "first argument not provided"
+                               } elseif {$str ne $::testinfo(null)} {
+                                       error "too many arguments"
+                               } elseif {$opt2 eq $::testinfo(null)} {
+                                       set txt $opt1
+                               } else {
+                                       set filename $opt1
+                                       if {$filename ni {stdin stderr} || [catch {$filename stat}]} {
+                                               # there is an error and the standard puts command will raise it
+                                               stdputs $filename $str
+                                       }
+                                       set txt $opt2
+                               }
+                       }
+               }
+               if {$filename eq $::testinfo(outputChannel)} {
+                       set out output
+               } elseif {$filename eq $::testinfo(errorChannel)} {
+                       set out errorOutput
+               }
+               if {$nonewline eq "-nonewline"} {
+                       append $out $txt
+               } else {
+                       append $out $txt "\n"
+               }
+       }
+}
+
+# Note: We support -output and -errorOutput for stdout (using a custom puts) and stderr.
+
 proc test {id descr args} {
-       set default [dict create -returnCodes {ok return} -match exact -result {} -constraints {} -body {} -setup {} -cleanup {}]
+       set default [dict create -returnCodes {ok return} -match exact -constraints {} -body {} -setup {} -cleanup {} \
+               -result {} -output $::testinfo(null) -errorOutput $::testinfo(null)]
        set a $default
        if {[lindex $args 0] ni [dict keys $a]} {
                if {[llength $args] == 2} {
@@ -347,13 +416,27 @@ proc test {id descr args} {
                        puts "-setup failed: $msg"
                }
        }
-       set rc [catch {uplevel 1 $a(-body)} result opts]
+
+       if {$a(-output) ne $::testinfo(null) || $a(-errorOutput) ne $::testinfo(null)} {
+               putscreate
+       }
+
+       if {$a(-errorOutput) ne $::testinfo(null) && "error" ni $a(-returnCodes)} {
+               set a(-returnCodes) "error"
+       }
+
+       set rc [catch {uplevel 1 $a(-body)} result opts]
+       if {$rc != 0 && ($a(-errorOutput) ne $::testinfo(null) || $a(-output) ne $::testinfo(null))} {
+               puts stderr $result
+       }
+
        if {[catch {uplevel 1 $a(-cleanup)} msg]} {
                if {$::testinfo(verbose)} {
                        puts "-cleanup failed: $msg"
                }
        }

+       set ok 1
        if {[info return $rc] ni $a(-returnCodes) && $rc ni $a(-returnCodes)} {
                set ok 0
                set expected "rc=[list $a(-returnCodes)] result=[list $a(-result)]"
@@ -361,17 +444,49 @@ proc test {id descr args} {
                # Now for the template, update -returnCodes
                set a(-returnCodes) [info return $rc]
        } else {
-               if {$a(-match) eq "exact"} {
-                       set ok [string equal $a(-result) $result]
-               } elseif {$a(-match) eq "glob"} {
-                       set ok [string match $a(-result) $result]
-               } elseif {$a(-match) eq "regexp"} {
-                       set ok [regexp $a(-result) $result]
-               } else {
+               if {$a(-match) ni {exact glob regexp}} {
                        return -code error "$id: unknown match type: $a(-match)"
                }
-               set actual [list $result]
-               set expected [list $a(-result)]
+               if {$a(-result) ne {}} {
+                       if {$a(-match) eq "exact"} {
+                               set ok [expr {[string equal $a(-result) $result] && $ok}]
+                       } elseif {$a(-match) eq "glob"} {
+                               set ok [expr {[string match $a(-result) $result] && $ok}]
+                       } else {
+                               set ok [expr {[regexp $a(-result) $result] && $ok}]
+                       }
+                       lappend actual {-result} $result
+                       lappend expected {-result} $a(-result)
+               }
+               if {$a(-output) ne $::testinfo(null)} {
+                       set out [puts -out]
+                       if {$a(-match) eq "exact"} {
+                               set ok [expr {[string equal $a(-output) $out] && $ok}]
+                       } elseif {$a(-match) eq "glob"} {
+                               set ok [expr {[string match $a(-output) $out] && $ok}]
+                       } else {
+                               set ok [expr {[regexp $a(-output) $out] && $ok}]
+                       }
+                       lappend actual {-output} $out
+                       lappend expected {-output} $a(-output)
+               }
+               if {$a(-errorOutput) ne $::testinfo(null)} {
+                       set out [puts -errorOutput]
+                       if {$a(-match) eq "exact"} {
+                               set ok [expr {[string equal $a(-errorOutput) $out] && $ok}]
+                       } elseif {$a(-match) eq "glob"} {
+                               set ok [expr {[string match $a(-errorOutput) $out] && $ok}]
+                       } else {
+                               set ok [expr {[regexp $a(-errorOutput) $out] && $ok}]
+                       }
+                       lappend actual {-errorOutput} $out
+                       lappend expected {-errorOutput} $a(-errorOutput)
+               }
+       }
+
+       if {[exists -proc stdputs]} {
+               rename puts {}
+               rename stdputs puts
        }

        if {$ok} {
@@ -391,8 +506,10 @@ proc test {id descr args} {
        } else {
                set source [error_source]
        }
-       puts "Expected: $expected"
-       puts "Got     : $actual"
+       foreach {exptype exp} $expected {acttype act} $actual {
+               puts "Expected ($exptype): {[string map {\n \\n\n \t \\t \r \\r\r} $exp]}"
+               puts "Got      ($acttype): {[string map {\n \\n\n \t \\t \r \\r\r} $act]}"
+       }
        puts ""
        if {$::testinfo(template)} {
                # We can't really do -match glob|regexp so