1# Commands covered: (test)thread 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1996 Sun Microsystems, Inc. 8# Copyright © 1998-1999 Scriptics Corporation. 9# Copyright © 2006-2008 Joe Mistachkin. All rights reserved. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19# when thread::release is used, -wait is passed in order allow the thread to 20# be fully finalized, which avoids valgrind "still reachable" reports. 21 22::tcltest::loadTestedCommands 23catch [list package require -exact tcl::test [info patchlevel]] 24package require tcltests 25 26# Some tests require the testthread command 27 28testConstraint testthread [expr {[info commands testthread] ne {}}] 29 30 31set threadSuperKillScript { 32 rename catch "" 33 rename while "" 34 rename unknown "" 35 rename update "" 36 thread::release 37} 38 39proc getThreadErrorFromInfo { info } { 40 set list [split $info \n] 41 set idx [lsearch -glob $list "*eval*unwound*"] 42 if {$idx >= 0} then { 43 return [lindex $list $idx] 44 } 45 set idx [lsearch -glob $list "*eval*canceled*"] 46 if {$idx >= 0} then { 47 return [lindex $list $idx] 48 } 49 return ""; # some other error we do not care about. 50} 51 52proc findThreadError { info } { 53 foreach error [lreverse $info] { 54 set error [getThreadErrorFromInfo $error] 55 if {[string length $error] > 0} then { 56 return $error 57 } 58 } 59 return ""; # some other error we do not care about. 60} 61 62proc ThreadError {id info} { 63 global threadSawError 64 if {[string length [getThreadErrorFromInfo $info]] > 0} then { 65 global threadId threadError 66 set threadId $id 67 lappend threadError($id) $info 68 } 69 set threadSawError($id) true; # signal main thread to exit [vwait]. 70} 71 72proc threadSuperKill id { 73 variable threadSuperKillScript 74 try { 75 thread::send $id $::threadSuperKillScript 76 } on error {tres topts} { 77 if {$tres ne {target thread died}} { 78 return -options $topts $tres 79 } 80 } 81} 82 83if {[testConstraint thread]} { 84 thread::errorproc ThreadError 85} 86 87if {[testConstraint testthread]} { 88 proc drainEventQueue {} { 89 while {[set x [testthread event]]} { 90 #puts "WARNING: drained $x event(s) on main thread" 91 } 92 } 93 94 testthread errorproc ThreadError 95} 96 97# Some tests require manual draining of the event queue 98 99testConstraint drainEventQueue [expr {[info commands drainEventQueue] != {}}] 100 101test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { 102 llength [thread::names] 103} 1 104test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { 105 set serverthread [thread::create -preserved] 106 set numthreads [llength [thread::names]] 107 thread::release -wait $serverthread 108 set numthreads 109} 2 110test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { 111 thread::create {set x 5} 112 foreach try {0 1 2 4 5 6} { 113 # Try various ways to yield 114 update 115 after 10 116 set l [llength [thread::names]] 117 if {$l == 1} { 118 break 119 } 120 } 121 set l 122} 1 123test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { 124 thread::create {{*}{}} 125 update 126 after 10 127 llength [thread::names] 128} {1} 129test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { 130 set serverthread [thread::create -preserved] 131 set five [thread::send $serverthread {set x 5}] 132 thread::release -wait $serverthread 133 set five 134} 5 135test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { 136 set serverthread [thread::create -preserved {set z 5 ; thread::wait}] 137 set five [thread::send $serverthread {set z}] 138 thread::release -wait $serverthread 139 set five 140} 5 141 142# The tests above also cover: 143# TclCreateThread, except when pthread_create fails 144# NewThread, safe and regular 145# ThreadErrorProc, except for printing to standard error 146 147test thread-2.1 {ListUpdateInner and ListRemove} {thread} { 148 catch {unset tid} 149 foreach t {0 1 2} { 150 upvar #0 t$t tid 151 set tid [thread::create -preserved] 152 } 153 foreach t {0 1 2} { 154 upvar #0 t$t tid 155 thread::release $tid 156 } 157 llength [thread::names] 158} 1 159 160test thread-3.1 {TclThreadList} {thread} { 161 catch {unset tid} 162 set len [llength [thread::names]] 163 set l1 {} 164 foreach t {0 1 2} { 165 lappend l1 [thread::create -preserved] 166 } 167 set l2 [thread::names] 168 set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] 169 foreach t $l1 { 170 thread::release -wait $t 171 } 172 list $len $c 173} {1 0} 174 175test thread-4.1 {TclThreadSend to self} {thread} { 176 catch {unset x} 177 thread::send [thread::id] { 178 set x 4 179 } 180 set x 181} {4} 182test thread-4.2 {TclThreadSend -async} {thread} { 183 set len [llength [thread::names]] 184 set serverthread [thread::create -preserved] 185 thread::send -async $serverthread { 186 after 1 {thread::release} 187 } 188 set two [llength [thread::names]] 189 after 100 {set done 1} 190 vwait done 191 list $len [llength [thread::names]] $two 192} {1 1 2} 193test thread-4.3 {TclThreadSend preserve errorInfo} {thread} { 194 set len [llength [thread::names]] 195 set serverthread [thread::create -preserved] 196 set x [catch {thread::send $serverthread {set undef}} msg] 197 set savedErrorInfo $::errorInfo 198 thread::release $serverthread 199 list $len $x $msg $savedErrorInfo 200} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable 201 while executing 202"set undef" 203 invoked from within 204"thread::send $serverthread {set undef}"}} 205test thread-4.4 {TclThreadSend preserve code} {thread} { 206 set len [llength [thread::names]] 207 set serverthread [thread::create -preserved] 208 set ::errorInfo {} 209 set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg] 210 set savedErrorInfo $::errorInfo 211 thread::release $serverthread 212 list $len $x $msg $savedErrorInfo 213} {1 3 {} {}} 214test thread-4.5 {TclThreadSend preserve errorCode} {thread} { 215 set serverthread [thread::create] 216 set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg] 217 set savedErrorCode $::errorCode 218 thread::release $serverthread 219 list $x $msg $savedErrorCode 220} {1 ERR CODE} 221 222 223test thread-5.0 {Joining threads} {thread} { 224 set serverthread [thread::create -joinable -preserved] 225 thread::send -async $serverthread {after 1000 ; thread::release} 226 thread::join $serverthread 227} {0} 228test thread-5.1 {Joining threads after the fact} {thread} { 229 set serverthread [thread::create -joinable -preserved] 230 thread::send -async $serverthread {thread::release} 231 after 2000 232 thread::join $serverthread 233} {0} 234test thread-5.2 {Try to join a detached thread} {thread} { 235 set serverthread [thread::create -preserved] 236 thread::send -async $serverthread {after 1000 ; thread::release} 237 catch {set res [thread::join $serverthread]} msg 238 while {[llength [thread::names]] > 1} { 239 after 20 240 } 241 lrange $msg 0 2 242} {cannot join thread} 243 244test thread-6.1 {freeing very large object trees in a thread} thread { 245 # conceptual duplicate of obj-32.1 246 set serverthread [thread::create -preserved] 247 thread::send -async $serverthread { 248 set x {} 249 for {set i 0} {$i<100000} {incr i} { 250 set x [list $x {}] 251 } 252 unset x 253 } 254 thread::release -wait $serverthread 255} 0 256 257# TIP #285: Script cancellation support 258test thread-7.4 {cancel: pure bytecode loop} -constraints {thread drainEventQueue} -setup { 259 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 260} -body { 261 set serverthread [thread::create -joinable \ 262 [string map [list %ID% [thread::id]] { 263 proc foobar {} { 264 if {![info exists foo]} then { 265 # signal the primary thread that we are ready 266 # to be canceled now (we are running). 267 thread::send %ID% [list set ::threadIdStarted [thread::id]] 268 set foo 1 269 } 270 while {1} { 271 # No bytecode at all here... 272 } 273 } 274 foobar 275 }]] 276 # wait for other thread to signal "ready to cancel" 277 vwait ::threadIdStarted 278 set res [thread::cancel $serverthread] 279 vwait ::threadSawError($serverthread) 280 thread::join $serverthread; drainEventQueue 281 list $res [expr {$::threadIdStarted == $serverthread}] \ 282 [expr {[info exists ::threadId] ? \ 283 $::threadId == $serverthread : 0}] \ 284 [expr {[info exists ::threadError($serverthread)] ? \ 285 [findThreadError $::threadError($serverthread)] : ""}] 286} -cleanup { 287 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 288} -result {{} 1 1 {eval canceled}} 289test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEventQueue} -setup { 290 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 291} -body { 292 set serverthread [thread::create -joinable \ 293 [string map [list %ID% [thread::id]] { 294 proc foobar {} { 295 if {![info exists foo]} then { 296 # signal the primary thread that we are ready 297 # to be canceled now (we are running). 298 thread::send %ID% [list set ::threadIdStarted [thread::id]] 299 set foo 1 300 } 301 set while while 302 $while {1} { 303 # No bytecode at all here... 304 } 305 } 306 foobar 307 }]] 308 # wait for other thread to signal "ready to cancel" 309 vwait ::threadIdStarted 310 set res [thread::cancel $serverthread] 311 vwait ::threadSawError($serverthread) 312 thread::join $serverthread; drainEventQueue 313 list $res [expr {$::threadIdStarted == $serverthread}] \ 314 [expr {[info exists ::threadId] ? \ 315 $::threadId == $serverthread : 0}] \ 316 [expr {[info exists ::threadError($serverthread)] ? \ 317 [findThreadError $::threadError($serverthread)] : ""}] 318} -cleanup { 319 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 320} -result {{} 1 1 {eval canceled}} 321test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { 322 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 323} -body { 324 set serverthread [thread::create -joinable \ 325 [string map [list %ID% [thread::id]] { 326 proc foobar {} { 327 if {![info exists foo]} then { 328 # signal the primary thread that we are ready 329 # to be canceled now (we are running). 330 thread::send %ID% [list set ::threadIdStarted [thread::id]] 331 set foo 1 332 } 333 while {1} { 334 # No bytecode at all here... 335 } 336 } 337 foobar 338 }]] 339 # wait for other thread to signal "ready to cancel" 340 vwait ::threadIdStarted 341 set res [thread::cancel -unwind $serverthread] 342 vwait ::threadSawError($serverthread) 343 thread::join $serverthread; drainEventQueue 344 list $res [expr {$::threadIdStarted == $serverthread}] \ 345 [expr {[info exists ::threadId] ? \ 346 $::threadId == $serverthread : 0}] \ 347 [expr {[info exists ::threadError($serverthread)] ? \ 348 [findThreadError $::threadError($serverthread)] : ""}] 349} -cleanup { 350 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 351} -result {{} 1 1 {eval unwound}} 352test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { 353 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 354} -body { 355 set serverthread [thread::create -joinable \ 356 [string map [list %ID% [thread::id]] { 357 proc foobar {} { 358 if {![info exists foo]} then { 359 # signal the primary thread that we are ready 360 # to be canceled now (we are running). 361 thread::send %ID% [list set ::threadIdStarted [thread::id]] 362 set foo 1 363 } 364 set while while 365 $while {1} { 366 # No bytecode at all here... 367 } 368 } 369 foobar 370 }]] 371 # wait for other thread to signal "ready to cancel" 372 vwait ::threadIdStarted 373 set res [thread::cancel -unwind $serverthread] 374 vwait ::threadSawError($serverthread) 375 thread::join $serverthread; drainEventQueue 376 list $res [expr {$::threadIdStarted == $serverthread}] \ 377 [expr {[info exists ::threadId] ? \ 378 $::threadId == $serverthread : 0}] \ 379 [expr {[info exists ::threadError($serverthread)] ? \ 380 [findThreadError $::threadError($serverthread)] : ""}] 381} -cleanup { 382 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 383} -result {{} 1 1 {eval unwound}} 384test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread drainEventQueue} -setup { 385 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 386} -body { 387 set serverthread [thread::create -joinable \ 388 [string map [list %ID% [thread::id]] { 389 proc foobar {} { 390 if {![info exists foo]} then { 391 # signal the primary thread that we are ready 392 # to be canceled now (we are running). 393 thread::send %ID% [list set ::threadIdStarted [thread::id]] 394 set foo 1 395 } 396 while {1} { 397 # No bytecode at all here... 398 } 399 } 400 foobar 401 }]] 402 # wait for other thread to signal "ready to cancel" 403 vwait ::threadIdStarted 404 set res [thread::cancel $serverthread "the eval was canceled"] 405 vwait ::threadSawError($serverthread) 406 thread::join $serverthread; drainEventQueue 407 list $res [expr {$::threadIdStarted == $serverthread}] \ 408 [expr {[info exists ::threadId] ? \ 409 $::threadId == $serverthread : 0}] \ 410 [expr {[info exists ::threadError($serverthread)] ? \ 411 [findThreadError $::threadError($serverthread)] : ""}] 412} -cleanup { 413 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 414} -result {{} 1 1 {the eval was canceled}} 415test thread-7.9 {cancel: pure inside-command loop custom result} -constraints { 416 thread 417 drainEventQueue 418} -setup { 419 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 420} -body { 421 set serverthread [thread::create -joinable \ 422 [string map [list %ID% [thread::id]] { 423 proc foobar {} { 424 if {![info exists foo]} then { 425 # signal the primary thread that we are ready 426 # to be canceled now (we are running). 427 thread::send %ID% [list set ::threadIdStarted [thread::id]] 428 set foo 1 429 } 430 set while while 431 $while {1} { 432 # No bytecode at all here... 433 } 434 } 435 foobar 436 }]] 437 # wait for other thread to signal "ready to cancel" 438 vwait ::threadIdStarted 439 set res [thread::cancel $serverthread "the eval was canceled"] 440 vwait ::threadSawError($serverthread) 441 thread::join $serverthread; drainEventQueue 442 list $res [expr {$::threadIdStarted == $serverthread}] \ 443 [expr {[info exists ::threadId] ? \ 444 $::threadId == $serverthread : 0}] \ 445 [expr {[info exists ::threadError($serverthread)] ? \ 446 [findThreadError $::threadError($serverthread)] : ""}] 447} -cleanup { 448 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 449} -result {{} 1 1 {the eval was canceled}} 450test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints { 451 thread 452 drainEventQueue 453} -setup { 454 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 455} -body { 456 set serverthread [thread::create -joinable \ 457 [string map [list %ID% [thread::id]] { 458 proc foobar {} { 459 if {![info exists foo]} then { 460 # signal the primary thread that we are ready 461 # to be canceled now (we are running). 462 thread::send %ID% [list set ::threadIdStarted [thread::id]] 463 set foo 1 464 } 465 while {1} { 466 # No bytecode at all here... 467 } 468 } 469 foobar 470 }]] 471 # wait for other thread to signal "ready to cancel" 472 vwait ::threadIdStarted 473 set res [thread::cancel -unwind $serverthread "the eval was unwound"] 474 vwait ::threadSawError($serverthread) 475 thread::join $serverthread; drainEventQueue 476 list $res [expr {$::threadIdStarted == $serverthread}] \ 477 [expr {[info exists ::threadId] ? \ 478 $::threadId == $serverthread : 0}] \ 479 [expr {[info exists ::threadError($serverthread)] ? \ 480 [findThreadError $::threadError($serverthread)] : ""}] 481} -cleanup { 482 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 483} -result {{} 1 1 {the eval was unwound}} 484test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints { 485 thread 486 drainEventQueue 487} -setup { 488 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 489} -body { 490 set serverthread [thread::create -joinable \ 491 [string map [list %ID% [thread::id]] { 492 proc foobar {} { 493 if {![info exists foo]} then { 494 # signal the primary thread that we are ready 495 # to be canceled now (we are running). 496 thread::send %ID% [list set ::threadIdStarted [thread::id]] 497 set foo 1 498 } 499 set while while 500 $while {1} { 501 # No bytecode at all here... 502 } 503 } 504 foobar 505 }]] 506 # wait for other thread to signal "ready to cancel" 507 vwait ::threadIdStarted 508 set res [thread::cancel -unwind $serverthread "the eval was unwound"] 509 vwait ::threadSawError($serverthread) 510 thread::join $serverthread; drainEventQueue 511 list $res [expr {$::threadIdStarted == $serverthread}] \ 512 [expr {[info exists ::threadId] ? \ 513 $::threadId == $serverthread : 0}] \ 514 [expr {[info exists ::threadError($serverthread)] ? \ 515 [findThreadError $::threadError($serverthread)] : ""}] 516} -cleanup { 517 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 518} -result {{} 1 1 {the eval was unwound}} 519test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup { 520 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 521} -body { 522 set serverthread [thread::create -joinable \ 523 [string map [list %ID% [thread::id]] { 524 if {![info exists foo]} then { 525 # signal the primary thread that we are ready 526 # to be canceled now (we are running). 527 thread::send %ID% [list set ::threadIdStarted [thread::id]] 528 set foo 1 529 } 530 after 30000 531 }]] 532 # wait for other thread to signal "ready to cancel" 533 vwait ::threadIdStarted 534 set res [thread::cancel $serverthread] 535 vwait ::threadSawError($serverthread) 536 thread::join $serverthread; drainEventQueue 537 list $res [expr {$::threadIdStarted == $serverthread}] \ 538 [expr {[info exists ::threadId] ? \ 539 $::threadId == $serverthread : 0}] \ 540 [expr {[info exists ::threadError($serverthread)] ? \ 541 [findThreadError $::threadError($serverthread)] : ""}] 542} -cleanup { 543 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 544} -result {{} 1 1 {eval canceled}} 545test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -setup { 546 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 547} -body { 548 set serverthread [thread::create -joinable \ 549 [string map [list %ID% [thread::id]] { 550 if {![info exists foo]} then { 551 # signal the primary thread that we are ready 552 # to be canceled now (we are running). 553 thread::send %ID% [list set ::threadIdStarted [thread::id]] 554 set foo 1 555 } 556 after 30000 557 }]] 558 # wait for other thread to signal "ready to cancel" 559 vwait ::threadIdStarted 560 set res [thread::cancel -unwind $serverthread] 561 vwait ::threadSawError($serverthread) 562 thread::join $serverthread; drainEventQueue 563 list $res [expr {$::threadIdStarted == $serverthread}] \ 564 [expr {[info exists ::threadId] ? \ 565 $::threadId == $serverthread : 0}] \ 566 [expr {[info exists ::threadError($serverthread)] ? \ 567 [findThreadError $::threadError($serverthread)] : ""}] 568} -cleanup { 569 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 570} -result {{} 1 1 {eval unwound}} 571test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup { 572 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 573} -body { 574 set serverthread [thread::create -joinable \ 575 [string map [list %ID% [thread::id]] { 576 if {![info exists foo]} then { 577 # signal the primary thread that we are ready 578 # to be canceled now (we are running). 579 thread::send %ID% [list set ::threadIdStarted [thread::id]] 580 set foo 1 581 } 582 vwait forever 583 }]] 584 # wait for other thread to signal "ready to cancel" 585 vwait ::threadIdStarted 586 set res [thread::cancel $serverthread] 587 vwait ::threadSawError($serverthread) 588 thread::join $serverthread; drainEventQueue 589 list $res [expr {$::threadIdStarted == $serverthread}] \ 590 [expr {[info exists ::threadId] ? \ 591 $::threadId == $serverthread : 0}] \ 592 [expr {[info exists ::threadError($serverthread)] ? \ 593 [findThreadError $::threadError($serverthread)] : ""}] 594} -cleanup { 595 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 596} -result {{} 1 1 {eval canceled}} 597test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -setup { 598 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 599} -body { 600 set serverthread [thread::create -joinable \ 601 [string map [list %ID% [thread::id]] { 602 if {![info exists foo]} then { 603 # signal the primary thread that we are ready 604 # to be canceled now (we are running). 605 thread::send %ID% [list set ::threadIdStarted [thread::id]] 606 set foo 1 607 } 608 vwait forever 609 }]] 610 # wait for other thread to signal "ready to cancel" 611 vwait ::threadIdStarted 612 set res [thread::cancel -unwind $serverthread] 613 vwait ::threadSawError($serverthread) 614 thread::join $serverthread; drainEventQueue 615 list $res [expr {$::threadIdStarted == $serverthread}] \ 616 [expr {[info exists ::threadId] ? \ 617 $::threadId == $serverthread : 0}] \ 618 [expr {[info exists ::threadError($serverthread)] ? \ 619 [findThreadError $::threadError($serverthread)] : ""}] 620} -cleanup { 621 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 622} -result {{} 1 1 {eval unwound}} 623test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup { 624 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 625} -body { 626 set serverthread [thread::create -joinable \ 627 [string map [list %ID% [thread::id]] { 628 set i [interp create] 629 $i eval "package require -exact Thread [package present Thread]" 630 $i eval { 631 if {![info exists foo]} then { 632 # signal the primary thread that we are ready 633 # to be canceled now (we are running). 634 635 thread::send %ID% [list set ::threadIdStarted [thread::id]] 636 set foo 1 637 } 638 expr {[while {1} {incr x}]} 639 } 640 }]] 641 # wait for other thread to signal "ready to cancel" 642 vwait ::threadIdStarted 643 set res [thread::cancel $serverthread] 644 vwait ::threadSawError($serverthread) 645 thread::join $serverthread; drainEventQueue 646 list $res [expr {$::threadIdStarted == $serverthread}] \ 647 [expr {[info exists ::threadId] ? \ 648 $::threadId == $serverthread : 0}] \ 649 [expr {[info exists ::threadError($serverthread)] ? \ 650 [findThreadError $::threadError($serverthread)] : ""}] 651} -cleanup { 652 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 653} -result {{} 1 1 {eval canceled}} 654test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -setup { 655 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 656} -body { 657 set serverthread [thread::create -joinable \ 658 [string map [list %ID% [thread::id]] { 659 set i [interp create] 660 $i eval "package require -exact Thread [package present Thread]" 661 $i eval { 662 if {![info exists foo]} then { 663 # signal the primary thread that we are ready 664 # to be canceled now (we are running). 665 thread::send %ID% [list set ::threadIdStarted [thread::id]] 666 set foo 1 667 } 668 expr {[while {1} {incr x}]} 669 } 670 }]] 671 # wait for other thread to signal "ready to cancel" 672 vwait ::threadIdStarted 673 set res [thread::cancel -unwind $serverthread] 674 vwait ::threadSawError($serverthread) 675 thread::join $serverthread; drainEventQueue 676 list $res [expr {$::threadIdStarted == $serverthread}] \ 677 [expr {[info exists ::threadId] ? \ 678 $::threadId == $serverthread : 0}] \ 679 [expr {[info exists ::threadError($serverthread)] ? \ 680 [findThreadError $::threadError($serverthread)] : ""}] 681} -cleanup { 682 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 683} -result {{} 1 1 {eval unwound}} 684test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} { 685 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 686 set serverthread [thread::create -joinable \ 687 [string map [list %ID% [thread::id]] { 688 set i [interp create] 689 $i eval "package require -exact Thread [package present Thread]" 690 $i eval { 691 if {![info exists foo]} then { 692 # signal the primary thread that we are ready 693 # to be canceled now (we are running). 694 thread::send %ID% [list set ::threadIdStarted [thread::id]] 695 set foo 1 696 } 697 # 698 # BUGBUG: This will not cancel because libtommath 699 # does not check Tcl_Canceled. 700 # 701 expr {2**99999} 702 } 703 }]] 704 # wait for other thread to signal "ready to cancel" 705 vwait ::threadIdStarted; after 1000 706 set res [thread::cancel $serverthread] 707 vwait ::threadSawError($serverthread); # WARNING: Never returns (see above). 708 thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above). 709 list $res [expr {[info exists ::threadIdStarted] ? \ 710 $::threadIdStarted == $serverthread : 0}] \ 711 [expr {[info exists ::threadId] ? \ 712 $::threadId == $serverthread : 0}] \ 713 [expr {[info exists ::threadError($serverthread)] ? \ 714 [findThreadError $::threadError($serverthread)] : ""}] 715} {{} 1 0 {}} 716test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug} { 717 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 718 set serverthread [thread::create -joinable \ 719 [string map [list %ID% [thread::id]] { 720 set i [interp create] 721 $i eval "package require -exact Thread [package present Thread]" 722 $i eval { 723 if {![info exists foo]} then { 724 # signal the primary thread that we are ready 725 # to be canceled now (we are running). 726 thread::send %ID% [list set ::threadIdStarted [thread::id]] 727 set foo 1 728 } 729 # 730 # BUGBUG: This will not cancel because libtommath 731 # does not check Tcl_Canceled. 732 # 733 expr {2**99999} 734 } 735 }]] 736 # wait for other thread to signal "ready to cancel" 737 vwait ::threadIdStarted; after 1000 738 set res [thread::cancel -unwind $serverthread] 739 vwait ::threadSawError($serverthread); # WARNING: Never returns (see above). 740 thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above). 741 list $res [expr {[info exists ::threadIdStarted] ? \ 742 $::threadIdStarted == $serverthread : 0}] \ 743 [expr {[info exists ::threadId] ? \ 744 $::threadId == $serverthread : 0}] \ 745 [expr {[info exists ::threadError($serverthread)] ? \ 746 [findThreadError $::threadError($serverthread)] : ""}] 747} {{} 1 0 {}} 748test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup { 749 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 750} -body { 751 set serverthread [thread::create -joinable \ 752 [string map [list %ID% [thread::id]] { 753 set i [interp create] 754 $i eval "package require -exact Thread [package present Thread]" 755 $i eval { 756 if {![info exists foo]} then { 757 # signal the primary thread that we are ready 758 # to be canceled now (we are running). 759 thread::send %ID% [list set ::threadIdStarted [thread::id]] 760 set foo 1 761 } 762 subst {[while {1} {incr x}]} 763 } 764 }]] 765 # wait for other thread to signal "ready to cancel" 766 vwait ::threadIdStarted 767 set res [thread::cancel $serverthread] 768 vwait ::threadSawError($serverthread) 769 thread::join $serverthread; drainEventQueue 770 list $res [expr {$::threadIdStarted == $serverthread}] \ 771 [expr {[info exists ::threadId] ? \ 772 $::threadId == $serverthread : 0}] \ 773 [expr {[info exists ::threadError($serverthread)] ? \ 774 [findThreadError $::threadError($serverthread)] : ""}] 775} -cleanup { 776 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 777} -result {{} 1 1 {eval canceled}} 778test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -setup { 779 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 780} -body { 781 set serverthread [thread::create -joinable \ 782 [string map [list %ID% [thread::id]] { 783 set i [interp create] 784 $i eval "package require -exact Thread [package present Thread]" 785 $i eval { 786 if {![info exists foo]} then { 787 # signal the primary thread that we are ready 788 # to be canceled now (we are running). 789 thread::send %ID% [list set ::threadIdStarted [thread::id]] 790 set foo 1 791 } 792 subst {[while {1} {incr x}]} 793 } 794 }]] 795 # wait for other thread to signal "ready to cancel" 796 vwait ::threadIdStarted 797 set res [thread::cancel -unwind $serverthread] 798 vwait ::threadSawError($serverthread) 799 thread::join $serverthread; drainEventQueue 800 list $res [expr {$::threadIdStarted == $serverthread}] \ 801 [expr {[info exists ::threadId] ? \ 802 $::threadId == $serverthread : 0}] \ 803 [expr {[info exists ::threadError($serverthread)] ? \ 804 [findThreadError $::threadError($serverthread)] : ""}] 805} -cleanup { 806 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 807} -result {{} 1 1 {eval unwound}} 808test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup { 809 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 810} -body { 811 set serverthread [thread::create -joinable \ 812 [string map [list %ID% [thread::id]] { 813 set i [interp create] 814 $i eval "package require -exact Thread [package present Thread]" 815 $i eval { 816 if {![info exists foo]} then { 817 # signal the primary thread that we are ready 818 # to be canceled now (we are running). 819 thread::send %ID% [list set ::threadIdStarted [thread::id]] 820 set foo 1 821 } 822 while {1} {} 823 } 824 }]] 825 # wait for other thread to signal "ready to cancel" 826 vwait ::threadIdStarted 827 set res [thread::cancel $serverthread] 828 vwait ::threadSawError($serverthread) 829 thread::join $serverthread; drainEventQueue 830 list $res [expr {$::threadIdStarted == $serverthread}] \ 831 [expr {[info exists ::threadId] ? \ 832 $::threadId == $serverthread : 0}] \ 833 [expr {[info exists ::threadError($serverthread)] ? \ 834 [findThreadError $::threadError($serverthread)] : ""}] 835} -cleanup { 836 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 837} -result {{} 1 1 {eval canceled}} 838test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup { 839 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 840} -body { 841 set serverthread [thread::create -joinable \ 842 [string map [list %ID% [thread::id]] { 843 set i [interp create] 844 $i eval "package require -exact Thread [package present Thread]" 845 $i eval { 846 if {![info exists foo]} then { 847 # signal the primary thread that we are ready 848 # to be canceled now (we are running). 849 thread::send %ID% [list set ::threadIdStarted [thread::id]] 850 set foo 1 851 } 852 set while while; $while {1} {} 853 } 854 }]] 855 # wait for other thread to signal "ready to cancel" 856 vwait ::threadIdStarted 857 set res [thread::cancel -unwind $serverthread] 858 vwait ::threadSawError($serverthread) 859 thread::join $serverthread; drainEventQueue 860 list $res [expr {$::threadIdStarted == $serverthread}] \ 861 [expr {[info exists ::threadId] ? \ 862 $::threadId == $serverthread : 0}] \ 863 [expr {[info exists ::threadError($serverthread)] ? \ 864 [findThreadError $::threadError($serverthread)] : ""}] 865} -cleanup { 866 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 867} -result {{} 1 1 {eval unwound}} 868test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainEventQueue} { 869 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 870 set serverthread [thread::create -joinable \ 871 [string map [list %ID% [thread::id]] { 872 proc foobar {} { 873 while {1} { 874 if {![info exists foo]} then { 875 # signal the primary thread that we are ready 876 # to be canceled now (we are running). 877 thread::send %ID% [list set ::threadIdStarted [thread::id]] 878 set foo 1 879 } 880 catch { 881 while {1} { 882 catch { 883 while {1} { 884 # we must call update here because otherwise 885 # the thread cannot even be forced to exit. 886 update 887 } 888 } 889 } 890 } 891 } 892 } 893 foobar 894 }]] 895 # wait for other thread to signal "ready to cancel" 896 vwait ::threadIdStarted; after 1000 897 set res [thread::cancel $serverthread] 898 threadSuperKill $serverthread 899 vwait ::threadSawError($serverthread) 900 thread::join $serverthread; drainEventQueue 901 list $res [expr {[info exists ::threadIdStarted] ? \ 902 $::threadIdStarted == $serverthread : 0}] \ 903 [expr {[info exists ::threadId] ? \ 904 $::threadId == $serverthread : 0}] \ 905 [expr {[info exists ::threadError($serverthread)] ? \ 906 [findThreadError $::threadError($serverthread)] : ""}] 907} {{} 1 0 {}} 908test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread drainEventQueue} { 909 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 910 set serverthread [thread::create -joinable \ 911 [string map [list %ID% [thread::id]] { 912 proc foobar {} { 913 set catch catch 914 set while while 915 $while {1} { 916 if {![info exists foo]} then { 917 # signal the primary thread that we are ready 918 # to be canceled now (we are running). 919 thread::send %ID% [list set ::threadIdStarted [thread::id]] 920 set foo 1 921 } 922 $catch { 923 $while {1} { 924 $catch { 925 $while {1} { 926 # we must call update here because otherwise 927 # the thread cannot even be forced to exit. 928 update 929 } 930 } 931 } 932 } 933 } 934 } 935 foobar 936 }]] 937 # wait for other thread to signal "ready to cancel" 938 vwait ::threadIdStarted; after 1000 939 set res [thread::cancel $serverthread] 940 threadSuperKill $serverthread 941 vwait ::threadSawError($serverthread) 942 thread::join $serverthread; drainEventQueue 943 list $res [expr {[info exists ::threadIdStarted] ? \ 944 $::threadIdStarted == $serverthread : 0}] \ 945 [expr {[info exists ::threadId] ? \ 946 $::threadId == $serverthread : 0}] \ 947 [expr {[info exists ::threadError($serverthread)] ? \ 948 [findThreadError $::threadError($serverthread)] : ""}] 949} {{} 1 0 {}} 950test thread-7.26 {cancel: send async cancel bad interp path} {thread drainEventQueue} { 951 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 952 set serverthread [thread::create -joinable \ 953 [string map [list %ID% [thread::id]] { 954 proc foobar {} { 955 while {1} { 956 if {![info exists foo]} then { 957 # signal the primary thread that we are ready 958 # to be canceled now (we are running). 959 thread::send %ID% [list set ::threadIdStarted [thread::id]] 960 set foo 1 961 } 962 update 963 } 964 } 965 foobar 966 }]] 967 # wait for other thread to signal "ready to cancel" 968 vwait ::threadIdStarted 969 catch {thread::send $serverthread {interp cancel -- bad}} msg 970 thread::send -async $serverthread {interp cancel -unwind} 971 vwait ::threadSawError($serverthread) 972 thread::join $serverthread; drainEventQueue 973 list [expr {$::threadIdStarted == $serverthread}] $msg 974} {1 {could not find interpreter "bad"}} 975test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread drainEventQueue} -setup { 976 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 977} -body { 978 set serverthread [thread::create -joinable \ 979 [string map [list %ID% [thread::id]] { 980 set i [interp create -- -unwind] 981 $i eval "package require -exact Thread [package present Thread]" 982 $i eval { 983 proc foobar {} { 984 while {1} { 985 if {![info exists foo]} then { 986 # signal the primary thread that we are ready 987 # to be canceled now (we are running). 988 thread::send %ID% [list set ::threadIdStarted [thread::id]] 989 set foo 1 990 } 991 update 992 } 993 } 994 foobar 995 } 996 }]] 997 # wait for other thread to signal "ready to cancel" 998 vwait ::threadIdStarted 999 set res [thread::send -async $serverthread {interp cancel -- -unwind}] 1000 vwait ::threadSawError($serverthread) 1001 thread::join $serverthread; drainEventQueue 1002 list $res [expr {$::threadIdStarted == $serverthread}] \ 1003 [expr {[info exists ::threadId] ? \ 1004 $::threadId == $serverthread : 0}] \ 1005 [expr {[info exists ::threadError($serverthread)] ? \ 1006 [findThreadError $::threadError($serverthread)] : ""}] 1007} -cleanup { 1008 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1009} -result {{} 1 1 {eval canceled}} 1010test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread drainEventQueue} { 1011 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1012 set serverthread [thread::create -joinable \ 1013 [string map [list %ID% [thread::id]] { 1014 proc foobar {} { 1015 while {1} { 1016 if {![info exists foo]} then { 1017 # signal the primary thread that we are ready 1018 # to be canceled now (we are running). 1019 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1020 set foo 1 1021 } 1022 catch { 1023 while {1} { 1024 catch { 1025 while {1} { 1026 # we must call update here because otherwise 1027 # the thread cannot even be forced to exit. 1028 update 1029 } 1030 } 1031 } 1032 } 1033 } 1034 } 1035 foobar 1036 }]] 1037 # wait for other thread to signal "ready to cancel" 1038 vwait ::threadIdStarted; after 1000 1039 set res [thread::send -async $serverthread {interp cancel}] 1040 threadSuperKill $serverthread 1041 vwait ::threadSawError($serverthread) 1042 thread::join $serverthread; drainEventQueue 1043 list $res [expr {[info exists ::threadIdStarted] ? \ 1044 $::threadIdStarted == $serverthread : 0}] \ 1045 [expr {[info exists ::threadId] ? \ 1046 $::threadId == $serverthread : 0}] \ 1047 [expr {[info exists ::threadError($serverthread)] ? \ 1048 [findThreadError $::threadError($serverthread)] : ""}] 1049} {{} 1 1 {eval canceled}} 1050test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread drainEventQueue} { 1051 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1052 set serverthread [thread::create -joinable \ 1053 [string map [list %ID% [thread::id]] { 1054 proc foobar {} { 1055 set catch catch 1056 set while while 1057 $while {1} { 1058 if {![info exists foo]} then { 1059 # signal the primary thread that we are ready 1060 # to be canceled now (we are running). 1061 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1062 set foo 1 1063 } 1064 $catch { 1065 $while {1} { 1066 $catch { 1067 $while {1} { 1068 # we must call update here because otherwise 1069 # the thread cannot even be forced to exit. 1070 update 1071 } 1072 } 1073 } 1074 } 1075 } 1076 } 1077 foobar 1078 }]] 1079 # wait for other thread to signal "ready to cancel" 1080 vwait ::threadIdStarted; after 1000 1081 set res [thread::send -async $serverthread {interp cancel}] 1082 threadSuperKill $serverthread 1083 vwait ::threadSawError($serverthread) 1084 thread::join $serverthread; drainEventQueue 1085 list $res [expr {[info exists ::threadIdStarted] ? \ 1086 $::threadIdStarted == $serverthread : 0}] \ 1087 [expr {[info exists ::threadId] ? \ 1088 $::threadId == $serverthread : 0}] \ 1089 [expr {[info exists ::threadError($serverthread)] ? \ 1090 [findThreadError $::threadError($serverthread)] : ""}] 1091} {{} 1 1 {eval canceled}} 1092test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread drainEventQueue} { 1093 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1094 set serverthread [thread::create -joinable \ 1095 [string map [list %ID% [thread::id]] { 1096 proc foobar {} { 1097 while {1} { 1098 if {![info exists foo]} then { 1099 # signal the primary thread that we are ready 1100 # to be canceled now (we are running). 1101 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1102 set foo 1 1103 } 1104 catch { 1105 while {1} { 1106 catch { 1107 while {1} { 1108 # we must call update here because otherwise 1109 # the thread cannot even be forced to exit. 1110 update 1111 } 1112 } 1113 } 1114 } 1115 } 1116 } 1117 foobar 1118 }]] 1119 # wait for other thread to signal "ready to cancel" 1120 vwait ::threadIdStarted; after 1000 1121 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] 1122 threadSuperKill $serverthread 1123 vwait ::threadSawError($serverthread) 1124 thread::join $serverthread; drainEventQueue 1125 list $res [expr {[info exists ::threadIdStarted] ? \ 1126 $::threadIdStarted == $serverthread : 0}] \ 1127 [expr {[info exists ::threadId] ? \ 1128 $::threadId == $serverthread : 0}] \ 1129 [expr {[info exists ::threadError($serverthread)] ? \ 1130 [findThreadError $::threadError($serverthread)] : ""}] 1131} {{} 1 1 {eval canceled}} 1132test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread drainEventQueue} { 1133 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1134 set serverthread [thread::create -joinable \ 1135 [string map [list %ID% [thread::id]] { 1136 proc foobar {} { 1137 set catch catch 1138 set while while 1139 $while {1} { 1140 if {![info exists foo]} then { 1141 # signal the primary thread that we are ready 1142 # to be canceled now (we are running). 1143 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1144 set foo 1 1145 } 1146 $catch { 1147 $while {1} { 1148 $catch { 1149 $while {1} { 1150 # we must call update here because otherwise 1151 # the thread cannot even be forced to exit. 1152 update 1153 } 1154 } 1155 } 1156 } 1157 } 1158 } 1159 foobar 1160 }]] 1161 # wait for other thread to signal "ready to cancel" 1162 vwait ::threadIdStarted; after 1000 1163 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] 1164 threadSuperKill $serverthread 1165 vwait ::threadSawError($serverthread) 1166 thread::join $serverthread; drainEventQueue 1167 list $res [expr {[info exists ::threadIdStarted] ? \ 1168 $::threadIdStarted == $serverthread : 0}] \ 1169 [expr {[info exists ::threadId] ? \ 1170 $::threadId == $serverthread : 0}] \ 1171 [expr {[info exists ::threadError($serverthread)] ? \ 1172 [findThreadError $::threadError($serverthread)] : ""}] 1173} {{} 1 1 {eval canceled}} 1174test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { 1175 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1176} -body { 1177 set serverthread [thread::create -joinable \ 1178 [string map [list %ID% [thread::id]] { 1179 proc foobar {} { 1180 while {1} { 1181 if {![info exists foo]} then { 1182 # signal the primary thread that we are ready 1183 # to be canceled now (we are running). 1184 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1185 set foo 1 1186 } 1187 catch { 1188 while {1} { 1189 catch { 1190 while {1} { 1191 # No bytecode at all here... 1192 } 1193 } 1194 } 1195 } 1196 } 1197 } 1198 foobar 1199 }]] 1200 # wait for other thread to signal "ready to cancel" 1201 vwait ::threadIdStarted 1202 set res [thread::cancel -unwind $serverthread] 1203 vwait ::threadSawError($serverthread) 1204 thread::join $serverthread; drainEventQueue 1205 list $res [expr {$::threadIdStarted == $serverthread}] \ 1206 [expr {[info exists ::threadId] ? \ 1207 $::threadId == $serverthread : 0}] \ 1208 [expr {[info exists ::threadError($serverthread)] ? \ 1209 [findThreadError $::threadError($serverthread)] : ""}] 1210} -cleanup { 1211 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1212} -result {{} 1 1 {eval unwound}} 1213test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { 1214 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1215} -body { 1216 set serverthread [thread::create -joinable \ 1217 [string map [list %ID% [thread::id]] { 1218 proc foobar {} { 1219 set catch catch 1220 set while while 1221 $while {1} { 1222 if {![info exists foo]} then { 1223 # signal the primary thread that we are ready 1224 # to be canceled now (we are running). 1225 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1226 set foo 1 1227 } 1228 $catch { 1229 $while {1} { 1230 $catch { 1231 $while {1} { 1232 # No bytecode at all here... 1233 } 1234 } 1235 } 1236 } 1237 } 1238 } 1239 foobar 1240 }]] 1241 # wait for other thread to signal "ready to cancel" 1242 vwait ::threadIdStarted 1243 set res [thread::cancel -unwind $serverthread] 1244 vwait ::threadSawError($serverthread) 1245 thread::join $serverthread; drainEventQueue 1246 list $res [expr {$::threadIdStarted == $serverthread}] \ 1247 [expr {[info exists ::threadId] ? \ 1248 $::threadId == $serverthread : 0}] \ 1249 [expr {[info exists ::threadError($serverthread)] ? \ 1250 [findThreadError $::threadError($serverthread)] : ""}] 1251} -cleanup { 1252 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1253} -result {{} 1 1 {eval unwound}} 1254test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { 1255 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1256} -body { 1257 set serverthread [thread::create -joinable \ 1258 [string map [list %ID% [thread::id]] { 1259 proc foobar {} { 1260 while {1} { 1261 if {![info exists foo]} then { 1262 # signal the primary thread that we are ready 1263 # to be canceled now (we are running). 1264 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1265 set foo 1 1266 } 1267 catch { 1268 while {1} { 1269 catch { 1270 while {1} { 1271 # we must call update here because otherwise 1272 # the thread cannot even be forced to exit. 1273 update 1274 } 1275 } 1276 } 1277 } 1278 } 1279 } 1280 foobar 1281 }]] 1282 # wait for other thread to signal "ready to cancel" 1283 vwait ::threadIdStarted 1284 set res [thread::send -async $serverthread {interp cancel -unwind}] 1285 vwait ::threadSawError($serverthread) 1286 thread::join $serverthread; drainEventQueue 1287 list $res [expr {$::threadIdStarted == $serverthread}] \ 1288 [expr {[info exists ::threadId] ? \ 1289 $::threadId == $serverthread : 0}] \ 1290 [expr {[info exists ::threadError($serverthread)] ? \ 1291 [findThreadError $::threadError($serverthread)] : ""}] 1292} -cleanup { 1293 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1294} -result {{} 1 1 {eval unwound}} 1295test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { 1296 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1297} -body { 1298 set serverthread [thread::create -joinable \ 1299 [string map [list %ID% [thread::id]] { 1300 proc foobar {} { 1301 set catch catch 1302 set while while 1303 $while {1} { 1304 if {![info exists foo]} then { 1305 # signal the primary thread that we are ready 1306 # to be canceled now (we are running). 1307 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1308 set foo 1 1309 } 1310 $catch { 1311 $while {1} { 1312 $catch { 1313 $while {1} { 1314 # we must call update here because otherwise 1315 # the thread cannot even be forced to exit. 1316 update 1317 } 1318 } 1319 } 1320 } 1321 } 1322 } 1323 foobar 1324 }]] 1325 # wait for other thread to signal "ready to cancel" 1326 vwait ::threadIdStarted 1327 set res [thread::send -async $serverthread {interp cancel -unwind}] 1328 vwait ::threadSawError($serverthread) 1329 thread::join $serverthread; drainEventQueue 1330 list $res [expr {$::threadIdStarted == $serverthread}] \ 1331 [expr {[info exists ::threadId] ? \ 1332 $::threadId == $serverthread : 0}] \ 1333 [expr {[info exists ::threadError($serverthread)] ? \ 1334 [findThreadError $::threadError($serverthread)] : ""}] 1335} -cleanup { 1336 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1337} -result {{} 1 1 {eval unwound}} 1338test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { 1339 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1340} -body { 1341 set serverthread [thread::create -joinable \ 1342 [string map [list %ID% [thread::id]] { 1343 proc foobar {} { 1344 while {1} { 1345 if {![info exists foo]} then { 1346 # signal the primary thread that we are ready 1347 # to be canceled now (we are running). 1348 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1349 set foo 1 1350 } 1351 catch { 1352 while {1} { 1353 catch { 1354 while {1} { 1355 # we must call update here because otherwise 1356 # the thread cannot even be forced to exit. 1357 update 1358 } 1359 } 1360 } 1361 } 1362 } 1363 } 1364 foobar 1365 }]] 1366 # wait for other thread to signal "ready to cancel" 1367 vwait ::threadIdStarted 1368 set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] 1369 vwait ::threadSawError($serverthread) 1370 thread::join $serverthread; drainEventQueue 1371 list $res [expr {$::threadIdStarted == $serverthread}] \ 1372 [expr {[info exists ::threadId] ? \ 1373 $::threadId == $serverthread : 0}] \ 1374 [expr {[info exists ::threadError($serverthread)] ? \ 1375 [findThreadError $::threadError($serverthread)] : ""}] 1376} -cleanup { 1377 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1378} -result {{} 1 1 {eval unwound}} 1379test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { 1380 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1381} -body { 1382 set serverthread [thread::create -joinable \ 1383 [string map [list %ID% [thread::id]] { 1384 proc foobar {} { 1385 set catch catch 1386 set while while 1387 $while {1} { 1388 if {![info exists foo]} then { 1389 # signal the primary thread that we are ready 1390 # to be canceled now (we are running). 1391 thread::send %ID% [list set ::threadIdStarted [thread::id]] 1392 set foo 1 1393 } 1394 $catch { 1395 $while {1} { 1396 $catch { 1397 $while {1} { 1398 # we must call update here because otherwise 1399 # the thread cannot even be forced to exit. 1400 update 1401 } 1402 } 1403 } 1404 } 1405 } 1406 } 1407 foobar 1408 }]] 1409 # wait for other thread to signal "ready to cancel" 1410 vwait ::threadIdStarted 1411 set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] 1412 vwait ::threadSawError($serverthread) 1413 thread::join $serverthread; drainEventQueue 1414 list $res [expr {$::threadIdStarted == $serverthread}] \ 1415 [expr {[info exists ::threadId] ? \ 1416 $::threadId == $serverthread : 0}] \ 1417 [expr {[info exists ::threadError($serverthread)] ? \ 1418 [findThreadError $::threadError($serverthread)] : ""}] 1419} -cleanup { 1420 unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted 1421} -result {{} 1 1 {eval unwound}} 1422 1423test thread-8.1 {threaded fork stress} -constraints {thread} -setup { 1424 unset -nocomplain ::threadCount ::execCount ::threads ::thread 1425 set ::threadCount 10 1426 set ::execCount 10 1427} -body { 1428 set ::threads [list] 1429 for {set i 0} {$i < $::threadCount} {incr i} { 1430 lappend ::threads [thread::create -joinable [string map \ 1431 [list %execCount% $::execCount] { 1432 proc execLs {} { 1433 if {$::tcl_platform(platform) eq "windows"} then { 1434 return [exec $::env(COMSPEC) /c DIR] 1435 } else { 1436 return [exec /bin/ls] 1437 } 1438 } 1439 set j {%execCount%}; while {[incr j -1]} {execLs} 1440 }]] 1441 } 1442 foreach ::thread $::threads { 1443 thread::join $::thread 1444 } 1445} -cleanup { 1446 unset -nocomplain ::threadCount ::execCount ::threads ::thread 1447} -result {} 1448 1449# cleanup 1450::tcltest::cleanupTests 1451return 1452