diff options
Diffstat (limited to 'itcl/iwidgets3.0.0/incoming/tests/defs')
| -rw-r--r-- | itcl/iwidgets3.0.0/incoming/tests/defs | 213 |
1 files changed, 213 insertions, 0 deletions
diff --git a/itcl/iwidgets3.0.0/incoming/tests/defs b/itcl/iwidgets3.0.0/incoming/tests/defs new file mode 100644 index 00000000000..4cda24e26a7 --- /dev/null +++ b/itcl/iwidgets3.0.0/incoming/tests/defs @@ -0,0 +1,213 @@ +# 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. +# +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) defs 1.7 94/12/17 15:53:52 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists DELAY] { + set DELAY 0 +} +if ![info exists TESTS] { + 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 development +# directory for Tk. The presence of a file "doAllTests" in this +# directory is used to indicate that these tests should be run. + +set doNonPortableTests [file exists doAllTests] + +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 + global DELAY + 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" + } + after $DELAY +} + +# +# Like test, but does reg expr check on the results. +# Useful when the result must follow a pattern but some exact details +# are not necessary, like an internal number appended to a frame, etc. +# +proc test_pattern {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 {[regexp -- [lindex $passing_results 1] [lindex $answer 1]] == 1 } { + 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 +} + +# The following code can be used to perform tests involving a second +# process running in the background. + +# Locate tktest executable +global argv0 +if {0} { +puts "file executable $argv0...[file executable $argv0]" +if { [file executable $argv0] } { + if { [string index $argv0 0] == "/" } { + set tktest $argv0 + } else { + set tktest "[pwd]/$argv0" + } +} elseif { [file executable ../$argv0] } { + set tktest "[pwd]/../$argv0" +} else { + set tktest {} + puts "Unable to find tktest executable, skipping multiple process tests." +} +} else {set tktest ../tktest} + +# Create background process +proc setupbg {{args ""}} { + global tktest fd bgData + set fd [open "|$tktest -geometry +0+0 $args" r+] + puts $fd "puts foo; flush stdout" + flush $fd + gets $fd + fileevent $fd readable bgReady +} + +# Send a command to the background process, catching errors and +# flushing I/O channels +proc dobg {command} { + global fd bgData bgDone + puts $fd "catch {$command} msg; update; puts \$msg; puts **DONE**; flush stdout" + flush $fd + set bgDone 0 + set bgData {} + tkwait variable bgDone + set bgData +} + +# Data arrived from background process. Check for special marker +# indicating end of data for this command, and make data available +# to dobg procedure. +proc bgReady {} { + global fd bgData bgDone + set x [gets $fd] + if [eof $fd] { + fileevent $fd readable {} + set bgDone 1 + } elseif {$x == "**DONE**"} { + set bgDone 1 + } else { + append bgData $x + } +} + +# Exit the background process, and close the pipes +proc cleanupbg {} { + global fd + catch { + puts $fd "exit" + close $fd + } +} |