diff options
Diffstat (limited to 'itcl/iwidgets3.0.0/tests/defs')
| -rw-r--r-- | itcl/iwidgets3.0.0/tests/defs | 220 |
1 files changed, 0 insertions, 220 deletions
diff --git a/itcl/iwidgets3.0.0/tests/defs b/itcl/iwidgets3.0.0/tests/defs deleted file mode 100644 index d2ac67b9024..00000000000 --- a/itcl/iwidgets3.0.0/tests/defs +++ /dev/null @@ -1,220 +0,0 @@ -# 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 -# ------------------------------------------------------------------ -# THIS SCRIPT IS NOW DEPRECATED! It is kept for older Tcl -# installations that don't have the "tcltest" package. -# Instead, use "package require tcltest" in the test suite. -# ------------------------------------------------------------------ - -package require Iwidgets - -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 - } -} |