summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorhershey <hershey>1999-04-20 18:12:18 (GMT)
committerhershey <hershey>1999-04-20 18:12:18 (GMT)
commit1078972debd4f992f68ecb132cb08616037048cd (patch)
treef5e45ddab0d5fdc67a74211c7040229c6827a4ae /tests
parentd81cb57b05280ff7ad32f29f973b028856e3cd24 (diff)
downloadtcl-1078972debd4f992f68ecb132cb08616037048cd.zip
tcl-1078972debd4f992f68ecb132cb08616037048cd.tar.gz
tcl-1078972debd4f992f68ecb132cb08616037048cd.tar.bz2
moved the ThreadReap command to ::tcltest::threadReap. Now each thread test calls
threadReap at the beginning and end of the test, inside the test body. This fixes the problem where the test suite was exiting on a call to threadReap (reap was killing the main thread by accident because other tests were leaving threads running and setting mainthread to be the list of running threads).
Diffstat (limited to 'tests')
-rw-r--r--tests/README4
-rw-r--r--tests/defs.tcl95
-rw-r--r--tests/socket.test32
-rw-r--r--tests/thread.test170
4 files changed, 192 insertions, 109 deletions
diff --git a/tests/README b/tests/README
index fe4bb30..3b22393 100644
--- a/tests/README
+++ b/tests/README
@@ -1,6 +1,6 @@
README -- Tcl test suite design document.
-RCS: @(#) $Id: README,v 1.3 1999/04/16 00:47:22 stanton Exp $
+RCS: @(#) $Id: README,v 1.4 1999/04/20 18:12:18 hershey Exp $
Contents:
---------
@@ -117,6 +117,8 @@ namespace and automatically imported:
restoreState Restore the procedure and global variable names.
+ threadReap Kill all threads except for the main thread.
+
Please refer to the defs.tcl file for more documentation on these
procedures.
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
diff --git a/tests/socket.test b/tests/socket.test
index 249dc5e..8ca46ff 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: socket.test,v 1.7 1999/04/16 00:47:34 stanton Exp $
+# RCS: @(#) $Id: socket.test,v 1.8 1999/04/20 18:12:18 hershey Exp $
# Running socket tests with a remote server:
# ------------------------------------------
@@ -1579,26 +1579,10 @@ test socket-12.3 {testing inheritance of accepted sockets} \
test socket-13.1 {Testing use of shared socket between two threads} \
{socket testthread} {
- set mainthread [testthread names]
- proc ThreadReap {} {
- global mainthread
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != $mainthread} {
- catch {testthread send -async $tid {testthread exit}}
- update
- }
- }
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- }
-
removeFile script
+ threadReap
- set f [open script w]
- puts $f {
+ makeFile {
set f [socket -server accept 2828]
proc accept {s a p} {
fileevent $s readable [list echo $s]
@@ -1622,16 +1606,16 @@ test socket-13.1 {Testing use of shared socket between two threads} \
# thread cleans itself up.
testthread exit
- }
- close $f
+ } script
# create a thread
set serverthread [testthread create { source script } ]
update
-
+ after 1000
set s [socket 127.0.0.1 2828]
fconfigure $s -buffering line
+
catch {
puts $s "hello"
gets $s result
@@ -1640,11 +1624,11 @@ test socket-13.1 {Testing use of shared socket between two threads} \
update
after 2000
- ThreadReap
+ lappend result [threadReap]
set result
-} hello
+} {hello 1}
# cleanup
if {[string match sock* $commandSocket] == 1} {
diff --git a/tests/thread.test b/tests/thread.test
index b3051ed..0780e7a 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -10,62 +10,55 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: thread.test,v 1.2 1999/04/16 00:47:35 stanton Exp $
+# RCS: @(#) $Id: thread.test,v 1.3 1999/04/20 18:12:19 hershey Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
}
-if {[info command testthread] == ""} {
- puts "skipping: tests require the testthread command"
- ::tcltest::cleanupTests
- return
-}
+# Some tests require the testthread command
+
+set ::tcltest::testConfig(testthread) \
+ [expr {[info commands testthread] != {}}]
+
+if {$::tcltest::testConfig(testthread)} {
-set mainthread [testthread names]
-proc ThreadReap {} {
- global mainthread
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != $mainthread} {
- catch {testthread send -async $tid {testthread exit}}
- update
- }
- }
- }
testthread errorproc ThreadError
- return [llength [testthread names]]
-}
-testthread errorproc ThreadError
-proc ThreadError {id info} {
- global threadError
- set threadError $info
-}
-proc ThreadNullError {id info} {
- # ignore
+
+ proc ThreadError {id info} {
+ global threadError
+ set threadError $info
+ }
+
+ proc ThreadNullError {id info} {
+ # ignore
+ }
}
-test thread-1.1 {Tcl_ThreadObjCmd: no args} {
+
+test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
list [catch {testthread} msg] $msg
} {1 {wrong # args: should be "testthread option ?args?"}}
-test thread-1.2 {Tcl_ThreadObjCmd: bad option} {
+test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
list [catch {testthread foo} msg] $msg
} {1 {bad option "foo": must be create, exit, id, names, send, wait, or errorproc}}
-test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {
- list [catch {testthread names} mainthread] [llength $mainthread]
-} {0 1}
+test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
+ list [threadReap] [llength [testthread names]]
+} {1 1}
-test thread-1.4 {Tcl_ThreadObjCmd: thread create } {
+test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
+ threadReap
set serverthread [testthread create]
update
set numthreads [llength [testthread names]]
+ threadReap
+ set numthreads
} {2}
-ThreadReap
-test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {
+test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
+ threadReap
testthread create {set x 5}
foreach try {0 1 2 4 5 6} {
# Try various ways to yeild
@@ -76,72 +69,76 @@ test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {
break
}
}
+ threadReap
set l
} {1}
-ThreadReap
-test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {
+test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
+ threadReap
testthread create {testthread exit}
update
after 10
- llength [testthread names]
+ set result [llength [testthread names]]
+ threadReap
+ set result
} {1}
-ThreadReap
-test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {
+test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
set x [catch {testthread id x} msg]
list $x $msg
} {1 {wrong # args: should be "testthread id"}}
-test thread-1.8 {Tcl_ThreadObjCmd: thread id} {
- string compare [testthread id] $mainthread
+test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} {
+ string compare [testthread id] $::tcltest::mainThread
} {0}
-test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {
+test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
set x [catch {testthread names x} msg]
list $x $msg
} {1 {wrong # args: should be "testthread names"}}
-test thread-1.10 {Tcl_ThreadObjCmd: thread id} {
- string compare [testthread names] $mainthread
+test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} {
+ string compare [testthread names] $::tcltest::mainThread
} {0}
-test thread-1.11 {Tcl_ThreadObjCmd: send args} {
+test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
set x [catch {testthread send} msg]
list $x $msg
} {1 {wrong # args: should be "testthread send ?-async? id script"}}
-test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {
+test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
set x [catch {testthread send abc command} msg]
list $x $msg
} {1 {expected integer but got "abc"}}
-test thread-1.13 {Tcl_ThreadObjCmd: send args} {
+test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
+ threadReap
set serverthread [testthread create]
set five [testthread send $serverthread {set x 5}]
- ThreadReap
+ threadReap
set five
} 5
-test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {
- set tid [expr $mainthread + 10]
+test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
+ set tid [expr $::tcltest::mainThread + 10]
set x [catch {testthread send $tid {set x 5}} msg]
list $x $msg
} {1 {invalid thread id}}
-test thread-1.15 {Tcl_ThreadObjCmd: wait} {
+test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
+ threadReap
set serverthread [testthread create {set z 5 ; testthread wait}]
set five [testthread send $serverthread {set z}]
- ThreadReap
+ threadReap
set five
} 5
-test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {
+test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
set x [catch {testthread errorproc foo bar} msg]
list $x $msg
} {1 {wrong # args: should be "testthread errorproc proc"}}
-test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {
+test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
testthread errorproc foo
testthread errorproc ThreadError
} {}
@@ -151,30 +148,34 @@ test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {
# NewThread, safe and regular
# ThreadErrorProc, except for printing to standard error
-test thread-2.1 {ListUpdateInner and ListRemove} {
+test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
+ threadReap
catch {unset tid}
foreach t {0 1 2} {
upvar #0 t$t tid
set tid [testthread create]
}
- ThreadReap
+ threadReap
} 1
-test thread-3.1 {TclThreadList} {
+test thread-3.1 {TclThreadList} {testthread} {
+ threadReap
catch {unset tid}
- set mainthread [testthread names]
+ set len [llength [testthread names]]
set l1 {}
foreach t {0 1 2} {
lappend l1 [testthread create]
}
set l2 [testthread names]
list $l1 $l2
- set c [string compare [lsort -integer [concat $mainthread $l1]] [lsort -integer $l2]]
- ThreadReap
- set c
-} 0
-
-test thread-4.1 {TclThreadSend to self} {
+ set c [string compare \
+ [lsort -integer [concat $::tcltest::mainThread $l1]] \
+ [lsort -integer $l2]]
+ threadReap
+ list $len $c
+} {1 0}
+
+test thread-4.1 {TclThreadSend to self} {testthread} {
catch {unset x}
testthread send [testthread id] {
set x 4
@@ -182,8 +183,9 @@ test thread-4.1 {TclThreadSend to self} {
set x
} {4}
-test thread-4.1 {TclThreadSend -async} {
- set mainthread [testthread names]
+test thread-4.2 {TclThreadSend -async} {testthread} {
+ threadReap
+ set len [llength [testthread names]]
set serverthread [testthread create]
testthread send -async $serverthread {
after 1000
@@ -192,36 +194,40 @@ test thread-4.1 {TclThreadSend -async} {
set two [llength [testthread names]]
after 1500 {set done 1}
vwait done
- list [llength [testthread names]] $two
-} {1 2}
+ threadReap
+ list $len [llength [testthread names]] $two
+} {1 1 2}
-test thread-4.2 {TclThreadSend preserve errorInfo} {
- set mainthread [testthread names]
+test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
+ threadReap
+ set len [llength [testthread names]]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {set undef}} msg]
- list $x $msg $errorInfo
-} {1 {can't read "undef": no such variable} {can't read "undef": no such variable
+ threadReap
+ list $len $x $msg $errorInfo
+} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
while executing
"set undef"
invoked from within
"testthread send $serverthread {set undef}"}}
-ThreadReap
-test thread-4.3 {TclThreadSend preserve code} {
- set mainthread [testthread names]
+test thread-4.4 {TclThreadSend preserve code} {testthread} {
+ threadReap
+ set len [llength [testthread names]]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {break}} msg]
- list $x $msg $errorInfo
-} {3 {} {}}
-ThreadReap
+ threadReap
+ list $len $x $msg $errorInfo
+} {1 3 {} {}}
-test thread-4.4 {TclThreadSend preserve errorCode} {
- set mainthread [testthread names]
+test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
+ threadReap
+ set ::tcltest::mainThread [testthread names]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
+ threadReap
list $x $msg $errorCode
} {1 ERR CODE}
-ThreadReap
# cleanup
::tcltest::cleanupTests