# This file contains support code for the Tcl test suite. It is # normally sourced by the individual files in the test suite before # they run their tests. This improved approach to testing was designed # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. if ![info exists VERBOSE] { set VERBOSE 0 } set TESTS {} set auto_noexec 1 set auto_noload 1 catch {rename unknown ""} # If tests are being run as root, issue a warning message and set a # variable to prevent some tests from running at all. set user {} catch {set user [exec whoami]} if {$user == "root"} { puts stdout "Warning: you're executing as root. I'll have to" puts stdout "skip some of the tests, since they'll fail as root." } # Some of the tests don't work on some system configurations due to # configuration quirks, not due to Tcl problems; in order to prevent # false alarms, these tests are only run in the master source directory # at Berkeley. The presence of a file "Berkeley" in this directory is # used to indicate that these tests should be run. set atBerkeley [file exists Berkeley] proc print_verbose {test_name test_description contents_of_test code answer} { puts stdout "\n" puts stdout "==== $test_name $test_description" puts stdout "==== Contents of test case:" puts stdout "$contents_of_test" if {$code != 0} { if {$code == 1} { puts stdout "==== Test generated error:" puts stdout $answer } elseif {$code == 2} { puts stdout "==== Test generated return exception; result was:" puts stdout $answer } elseif {$code == 3} { puts stdout "==== Test generated break exception" } elseif {$code == 4} { puts stdout "==== Test generated continue exception" } else { puts stdout "==== Test generated exception $code; message was:" puts stdout $answer } } else { puts stdout "==== Result was:" puts stdout "$answer" } } proc test {test_name test_description contents_of_test passing_results} { global VERBOSE global TESTS if {[string compare $TESTS ""] != 0} then { set ok 0 foreach test $TESTS { if [string match $test $test_name] then { set ok 1 break } } if !$ok then return } set code [catch {uplevel $contents_of_test} answer] if {$code != 0} { print_verbose $test_name $test_description $contents_of_test \ $code $answer } elseif {[string compare $answer $passing_results] == 0} then { if $VERBOSE then { print_verbose $test_name $test_description $contents_of_test \ $code $answer puts stdout "++++ $test_name PASSED" } } else { print_verbose $test_name $test_description $contents_of_test $code \ $answer puts stdout "---- Result should have been:" puts stdout "$passing_results" puts stdout "---- $test_name FAILED" } } # stick it in a file, run, and test by looking at output proc ftest {test_name test_description contents_of_test passing_results} { global VERBOSE global TESTS global objdir if {[string compare $TESTS ""] != 0} then { set ok 0 foreach test $TESTS { if [string match $test $test_name] then { set ok 1 break } } if !$ok then return } set file [open /tmp/[pid] w] puts $file $contents_of_test close $file set code [catch {exec $objdir/expect /tmp/[pid]} answer] if {$code != 0} { print_verbose $test_name $test_description $contents_of_test \ $code $answer } elseif {[string compare $answer $passing_results] == 0} then { if $VERBOSE then { print_verbose $test_name $test_description $contents_of_test \ $code $answer puts stdout "++++ $test_name PASSED" } } else { print_verbose $test_name $test_description $contents_of_test $code \ $answer puts stdout "---- Result should have been:" puts stdout "$passing_results" puts stdout "---- $test_name FAILED" } catch {exec rm -f /tmp/[pid]} } proc dotests {file args} { global TESTS set savedTests $TESTS set TESTS $args source $file set TESTS $savedTests }