diff options
Diffstat (limited to 'tests/defs')
| -rw-r--r-- | tests/defs | 447 |
1 files changed, 447 insertions, 0 deletions
diff --git a/tests/defs b/tests/defs new file mode 100644 index 0000000..61f90ec --- /dev/null +++ b/tests/defs @@ -0,0 +1,447 @@ +# 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) 1990-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 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.60 97/08/13 18:10:19 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists TESTS] { + set TESTS {} +} + +# If tests are being run as root, issue a warning message and set a +# variable to prevent some tests from running at all. + +set user {} +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {$user == ""} {set user root} + if {$user == "root"} { + puts stdout "Warning: you're executing as root. I'll have to" + puts stdout "skip some of the tests, since they'll fail as root." + set testConfig(root) 1 + } +} + +# Some of the tests don't work on some system configurations due to +# differences in word length, file system configuration, etc. In order +# to prevent false alarms, these tests are generally only run in the +# master development directory for Tcl. The presence of a file +# "doAllTests" in this directory is used to indicate that the non-portable +# tests should be run. + +# 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 {} +} + +# 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. +# knownBug - The test is known to fail and the bug is not yet +# fixed. The test will be run only if the file +# "doBuggyTests" exists (intended for Tcl dev. group +# internal use only). +# tempNotPc - The inverse of pcOnly. This flag is used to +# temporarily disable a test. +# tempNotMac - The inverse of macOnly. This flag is used to +# temporarily disable a test. +# nonBlockFiles - 1 means this platform supports setting files into +# nonblocking mode. +# asyncPipeClose- 1 means this platform supports async flush and +# async close on a pipe. +# unixExecs - 1 means this machine has commands such as 'cat', +# 'echo' etc available. +# notIfCompiled - 1 means this that it is safe to run tests that +# might fail if the bytecode compiler is used. This +# element is set 1 if the file "doAllTests" exists in +# this directory. Normally, this element is 0 so that +# tests that fail with the bytecode compiler are +# skipped. As of 11/2/96 these are the history tests +# since they depend on accurate source location +# information. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 1 + set testConfig(tempNotMac) 1 +} else { + set testConfig(unixOnly) 0 +} +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(tempNotPc) 1 + set testConfig(macOnly) 1 +} else { + set testConfig(macOnly) 0 +} +if {$tcl_platform(platform) == "windows"} { + set testConfig(tempNotMac) 1 + set testConfig(pcOnly) 1 +} else { + set testConfig(pcOnly) 0 +} +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 doAllTe]] +set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]] +set testConfig(notIfCompiled) [file exists doAllCompilerTests] + +set testConfig(unix) $testConfig(unixOnly) +set testConfig(mac) $testConfig(macOnly) +set testConfig(pc) $testConfig(pcOnly) + +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 crash on +# certain platforms, so that they can be reactivated again when the +# underlying problem is fixed. + +set testConfig(pcCrash) $testConfig(macOrUnix) +set testConfig(macCrash) $testConfig(unixOrPc) +set testConfig(unixCrash) $testConfig(macOrPc) + +if {[catch {set f [open defs r]}]} { + set testConfig(nonBlockFiles) 1 +} else { + if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 + } else { + set testConfig(nonBlockFiles) 0 + } + close $f +} + +trace variable testConfig r safeFetch + +proc safeFetch {n1 n2 op} { + global testConfig + + if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { + set testConfig($n2) 0 + } +} + +# Test for SCO Unix - cannot run async flushing tests because a potential +# problem with select is apparently interfering. (Mark Diekhans). + +if {$tcl_platform(platform) == "unix"} { + if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { + set testConfig(asyncPipeClose) 0 + } else { + set testConfig(asyncPipeClose) 1 + } +} else { + set testConfig(asyncPipeClose) 1 +} + +# Test to see if execed commands such as cat, echo, rm and so forth are +# present on this machine. + +set testConfig(unixExecs) 1 +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(unixExecs) 0 +} +if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {$testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set testConfig(unixExecs) 0 + } + } + if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + if {$testConfig(unixExecs) == 0} { + puts stdout "Warning: Unix-style executables are not available, so" + puts stdout "some tests will be skipped." + } +} + +proc print_verbose {name description constraints script code answer} { + puts stdout "\n" + if {[string length $constraints]} { + puts stdout "==== $name $description\t--- ($constraints) ---" + } else { + 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} then { + set ok 0 + foreach test $TESTS { + if [string match $test $name] then { + set ok 1 + break + } + } + if !$ok then return + } + set i [llength $args] + if {$i == 0} { + set constraints {} + } 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 [list $constraints]]} msg + } 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 then { + 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 $constraints $script \ + $code $result + } elseif {[string compare $result $answer] == 0} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $constraints $script \ + $code $result + } + if {$VERBOSE != -2} { + puts stdout "++++ $name PASSED" + } + } + } else { + print_verbose $name $description $constraints $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 +} + +proc normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +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 +} + +proc makeDirectory {name} { + file mkdir $name +} + +proc removeDirectory {name} { + file delete -force $name +} + +proc viewFile {name} { + global tcl_platform testConfig + if {($tcl_platform(platform) == "macintosh") || \ + ($testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# Locate tcltest executable + +set tcltest [info nameofexecutable] + +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + +if {$tcl_platform(os) != "Win32s"} { + # Don't even try running another copy of tcltest under win32s, or you + # get an error dialog about multiple instances. + + catch { + file delete -force tmp + set f [open tmp w] + puts $f { + exit + } + close $f + set f [open "|[list $tcltest tmp]" r] + close $f + set testConfig(stdio) 1 + } +} + +if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} { + puts "(will skip tests that redirect stdio of exec'd 32-bit applications)" +} + +catch {socket} msg +set testConfig(socket) [expr {$msg != "sockets are not available on this system"}] + +if {$testConfig(socket) == 0} { + puts "(will skip tests that use sockets)" +} + + |