95 lines
2.9 KiB
Plaintext
95 lines
2.9 KiB
Plaintext
# 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.
|
|
|
|
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"
|
|
}
|
|
}
|
|
|
|
proc dotests {file args} {
|
|
global TESTS
|
|
set savedTests $TESTS
|
|
set TESTS $args
|
|
source $file
|
|
set TESTS $savedTests
|
|
}
|