* Merged 8.1 branch into the main trunk

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