summaryrefslogtreecommitdiffstats
path: root/tests/defs.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tests/defs.tcl')
-rw-r--r--tests/defs.tcl95
1 files changed, 93 insertions, 2 deletions
diff --git a/tests/defs.tcl b/tests/defs.tcl
index 1e7d8fc..727c787 100644
--- a/tests/defs.tcl
+++ b/tests/defs.tcl
@@ -11,23 +11,27 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: defs.tcl,v 1.2 1999/04/16 00:47:26 stanton Exp $
+# RCS: @(#) $Id: defs.tcl,v 1.3 1999/04/20 18:12:18 hershey Exp $
# Initialize wish shell
+
if {[info exists tk_version]} {
tk appname tktest
wm title . tktest
} else {
+
# Ensure that we have a minimal auto_path so we don't pick up extra junk.
+
set auto_path [list [info library]]
}
# create the "tcltest" namespace for all testing variables and procedures
+
namespace eval tcltest {
set procList [list test cleanupTests dotests saveState restoreState \
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
viewFile bytestring set_iso8859_1_locale restore_locale \
- safeFetch]
+ safeFetch threadReap]
if {[info exists tk_version]} {
lappend procList setupbg dobg bgReady cleanupbg fixfocus
}
@@ -36,12 +40,15 @@ namespace eval tcltest {
}
# ::tcltest::verbose defaults to "b"
+
variable verbose "b"
# match defaults to the empty list
+
variable match {}
# skip defaults to the empty list
+
variable skip {}
# Tests should not rely on the current working directory.
@@ -77,15 +84,22 @@ namespace eval tcltest {
# ::tcltest::numTests will store test files as indices and the list
# of files (that should not have been) left behind by the test files.
+
array set ::tcltest::createdNewFiles {}
# initialize ::tcltest::numTests array to keep track fo the number of
# tests that pass, fial, and are skipped.
+
array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
# initialize ::tcltest::skippedBecause array to keep track of
# constraints that kept tests from running
+
array set ::tcltest::skippedBecause {}
+
+ # tests that use thread need to know which is the main thread
+
+ set ::tcltest::mainThread [testthread names]
}
# If there is no "memory" command (because memory debugging isn't
@@ -169,6 +183,7 @@ proc ::tcltest::initConfig {} {
set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]
# Set the "fonts" constraint for wish apps
+
if {[info exists tk_version]} {
set ::tcltest::testConfig(fonts) 1
catch {destroy .e}
@@ -191,22 +206,28 @@ proc ::tcltest::initConfig {} {
}
# Skip empty tests
+
set ::tcltest::testConfig(emptyTest) 0
# By default, tests that expost known bugs are skipped.
+
set ::tcltest::testConfig(knownBug) 0
# By default, non-portable tests are skipped.
+
set ::tcltest::testConfig(nonPortable) 0
# Some tests require user interaction.
+
set ::tcltest::testConfig(userInteraction) 0
# Some tests must be skipped if the interpreter is not in interactive mode
+
set ::tcltest::testConfig(interactive) $tcl_interactive
# Some tests must be skipped if you are running as root on Unix.
# Other tests can only be run if you are running as root on Unix.
+
set ::tcltest::testConfig(root) 0
set ::tcltest::testConfig(notRoot) 1
set user {}
@@ -223,6 +244,7 @@ proc ::tcltest::initConfig {} {
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
+
if {[catch {set f [open defs r]}]} {
set ::tcltest::testConfig(nonBlockFiles) 1
} else {
@@ -240,6 +262,7 @@ proc ::tcltest::initConfig {} {
# 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 ::tcltest::testConfig(asyncPipeClose) 0
@@ -252,6 +275,7 @@ proc ::tcltest::initConfig {} {
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
+
set ::tcltest::testConfig(eformat) 1
if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
set ::tcltest::testConfig(eformat) 0
@@ -259,6 +283,7 @@ proc ::tcltest::initConfig {} {
# Test to see if execed commands such as cat, echo, rm and so forth are
# present on this machine.
+
set ::tcltest::testConfig(unixExecs) 1
if {$tcl_platform(platform) == "macintosh"} {
set ::tcltest::testConfig(unixExecs) 0
@@ -336,6 +361,7 @@ proc ::tcltest::processCmdLineArgs {} {
# The "argv" var doesn't exist in some cases, so use {}
# The "argv" var doesn't exist in some cases.
+
if {(![info exists argv]) || ([llength $argv] < 2)} {
set flagArray {}
} else {
@@ -351,6 +377,7 @@ proc ::tcltest::processCmdLineArgs {} {
# Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
# Note that -verbose cannot be abbreviated to -v in wish because it
# conflicts with the wish option -visual.
+
foreach arg {-verbose -match -skip -constraints} {
set abbrev [string range $arg 0 1]
if {([info exists flag($abbrev)]) && \
@@ -362,22 +389,26 @@ proc ::tcltest::processCmdLineArgs {} {
# Set ::tcltest::workingDir to [pwd].
# Save the names of files that already exist in ::tcltest::workingDir.
+
set ::tcltest::workingDir [pwd]
foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
lappend ::tcltest::filesExisted [file tail $file]
}
# Set ::tcltest::verbose to the arg of the -verbose flag, if given
+
if {[info exists flag(-verbose)]} {
set ::tcltest::verbose $flag(-verbose)
}
# Set ::tcltest::match to the arg of the -match flag, if given
+
if {[info exists flag(-match)]} {
set ::tcltest::match $flag(-match)
}
# Set ::tcltest::skip to the arg of the -skip flag, if given
+
if {[info exists flag(-skip)]} {
set ::tcltest::skip $flag(-skip)
}
@@ -385,6 +416,7 @@ proc ::tcltest::processCmdLineArgs {} {
# Use the -constraints flag, if given, to turn on constraints that are
# turned off by default: userInteractive knownBug nonPortable. This
# code fragment must be run after constraints are initialized.
+
if {[info exists flag(-constraints)]} {
foreach elt $flag(-constraints) {
set ::tcltest::testConfig($elt) 1
@@ -414,6 +446,7 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
# ::tcltest::makeDirectory procedures.
# Record the names of files in ::tcltest::workingDir that were not
# pre-existing, and associate them with the test file that created them.
+
if {!$calledFromAllFile} {
foreach file $::tcltest::filesMade {
@@ -438,7 +471,9 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
}
if {$calledFromAllFile || $::tcltest::testSingleFile} {
+
# print stats
+
puts -nonewline stdout "$tail:"
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
@@ -447,6 +482,7 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
# print number test files sourced
# print names of files that ran tests which failed
+
if {$calledFromAllFile} {
puts stdout "Sourced $::tcltest::numTestFiles Test Files."
set ::tcltest::numTestFiles 0
@@ -458,6 +494,7 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
# if any tests were skipped, print the constraints that kept them
# from running.
+
set constraintList [array names ::tcltest::skippedBecause]
if {[llength $constraintList] > 0} {
puts stdout "Number of tests skipped for each constraint:"
@@ -470,6 +507,7 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
# report the names of test files in ::tcltest::createdNewFiles, and
# reset the array to be empty.
+
set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
if {[llength $testFilesThatTurded] > 0} {
puts stdout "Warning: test files left files behind:"
@@ -480,20 +518,24 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
}
# reset filesMade, filesExisted, and numTests
+
set ::tcltest::filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
set ::tcltest::numTests($index) 0
}
# exit only if running Tk in non-interactive mode
+
global tk_version tcl_interactive
if {[info exists tk_version] && !$tcl_interactive} {
exit
}
} else {
+
# if we're deferring stat-reporting until all files are sourced,
# then add current file to failFile list if any tests in this file
# failed
+
incr ::tcltest::numTestFiles
if {($::tcltest::currentFailure) && \
([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
@@ -531,6 +573,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
incr ::tcltest::numTests(Total)
# skip the test if it's name matches an element of skip
+
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
@@ -538,6 +581,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
}
}
# skip the test if it's name doesn't match any element of match
+
if {[llength $::tcltest::match] > 0} {
set ok 0
foreach pattern $::tcltest::match {
@@ -555,6 +599,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
if {$i == 0} {
set constraints {}
} elseif {$i == 1} {
+
# "constraints" argument exists; shuffle arguments down, then
# make sure that the constraints are satisfied.
@@ -563,10 +608,13 @@ proc ::tcltest::test {name description script expectedAnswer args} {
set expectedAnswer [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
# $::tcltest::testConfig(a) || $::tcltest::testConfig(b).
@@ -574,6 +622,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
{$::tcltest::testConfig(&)} c
catch {set doTest [eval expr $c]}
} else {
+
# just simple constraints such as {unixOnly fonts}.
set doTest 1
@@ -581,7 +630,9 @@ proc ::tcltest::test {name description script expectedAnswer args} {
if {![info exists ::tcltest::testConfig($constraint)]
|| !$::tcltest::testConfig($constraint)} {
set doTest 0
+
# store the constraint that kept the test from running
+
set constraints $constraint
break
}
@@ -592,8 +643,10 @@ proc ::tcltest::test {name description script expectedAnswer args} {
if {[string first s $::tcltest::verbose] != -1} {
puts stdout "++++ $name SKIPPED: $constraints"
}
+
# add the constraint to the list of constraints the kept tests
# from running
+
if {[info exists ::tcltest::skippedBecause($constraints)]} {
incr ::tcltest::skippedBecause($constraints)
} else {
@@ -821,6 +874,7 @@ catch {file delete -force tmp}
# Deliberately call the socket with the wrong number of arguments. The error
# message you get will indicate whether sockets are available on this system.
+
catch {socket} msg
set ::tcltest::testConfig(socket) \
[expr {$msg != "sockets are not available on this system"}]
@@ -828,11 +882,14 @@ set ::tcltest::testConfig(socket) \
#
# Internationalization / ISO support procs -- dl
#
+
if {[info commands testlocale]==""} {
+
# No testlocale command, no tests...
# (it could be that we are a sub interp and we could just load
# the Tcltest package but that would interfere with tests
# that tests packages/loading in slaves...)
+
set ::tcltest::testConfig(hasIsoLocale) 0
} else {
proc ::tcltest::set_iso8859_1_locale {} {
@@ -848,7 +905,9 @@ if {[info commands testlocale]==""} {
set ::tcltest::isoLocale fr
switch $tcl_platform(platform) {
"unix" {
+
# Try some 'known' values for some platforms:
+
switch -exact -- $tcl_platform(os) {
"FreeBSD" {
set ::tcltest::isoLocale fr_FR.ISO_8859-1
@@ -861,9 +920,11 @@ if {[info commands testlocale]==""} {
set ::tcltest::isoLocale fr
}
default {
+
# Works on SunOS 4 and Solaris, and maybe others...
# define it to something else on your system
#if you want to test those.
+
set ::tcltest::isoLocale iso_8859_1
}
}
@@ -882,7 +943,9 @@ if {[info commands testlocale]==""} {
#
# procedures that are Tk specific
#
+
if {[info exists tk_version]} {
+
# 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.
@@ -934,6 +997,7 @@ if {[info exists tk_version]} {
# Send a command to the background process, catching errors and
# flushing I/O channels
+
proc ::tcltest::dobg {command} {
puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
flush $::tcltest::fd
@@ -946,6 +1010,7 @@ if {[info exists tk_version]} {
# Data arrived from background process. Check for special marker
# indicating end of data for this command, and make data available
# to dobg procedure.
+
proc ::tcltest::bgReady {} {
set x [gets $::tcltest::fd]
if {[eof $::tcltest::fd]} {
@@ -959,6 +1024,7 @@ if {[info exists tk_version]} {
}
# Exit the background process, and close the pipes
+
proc ::tcltest::cleanupbg {} {
catch {
puts $::tcltest::fd "exit"
@@ -984,7 +1050,32 @@ if {[info exists tk_version]} {
}
}
+# threadReap --
+#
+# Kill all thread except for the main thread.
+#
+# Arguments:
+# none.
+#
+# Results:
+# Returns the number of existing threads.
+
+proc ::tcltest::threadReap {} {
+ testthread errorproc ThreadNullError
+ while {[llength [testthread names]] > 1} {
+ foreach tid [testthread names] {
+ if {$tid != $::tcltest::mainThread} {
+ catch {testthread send -async $tid {testthread exit}}
+ update
+ }
+ }
+ }
+ testthread errorproc ThreadError
+ return [llength [testthread names]]
+}
+
# Need to catch the import because it fails if defs.tcl is sourced
# more than once.
+
catch {namespace import ::tcltest::*}
return