diff options
Diffstat (limited to 'tests/defs')
| -rw-r--r-- | tests/defs | 367 |
1 files changed, 367 insertions, 0 deletions
diff --git a/tests/defs b/tests/defs new file mode 100644 index 0000000..df518da --- /dev/null +++ b/tests/defs @@ -0,0 +1,367 @@ +# 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-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) defs 1.39 97/08/06 15:32:02 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists TESTS] { + set TESTS {} +} + +tk appname tktest +wm title . tktest + +# Check configuration information that will determine which tests +# to run. To do this, create an array testConfig. Each element +# has a 0 or 1 value, and the following elements are defined: +# unixOnly - 1 means this is a UNIX platform, so it's OK +# to run tests that only work under UNIX. +# macOnly - 1 means this is a Mac platform, so it's OK +# to run tests that only work on Macs. +# pcOnly - 1 means this is a PC platform, so it's OK to +# run tests that only work on PCs. +# unixOrPc - 1 means this is a UNIX or PC platform. +# macOrPc - 1 means this is a Mac or PC platform. +# macOrUnix - 1 means this is a Mac or UNIX platform. +# nonPortable - 1 means this the tests are being running in +# the master Tcl/Tk development environment; +# Some tests are inherently non-portable because +# they depend on things like word length, file system +# configuration, window manager, etc. These tests +# are only run in the main Tcl development directory +# where the configuration is well known. The presence +# of the file "doAllTests" in this directory indicates +# that it is safe to run non-portable tests. +# fonts - 1 means that this platform uses fonts with +# well-know geometries, so it is safe to run +# tests that depend on particular font sizes. + +catch {unset testConfig} + +set testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}] +set testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}] +set testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}] + +set testConfig(unix) $testConfig(unixOnly) +set testConfig(mac) $testConfig(macOnly) +set testConfig(pc) $testConfig(pcOnly) + +set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] +set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] +set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] + +set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists DOALLT~1]] + +set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] +set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] +set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}] + +# The following config switches are used to mark tests that should work, +# but have been temporarily disabled on certain platforms because they don't. + +set testConfig(tempNotPc) [expr !$testConfig(pc)] +set testConfig(tempNotMac) [expr !$testConfig(mac)] +set testConfig(tempNotUnix) [expr !$testConfig(unix)] + +# The following config switches are used to mark tests that crash on +# certain platforms, so that they can be reactivated again when the +# underlying problem is fixed. + +set testConfig(pcCrash) [expr !$testConfig(pc)] +set testConfig(win32sCrash) [expr !$testConfig(win32s)] +set testConfig(macCrash) [expr !$testConfig(mac)] +set testConfig(unixCrash) [expr !$testConfig(unix)] + +set testConfig(fonts) 1 +catch {destroy .e} +entry .e -width 0 -font {Helvetica -12} -bd 1 +.e insert end "a.bcd" +if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { + set testConfig(fonts) 0 +} +destroy .e .t +text .t -width 80 -height 20 -font {Times -14} -bd 1 +pack .t +.t insert end "This is\na dot." +update +set x [list [.t bbox 1.3] [.t bbox 2.5]] +destroy .t +if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} { + set testConfig(fonts) 0 +} + +if {$testConfig(nonPortable) == 0} { + puts "(will skip non-portable tests)" +} +if {$testConfig(fonts) == 0} { + puts "(will skip font-sensitive tests: this system has unexpected font geometries)" +} + +trace variable testConfig r safeFetch + +proc safeFetch {n1 n2 op} { + global testConfig + + if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { + set testConfig($n2) 0 + } +} + +# If there is no "memory" command (because memory debugging isn't +# enabled), generate a dummy command that does nothing. + +if {[info commands memory] == ""} { + proc memory args {} +} + +proc print_verbose {name description script code answer} { + puts stdout "\n" + puts stdout "==== $name $description" + puts stdout "==== Contents of test case:" + puts stdout "$script" + 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" + } +} + +# test -- +# This procedure runs a test and prints an error message if the +# test fails. If VERBOSE has been set, it also prints a message +# even if the test succeeds. The test will be skipped if it +# doesn't match the TESTS variable, or if one of the elements +# of "constraints" turns out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +proc test {name description script answer args} { + global VERBOSE TESTS testConfig + if {[string compare $TESTS ""] != 0} { + set ok 0 + foreach test $TESTS { + if {[string match $test $name]} { + set ok 1 + break + } + } + if {!$ok} { + return + } + } + set i [llength $args] + if {$i == 0} { + # Empty body + } elseif {$i == 1} { + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $answer + set answer [lindex $args 0] + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + + catch {set doTest [uplevel #0 expr $constraints]} + } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $testConfig(a) || $testConfig(b). + + regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c + catch {set doTest [eval expr $c]} + } else { + # just simple constraints such as {unixOnly fonts}. + + set doTest 1 + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + set doTest 0 + break + } + } + } + if {$doTest == 0} { + if {$VERBOSE} { + puts stdout "++++ $name SKIPPED: $constraints" + } + return + } + } else { + error "wrong # args: must be \"test name description ?constraints? script answer\"" + } + memory tag $name + set code [catch {uplevel $script} result] + if {$code != 0} { + print_verbose $name $description $script $code $result + } elseif {[string compare $result $answer] == 0} { + if {$VERBOSE} then { + if {$VERBOSE > 0} { + print_verbose $name $description $script $code $result + } + if {$VERBOSE != -2} { + puts stdout "++++ $name PASSED" + } + } + } else { + print_verbose $name $description $script $code $result + puts stdout "---- Result should have been:" + puts stdout "$answer" + puts stdout "---- $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 + +set tktest [info nameofexecutable] +if {$tktest == "{}"} { + set tktest {} + puts "Unable to find tktest executable, skipping multiple process tests." +} + +# Create background process + +proc setupbg {{args ""}} { + global tktest fd bgData + if {$tktest == ""} { + error "you're not running tktest so setupbg should not have been called" + } + if {[info exists fd] && ($fd != "")} { + cleanupbg + } + set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+] + puts $fd "puts foo; flush stdout" + flush $fd + if {[gets $fd data] < 0} { + error "unexpected EOF from \"$tktest\"" + } + if [string compare $data foo] { + error "unexpected output from background process \"$data\"" + } + 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 [list $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 + } + set fd "" +} + +# Clean up focus after using generate event, which +# can leave the window manager with the wrong impression +# about who thinks they have the focus. (BW) + +proc fixfocus {} { + catch {destroy .focus} + toplevel .focus + wm geometry .focus +0+0 + entry .focus.e + .focus.e insert 0 "fixfocus" + pack .focus.e + update + focus -force .focus.e + destroy .focus +} + +proc makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd +} + +proc removeFile {name} { + file delete -- $name +} |