summaryrefslogtreecommitdiffstats
path: root/tests/defs
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 01:51:06 (GMT)
committerstanton <stanton>1999-04-16 01:51:06 (GMT)
commit03656f44f81469f459031fa3a4a7b09c8bc77712 (patch)
tree31378e81bd58f8c726fc552d6b30cbf3ca07497b /tests/defs
parent404fc236f34304df53b7e44bc7971d786b87d453 (diff)
downloadtk-03656f44f81469f459031fa3a4a7b09c8bc77712.zip
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.gz
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.bz2
* Merged 8.1 branch into the main trunk
Diffstat (limited to 'tests/defs')
-rw-r--r--tests/defs372
1 files changed, 0 insertions, 372 deletions
diff --git a/tests/defs b/tests/defs
deleted file mode 100644
index a7037ee..0000000
--- a/tests/defs
+++ /dev/null
@@ -1,372 +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-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: defs,v 1.4 1999/04/16 01:25:55 stanton Exp $
-
-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 stdout "(will skip non-portable tests)"
-}
-if {$testConfig(fonts) == 0} {
- puts stdout "(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} {
- 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"
- }
- if {[string compare $::tcl_platform(platform) macintosh] == 0} {
- # Force the text to be drawn even if the tests are not updating.
- update idletasks
- }
-}
-
-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 stdout "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
-}