Initial revision

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
+}