diff options
Diffstat (limited to 'tests/thread.test')
| -rw-r--r-- | tests/thread.test | 170 |
1 files changed, 88 insertions, 82 deletions
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 |