diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:46:09 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:46:09 (GMT) |
commit | 768f87f613cc9789fcf8073018fa02178c8c91df (patch) | |
tree | ec633f5608ef498bee52a5f42c12c49493ec8bf8 /tcl8.6/tests/thread.test | |
parent | 07e464099b99459d0a37757771791598ef3395d9 (diff) | |
parent | 05fa4c89f20e9769db0e6c0b429cef2590771ace (diff) | |
download | blt-768f87f613cc9789fcf8073018fa02178c8c91df.zip blt-768f87f613cc9789fcf8073018fa02178c8c91df.tar.gz blt-768f87f613cc9789fcf8073018fa02178c8c91df.tar.bz2 |
Merge commit '05fa4c89f20e9769db0e6c0b429cef2590771ace' as 'tcl8.6'
Diffstat (limited to 'tcl8.6/tests/thread.test')
-rw-r--r-- | tcl8.6/tests/thread.test | 1443 |
1 files changed, 1443 insertions, 0 deletions
diff --git a/tcl8.6/tests/thread.test b/tcl8.6/tests/thread.test new file mode 100644 index 0000000..cc4c871 --- /dev/null +++ b/tcl8.6/tests/thread.test @@ -0,0 +1,1443 @@ +# Commands covered: (test)thread +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2.2 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +# Some tests require the testthread command + +testConstraint testthread [expr {[info commands testthread] != {}}] + +# Some tests require the Thread package + +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] + +# Some tests may not work under valgrind + +testConstraint notValgrind [expr {![testConstraint valgrind]}] + +set threadSuperKillScript { + rename catch "" + rename while "" + rename unknown "" + rename update "" + thread::release +} + +proc getThreadErrorFromInfo { info } { + set list [split $info \n] + set idx [lsearch -glob $list "*eval*unwound*"] + if {$idx != -1} then { + return [lindex $list $idx] + } + set idx [lsearch -glob $list "*eval*canceled*"] + if {$idx != -1} then { + return [lindex $list $idx] + } + return ""; # some other error we do not care about. +} + +proc findThreadError { info } { + foreach error [lreverse $info] { + set error [getThreadErrorFromInfo $error] + if {[string length $error] > 0} then { + return $error + } + } + return ""; # some other error we do not care about. +} + +proc ThreadError {id info} { + global threadSawError + if {[string length [getThreadErrorFromInfo $info]] > 0} then { + global threadId threadError + set threadId $id + lappend threadError($id) $info + } + set threadSawError($id) true; # signal main thread to exit [vwait]. +} + +if {[testConstraint thread]} { + thread::errorproc ThreadError +} + +if {[testConstraint testthread]} { + proc drainEventQueue {} { + while {[set x [testthread event]]} { + #puts "WARNING: drained $x event(s) on main thread" + } + } + + testthread errorproc ThreadError +} + +# Some tests require manual draining of the event queue + +testConstraint drainEventQueue [expr {[info commands drainEventQueue] != {}}] + +test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { + llength [thread::names] +} 1 +test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { + set serverthread [thread::create -preserved] + set numthreads [llength [thread::names]] + thread::release $serverthread + set numthreads +} {2} +test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { + thread::create {set x 5} + foreach try {0 1 2 4 5 6} { + # Try various ways to yield + update + after 10 + set l [llength [thread::names]] + if {$l == 1} { + break + } + } + set l +} {1} +test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { + thread::create {{*}{}} + update + after 10 + llength [thread::names] +} {1} +test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { + set serverthread [thread::create -preserved] + set five [thread::send $serverthread {set x 5}] + thread::release $serverthread + set five +} 5 +test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { + set serverthread [thread::create -preserved {set z 5 ; thread::wait}] + set five [thread::send $serverthread {set z}] + thread::release $serverthread + set five +} 5 + +# The tests above also cover: +# TclCreateThread, except when pthread_create fails +# NewThread, safe and regular +# ThreadErrorProc, except for printing to standard error + +test thread-2.1 {ListUpdateInner and ListRemove} {thread} { + catch {unset tid} + foreach t {0 1 2} { + upvar #0 t$t tid + set tid [thread::create -preserved] + } + foreach t {0 1 2} { + upvar #0 t$t tid + thread::release $tid + } + llength [thread::names] +} 1 + +test thread-3.1 {TclThreadList} {thread} { + catch {unset tid} + set len [llength [thread::names]] + set l1 {} + foreach t {0 1 2} { + lappend l1 [thread::create -preserved] + } + set l2 [thread::names] + set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] + foreach t $l1 { + thread::release $t + } + list $len $c +} {1 0} + +test thread-4.1 {TclThreadSend to self} {thread} { + catch {unset x} + thread::send [thread::id] { + set x 4 + } + set x +} {4} +test thread-4.2 {TclThreadSend -async} {thread} { + set len [llength [thread::names]] + set serverthread [thread::create -preserved] + thread::send -async $serverthread { + after 1 {thread::release} + } + set two [llength [thread::names]] + after 100 {set done 1} + vwait done + list $len [llength [thread::names]] $two +} {1 1 2} +test thread-4.3 {TclThreadSend preserve errorInfo} {thread} { + set len [llength [thread::names]] + set serverthread [thread::create -preserved] + set x [catch {thread::send $serverthread {set undef}} msg] + set savedErrorInfo $::errorInfo + thread::release $serverthread + list $len $x $msg $savedErrorInfo +} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable + while executing +"set undef" + invoked from within +"thread::send $serverthread {set undef}"}} +test thread-4.4 {TclThreadSend preserve code} {thread} { + set len [llength [thread::names]] + set serverthread [thread::create -preserved] + set ::errorInfo {} + set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg] + set savedErrorInfo $::errorInfo + thread::release $serverthread + list $len $x $msg $savedErrorInfo +} {1 3 {} {}} +test thread-4.5 {TclThreadSend preserve errorCode} {thread} { + set serverthread [thread::create] + set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg] + set savedErrorCode $::errorCode + thread::release $serverthread + list $x $msg $savedErrorCode +} {1 ERR CODE} + + +test thread-5.0 {Joining threads} {thread} { + set serverthread [thread::create -joinable -preserved] + thread::send -async $serverthread {after 1000 ; thread::release} + thread::join $serverthread +} {0} +test thread-5.1 {Joining threads after the fact} {thread} { + set serverthread [thread::create -joinable -preserved] + thread::send -async $serverthread {thread::release} + after 2000 + thread::join $serverthread +} {0} +test thread-5.2 {Try to join a detached thread} {thread} { + set serverthread [thread::create -preserved] + thread::send -async $serverthread {after 1000 ; thread::release} + catch {set res [thread::join $serverthread]} msg + while {[llength [thread::names]] > 1} { + after 20 + } + lrange $msg 0 2 +} {cannot join thread} + +test thread-6.1 {freeing very large object trees in a thread} thread { + # conceptual duplicate of obj-32.1 + set serverthread [thread::create -preserved] + thread::send -async $serverthread { + set x {} + for {set i 0} {$i<100000} {incr i} { + set x [list $x {}] + } + unset x + } + thread::release -wait $serverthread +} 0 + +# TIP #285: Script cancellation support +test thread-7.4 {cancel: pure bytecode loop} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + set while while + $while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + set while while + $while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread "the eval was canceled"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was canceled}} +test thread-7.9 {cancel: pure inside-command loop custom result} -constraints { + thread + drainEventQueue +} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + set while while + $while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread "the eval was canceled"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was canceled}} +test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints { + thread + drainEventQueue +} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread "the eval was unwound"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was unwound}} +test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints { + thread + drainEventQueue +} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + set while while + $while {1} { + # No bytecode at all here... + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread "the eval was unwound"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was unwound}} +test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + after 30000 + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + after 30000 + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + vwait forever + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + vwait forever + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + expr {[while {1} {incr x}]} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + expr {[while {1} {incr x}]} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + # + # BUGBUG: This will not cancel because libtommath + # does not check Tcl_Canceled. + # + expr {2**99999} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread); # WARNING: Never returns (see above). + thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above). + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 0 {}} +test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + # + # BUGBUG: This will not cancel because libtommath + # does not check Tcl_Canceled. + # + expr {2**99999} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread); # WARNING: Never returns (see above). + thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above). + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 0 {}} +test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + subst {[while {1} {incr x}]} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + subst {[while {1} {incr x}]} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + while {1} {} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + set while while; $while {1} {} + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + catch { + while {1} { + catch { + while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::cancel $serverthread] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 0 {}} +test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + set catch catch + set while while + $while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + $catch { + $while {1} { + $catch { + $while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::cancel $serverthread] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 0 {}} +test thread-7.26 {cancel: send async cancel bad interp path} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + update + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + catch {thread::send $serverthread {interp cancel -- bad}} msg + thread::send -async $serverthread {interp cancel -unwind} + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list [expr {$::threadIdStarted == $serverthread}] $msg +} {1 {could not find interpreter "bad"}} +test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create -- -unwind] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + update + } + } + foobar + } + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -- -unwind}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + catch { + while {1} { + catch { + while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::send -async $serverthread {interp cancel}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + set catch catch + set while while + $while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + $catch { + $while {1} { + $catch { + $while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::send -async $serverthread {interp cancel}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + catch { + while {1} { + catch { + while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::send -async $serverthread {thread::cancel [thread::id]}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + set catch catch + set while while + $while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + $catch { + $while {1} { + $catch { + $while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted; after 1000 + set res [thread::send -async $serverthread {thread::cancel [thread::id]}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {[info exists ::threadIdStarted] ? \ + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + catch { + while {1} { + catch { + while {1} { + # No bytecode at all here... + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + set catch catch + set while while + $while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + $catch { + $while {1} { + $catch { + $while {1} { + # No bytecode at all here... + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + catch { + while {1} { + catch { + while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -unwind}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + set catch catch + set while while + $while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + $catch { + $while {1} { + $catch { + $while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -unwind}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + catch { + while {1} { + catch { + while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { + set catch catch + set while while + $while {1} { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + $catch { + $while {1} { + $catch { + $while {1} { + # we must call update here because otherwise + # the thread cannot even be forced to exit. + update + } + } + } + } + } + } + foobar + }]] + # wait for other thread to signal "ready to cancel" + vwait ::threadIdStarted + set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} + +test thread-8.1 {threaded fork stress} -constraints {thread} -setup { + unset -nocomplain ::threadCount ::execCount ::threads ::thread + set ::threadCount 10 + set ::execCount 10 +} -body { + set ::threads [list] + for {set i 0} {$i < $::threadCount} {incr i} { + lappend ::threads [thread::create -joinable [string map \ + [list %execCount% $::execCount] { + proc execLs {} { + if {$::tcl_platform(platform) eq "windows"} then { + return [exec $::env(COMSPEC) /c DIR] + } else { + return [exec /bin/ls] + } + } + set j {%execCount%}; while {[incr j -1]} {execLs} + }]] + } + foreach ::thread $::threads { + thread::join $::thread + } +} -cleanup { + unset -nocomplain ::threadCount ::execCount ::threads ::thread +} -result {} + +# cleanup +::tcltest::cleanupTests +return |