diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | tests/thread.test | 40 |
2 files changed, 35 insertions, 11 deletions
@@ -1,3 +1,9 @@ +2011-09-23 Don Porter <dgp@users.sourceforge.net> + + * tests/thread.test: Stop using the deprecated thread management + commands of the tcltest package. The test suite ought to provide + these tools for itself. They do not belong in a testing harness. + 2011-09-22 Don Porter <dgp@users.sourceforge.net> * generic/tclCmdIL.c: Revise [info frame] so that it stops creating diff --git a/tests/thread.test b/tests/thread.test index 732f5fd..74f7043 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -23,23 +23,41 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] -if {[testConstraint testthread]} { - testthread errorproc ThreadError +proc ThreadError {id info} { + global threadId threadError + set threadId $id + set threadError $info } + if {[testConstraint thread]} { thread::errorproc ThreadError } - proc ThreadError {id info} { - global threadId threadError - set threadId $id - set threadError $info - } +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + set mainThread [testthread id] proc ThreadNullError {id info} { # ignore } + proc threadReap {} { + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != [testthread id]} { + catch { + testthread send -async $tid {testthread exit} + } + } + } + after 1 + } + testthread errorproc ThreadError + return [llength [testthread names]] + } +} test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} { list [catch {testthread} msg] $msg @@ -80,14 +98,14 @@ test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} { list $x $msg } {1 {wrong # args: should be "testthread id"}} test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread id] $::tcltest::mainThread + string compare [testthread id] $mainThread } {0} 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} {testthread} { - string compare [testthread names] $::tcltest::mainThread + string compare [testthread names] $mainThread } {0} test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} { set x [catch {testthread send} msg] @@ -104,7 +122,7 @@ test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set five } 5 test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] + set tid [expr $mainThread + 10] set x [catch {testthread send $tid {set x 5}} msg] list $x $msg } {1 {invalid thread id}} @@ -248,7 +266,7 @@ test thread-7.2 {cancel: nonint} {testthread} { list $x $msg } {1 {expected integer but got "abc"}} test thread-7.3 {cancel: bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] + set tid [expr $mainThread + 10] set x [catch {testthread cancel $tid} msg] list $x $msg } {1 {invalid thread id}} |