summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-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