91 lines
2.7 KiB
Plaintext
91 lines
2.7 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 {}
|
||
|
|
|
||
|
|
# Some of the tests don't work on some system configurations due to
|
||
|
|
# configuration quirks, not due to Tk 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
|
||
|
|
}
|
||
|
|
|
||
|
|
# If the main window isn't already mapped (e.g. because the tests are
|
||
|
|
# being run automatically) , specify a precise size for it so that the
|
||
|
|
# user won't have to position it manually.
|
||
|
|
|
||
|
|
if {![winfo ismapped .]} {
|
||
|
|
wm geometry . +0+0
|
||
|
|
update
|
||
|
|
}
|