--- /dev/null
+# 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.
+#
+# RCS: @(#) $Id$
+
+if ![info exists srcdir] {
+ set srcdir .
+}
+
+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
+}
OSDN Git Service
