diff options
| -rw-r--r-- | tests/README | 4 | ||||
| -rw-r--r-- | tests/defs.tcl | 95 | ||||
| -rw-r--r-- | tests/socket.test | 32 | ||||
| -rw-r--r-- | tests/thread.test | 170 |
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 |