summaryrefslogtreecommitdiffstats
path: root/tests/thread.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/thread.test')
-rw-r--r--tests/thread.test1479
1 files changed, 1328 insertions, 151 deletions
diff --git a/tests/thread.test b/tests/thread.test
index bfef91c..44789fa 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -6,12 +6,13 @@
#
# 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
+ package require tcltest 2.2
namespace import -force ::tcltest::*
}
@@ -19,240 +20,1416 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
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
- proc ThreadError {id info} {
- global threadError
- set threadError $info
- }
+ 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]]
+ }
}
+# Some tests require manual draining of the event queue
-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} {testthread} {
- list [catch {testthread foo} msg] $msg
-} {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
-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 } {testthread} {
- threadReap
- set serverthread [testthread create]
- update
- set numthreads [llength [testthread names]]
- threadReap
+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} {testthread} {
- threadReap
- testthread create {set x 5}
+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 [testthread names]]
+ set l [llength [thread::names]]
if {$l == 1} {
break
}
}
- threadReap
set l
} {1}
-test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
- threadReap
- testthread create {testthread exit}
+test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
+ thread::create {{*}{}}
update
after 10
- set result [llength [testthread names]]
- threadReap
- set result
+ llength [thread::names]
} {1}
-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} {testthread} {
- string compare [testthread id] $::tcltest::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
-} {0}
-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} {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} {testthread} {
- threadReap
- set serverthread [testthread create]
- set five [testthread send $serverthread {set x 5}]
- threadReap
+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.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} {testthread} {
- threadReap
- set serverthread [testthread create {set z 5 ; testthread wait}]
- set five [testthread send $serverthread {set z}]
- threadReap
+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
-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} {testthread} {
- testthread errorproc foo
- testthread errorproc ThreadError
-} {}
# 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} {testthread} {
- threadReap
+test thread-2.1 {ListUpdateInner and ListRemove} {thread} {
catch {unset tid}
foreach t {0 1 2} {
upvar #0 t$t tid
- set tid [testthread create]
+ set tid [thread::create -preserved]
}
- threadReap
+ foreach t {0 1 2} {
+ upvar #0 t$t tid
+ thread::release $tid
+ }
+ llength [thread::names]
} 1
-test thread-3.1 {TclThreadList} {testthread} {
- threadReap
+test thread-3.1 {TclThreadList} {thread} {
catch {unset tid}
- set len [llength [testthread names]]
+ set len [llength [thread::names]]
set l1 {}
foreach t {0 1 2} {
- lappend l1 [testthread create]
+ 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
}
- set l2 [testthread names]
- list $l1 $l2
- 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} {
+test thread-4.1 {TclThreadSend to self} {thread} {
catch {unset x}
- testthread send [testthread id] {
+ thread::send [thread::id] {
set x 4
}
set x
} {4}
-test thread-4.2 {TclThreadSend -async} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
- testthread send -async $serverthread {
- after 1000
- testthread exit
+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 [testthread names]]
- after 1500 {set done 1}
+ set two [llength [thread::names]]
+ after 100 {set done 1}
vwait done
- threadReap
- list $len [llength [testthread names]] $two
+ list $len [llength [thread::names]] $two
} {1 1 2}
-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]
+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
- threadReap
+ 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
-"testthread send $serverthread {set undef}"}}
-test thread-4.4 {TclThreadSend preserve code} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
+"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 {testthread send $serverthread {set ::errorInfo {}; break}} msg]
+ set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg]
set savedErrorInfo $::errorInfo
- threadReap
+ thread::release $serverthread
list $len $x $msg $savedErrorInfo
} {1 3 {} {}}
-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]
+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
- threadReap
+ thread::release $serverthread
list $x $msg $savedErrorCode
} {1 ERR CODE}
-test thread-5.0 {Joining threads} {testthread} {
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {after 1000 ; testthread exit}
- set res [testthread join $serverthread]
- threadReap
- set res
+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} {testthread} {
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {testthread exit}
+test thread-5.1 {Joining threads after the fact} {thread} {
+ set serverthread [thread::create -joinable -preserved]
+ thread::send -async $serverthread {thread::release}
after 2000
- set res [testthread join $serverthread]
- threadReap
- set res
+ thread::join $serverthread
} {0}
-test thread-5.2 {Try to join a detached thread} {testthread} {
- threadReap
- set serverthread [testthread create]
- testthread send -async $serverthread {after 1000 ; testthread exit}
- catch {set res [testthread join $serverthread]} msg
- threadReap
+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} testthread {
+test thread-6.1 {freeing very large object trees in a thread} thread {
# conceptual duplicate of obj-32.1
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {
+ 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
- testthread exit
}
- catch {set res [testthread join $serverthread]} msg
- threadReap
- set res
-} {0}
+ 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}}
# cleanup
::tcltest::cleanupTests