diff options
Diffstat (limited to 'contrib/tcl/tests/defs')
| -rw-r--r-- | contrib/tcl/tests/defs | 346 |
1 files changed, 346 insertions, 0 deletions
diff --git a/contrib/tcl/tests/defs b/contrib/tcl/tests/defs new file mode 100644 index 0000000..aaf6cfc --- /dev/null +++ b/contrib/tcl/tests/defs @@ -0,0 +1,346 @@ +# 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.37 96/04/12 13:45:04 + +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 {} +catch {set user [exec whoami]} +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." +} + +# 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. + +set doNonPortableTests [file exists doAllTests] + +# 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. +# 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. +# tempNotPc - The inverse of pcOnly. 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. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 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(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(nonPortable) [file exists doAllTests] + +set f [open defs r] +if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 +} else { + set testConfig(nonBlockFiles) 0 +} +close $f + +# 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} + } +} + +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} 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} { + # 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] + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + 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} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $script \ + $code $result + } + 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 +} + +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} { + global tcl_platform testConfig + if {$tcl_platform(platform) == "macintosh"} { + catch {rm -f $name} + } else { + catch {exec rm -f $name} + } +} + +proc makeDirectory {name} { + global tcl_platform testConfig + if {$tcl_platform(platform) == "macintosh"} { + catch {mkdir $name} + } else { + catch {exec mkdir $name} + } +} + +proc removeDirectory {name} { + global tcl_platform testConfig + if {$tcl_platform(platform) == "macintosh"} { + catch {rmdir $name} + } else { + catch {exec rm -rf $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 [list [info nameofexecutable]] +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + + |
