Adding -output and -errorOutput to tcltest

[geoff1111]

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

It uses a custom puts command to capture output, but the custom puts is only activated when either -output or -errorOutput is specified in a test. 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). Similarly, output or error output (via puts) from a tcl script can be tested. Since puts is customized in this patch when -output or -errorOutput is specified, this renders tcltest.tcl unable to fully test standard puts when writing to stdout or stderr.

It has been tested for the following testfile (and also using make test in jimtcl, just to confirm it does not cause problems; it
is not really exercised by make test in jimtcl currently (because the tests do not check -output or -errorOutput AFAIK):

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. The output is also surrounded by braces, again in the interest of making whitespace discrepancies more obvious.

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..5149da5 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,77 @@ 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 NV $::testinfo(null)] {{opt1 NV} {opt2 NV} {str NV}}] {{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 [list $::testinfo(outputChannel) $::testinfo(errorChannel)] \
+                                               || [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 [list $::testinfo(outputChannel) $::testinfo(errorChannel)] \
+                                               || [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 +418,30 @@ 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]
+
+       # capture errors into stderr automatically:
+       if {[info returncodes $rc] eq "error" && $a(-errorOutput) ne $::testinfo(null)} {
+               puts $::testinfo(errorChannel) $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 +449,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 -errorOut]
+                       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,9 +511,13 @@ 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
                # just store the result as-is for -match exact

[msteveb]

I actually didn't know about -output! I took a look and it has very little use in the current testsuite. Is it useful enough to add?

[geoff1111]

Not essential, AFAIK.

-output and -errorOutput could have utility where you need to test the output of a proc (e.g. printMsg {chan} {...}) which has no return value, but prints something to either stdout or stderr.

Of course, it is possible to work around the absence of -output or -errorOutput in this circumstance by changing the proc to return a value, and then puts that value, e.g. puts $chan [formatMsg]. In this modified circumstance, formatMsg should be testable using -result.

[msteveb]

Thanks. I'll hold off adding support for -output for now, but I may come back to it