1# Commands covered: 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 (c) 1996 Sun Microsystems, Inc. 8# Copyright (c) 1998-2000 Scriptics Corporation. 9# Copyright (c) 2002 ActiveState Corporation. 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 14package require tcltest 15namespace import ::tcltest::* 16tcltest::loadTestedCommands 17package require Thread 18 19tcltest::testConstraint chanTransfer \ 20 [expr { $::tcl_platform(platform) == "unix" \ 21 || $::tcl_patchLevel > "8.4.10"}] 22 23set dummy [makeFile dummyForTransfer dummyForTransfer] 24set tcltest::mainThread [thread::id] 25 26proc ThreadReap {} { 27 while {[llength [thread::names]] > 1} { 28 foreach tid [thread::names] { 29 if {$tid != $::tcltest::mainThread} { 30 catch {thread::release -wait $tid} 31 } 32 } 33 } 34 llength [thread::names] 35} 36 37test thread-2.0 {no global thread command} { 38 info commands thread 39} {} 40 41test thread-2.84 {thread subcommands} { 42 set cmds [info commands thread::*] 43 set idx [lsearch -exact $cmds ::thread::cancel] 44 lsort [lreplace $cmds $idx $idx] 45} {::thread::attach ::thread::broadcast ::thread::cond ::thread::configure ::thread::create ::thread::detach ::thread::errorproc ::thread::eval ::thread::exists ::thread::exit ::thread::id ::thread::join ::thread::mutex ::thread::names ::thread::preserve ::thread::release ::thread::rwmutex ::thread::send ::thread::transfer ::thread::unwind ::thread::wait} 46 47test thread-3.0 {thread::names initial thread list} { 48 list [ThreadReap] [llength [thread::names]] 49} {1 1} 50 51test thread-4.0 {thread::create: create server thread} { 52 ThreadReap 53 set tid [thread::create] 54 update 55 set l [llength [thread::names]] 56 ThreadReap 57 set l 58} {2} 59 60test thread-4.1 {thread::create: create one shot thread} { 61 ThreadReap 62 thread::create {set x 5} 63 foreach try {0 1 2 4 5 6} { 64 # Try various ways to yield 65 update 66 after 10 67 set l [llength [thread::names]] 68 if {$l == 1} { 69 break 70 } 71 } 72 ThreadReap 73 set l 74} {1} 75 76test thread-4.2 {thread::create - create preservable thread} { 77 ThreadReap 78 set tid [thread::create -preserved] 79 set c [thread::preserve $tid] 80 thread::release -wait $tid 81 ThreadReap 82 set c 83} {2} 84 85test thread-4.3 {thread::create - release a thread} { 86 ThreadReap 87 set tid [thread::create {thread::release}] 88 update 89 after 10 90 set l [llength [thread::names]] 91 ThreadReap 92 set l 93} {1} 94 95test thread-4.4 {thread::create - create joinable thread} { 96 ThreadReap 97 set tid [thread::create -joinable {set x 5}] 98 set c [thread::join $tid] 99 ThreadReap 100 set c 101} {0} 102 103test thread-4.5 {thread::create - join detached thread} { 104 ThreadReap 105 set tid [thread::create] 106 thread::send -async $tid {after 1000 ; thread::release} 107 catch {set res [thread::join $tid]} msg 108 ThreadReap 109 lrange $msg 0 2 110} {cannot join thread} 111 112test thread-5.0 {thread::release} { 113 ThreadReap 114 set tid [thread::create {thread::release}] 115 update 116 after 10 117 set l [llength [thread::names]] 118 ThreadReap 119 set l 120} {1} 121 122test thread-6.0 {thread::unwind - simple unwind} { 123 ThreadReap 124 thread::create {thread::unwind} 125 update 126 after 10 127 set l [llength [thread::names]] 128 ThreadReap 129 set l 130} {1} 131 132test thread-6.1 {thread::unwind - blocked unwind} { 133 ThreadReap 134 thread::create {thread::unwind; vwait dummy} 135 update 136 after 10 137 set l [llength [thread::names]] 138 ThreadReap 139 set l 140} {2} 141 142test thread-7.0 {thread::exit} { 143 ThreadReap 144 set tid [thread::create -joinable {thread::exit}] 145 set c [thread::join $tid] 146 ThreadReap 147 set c 148} {666} 149 150test thread-7.1 {thread::exit - # args} { 151 set tid [thread::create] 152 catch {thread::send $tid {thread::exit 1 0}} msg 153 set msg 154} {wrong # args: should be "thread::exit ?status?"} 155 156test thread-7.2 {thread::exit - args} { 157 set tid [thread::create] 158 catch {thread::send $tid {thread::exit foo}} msg 159 set msg 160} {expected integer but got "foo"} 161 162test thread-7.3 {thread::exit - status} { 163 ThreadReap 164 set tid [thread::create -joinable {thread::exit 0}] 165 set c [thread::join $tid] 166 ThreadReap 167 set c 168} {0} 169 170test thread-8.0 {thread::exists - true} { 171 ThreadReap 172 set c [thread::exists [thread::create]] 173 ThreadReap 174 set c 175} {1} 176 177test thread-8.1 {thread::exists - false} { 178 ThreadReap 179 set tid [thread::create {set x 5}] 180 update 181 after 10 182 set c [thread::exists $tid] 183 ThreadReap 184 set c 185} {0} 186 187test thread-9.0 {thread::id} { 188 expr {[thread::id] == $::tcltest::mainThread} 189} {1} 190 191test thread-9.1 {thread::id - args} { 192 set x [catch {thread::id x} msg] 193 list $x $msg 194} {1 {wrong # args: should be "thread::id"}} 195 196test thread-10.0 {thread::names args} { 197 set x [catch {thread::names x} msg] 198 list $x $msg 199} {1 {wrong # args: should be "thread::names"}} 200 201test thread-11.0 {thread::send - no args} { 202 set x [catch {thread::send} msg] 203 list $x $msg 204} {1 {wrong # args: should be "thread::send ?-async? ?-head? id script ?varName?"}} 205 206test thread-11.1 {thread::send - simple script} { 207 ThreadReap 208 set tid [thread::create] 209 set five [thread::send $tid {set x 5}] 210 ThreadReap 211 set five 212} 5 213 214test thread-11.2 {thread::send - bad thread id} { 215 set tid dummy 216 set x [catch {thread::send $tid {set x 5}} msg] 217 list $x $msg 218} {1 {invalid thread handle "dummy"}} 219 220test thread-11.3 {thread::send - test TCL_ERROR return code} { 221 ThreadReap 222 set tid [thread::create] 223 set c [thread::send $tid {dummy} msg] 224 ThreadReap 225 list $c $msg} {1 {invalid command name "dummy"}} 226 227test thread-11.4 {thread::send - test TCL_RETURN return code} { 228 ThreadReap 229 set tid [thread::create] 230 set c [thread::send $tid {return} msg] 231 ThreadReap 232 list $c $msg 233} {2 {}} 234 235test thread-11.5 {thread::send - test TCL_BREAK return code} { 236 ThreadReap 237 set tid [thread::create] 238 set c [thread::send $tid {break} msg] 239 ThreadReap 240 list $c $msg 241} {3 {}} 242 243test thread-11.6 {thread::send - asynchronous send} { 244 ThreadReap 245 set tid [thread::create] 246 thread::send -async $tid {set x 5} 247 update 248 after 10 249 set five [thread::send $tid {set x}] 250 ThreadReap 251 set five 252} {5} 253 254test thread-11.7 {thread::send - async send with event-loop wait} { 255 ThreadReap 256 set res {} 257 set tid [thread::create] 258 thread::send -async $tid {set x 5} five 259 vwait five 260 lappend res $five; set five {} 261 thread::send -async $tid {set x 5} [binary format cccc 0x66 0x69 0x76 0x65]; # five as byte array without str-rep. 262 vwait five 263 lappend res $five; set five {} 264 ThreadReap 265 set res 266} {5 5} 267 268test thread-11.7.1 {thread::send - sync send with var} { 269 ThreadReap 270 set res {} 271 set tid [thread::create] 272 thread::send $tid {set x 5} five 273 lappend res $five; set five {} 274 thread::send $tid {set x 5} [binary format cccc 0x66 0x69 0x76 0x65]; # five as byte array without str-rep. 275 lappend res $five; set five {} 276 ThreadReap 277 set res 278} {5 5} 279 280test thread-11.8 {thread::send - send to self directly} { 281 thread::send [thread::id] {set x 5} five 282 set five 283} {5} 284 285test thread-11.9 {thread::send - send to self asynchronously} { 286 set c [catch {thread::send -async [thread::id] {set x 5} five} msg] 287 list $c $msg 288} {1 {can't notify self}} 289 290 291test thread-11.10 {thread::send - preserve errorInfo} { 292 ThreadReap 293 set len [llength [thread::names]] 294 set tid [thread::create] 295 set c [catch {thread::send $tid {set undef}} msg] 296 ThreadReap 297 list $c $msg $errorInfo 298} {1 {can't read "undef": no such variable} {can't read "undef": no such variable 299 while executing 300"set undef" 301 invoked from within 302"thread::send $tid {set undef}"}} 303 304test thread-11.11 {Thread_Send preserve errorCode} { 305 ThreadReap 306 set tid [thread::create] 307 set c [catch {thread::send $tid {error ERR INFO CODE}} msg] 308 ThreadReap 309 list $c $msg $errorCode 310} {1 ERR CODE} 311 312test thread-12.0 {thread::wait} { 313 ThreadReap 314 set tid [thread::create {set x 5; thread::wait}] 315 thread::send $tid {set x} five 316 ThreadReap 317 set five 318} {5} 319 320test thread-13.0 {thread::broadcast} { 321 ThreadReap 322 catch {unset tids} 323 foreach i {1 2 3 4} { 324 lappend tids [thread::create] 325 } 326 thread::broadcast {set x 5} 327 update 328 catch {unset r} 329 foreach tid $tids { 330 lappend r [thread::send $tid {if {[info exists x]} {set x}}] 331 } 332 ThreadReap 333 set r 334} {5 5 5 5} 335 336test thread-13.1 {thread::broadcast no args} { 337 set c [catch {thread::broadcast} msg] 338 list $c $msg 339} {1 {wrong # args: should be "thread::broadcast script"}} 340 341 342test thread-14.0 {thread::eval - no arguments} { 343 set c [catch {thread::eval} msg] 344 list $c $msg 345} {1 {wrong # args: should be "thread::eval ?-lock <mutexHandle>? arg ?arg...?"}} 346 347test thread-14.1 {thread::eval - bad arguments} { 348 set c [catch {thread::eval -lock} msg] 349 list $c $msg 350} {1 {wrong # args: should be "thread::eval ?-lock <mutexHandle>? arg ?arg...?"}} 351 352test thread-14.2 {thread::eval - missing script argument} { 353 set c [catch {thread::eval -lock dummy} msg] 354 list $c $msg 355} {1 {wrong # args: should be "thread::eval ?-lock <mutexHandle>? arg ?arg...?"}} 356 357test thread-14.3 {thread::eval - bad mutex handle} { 358 set c [catch {thread::eval -lock dummy {set x 5}} msg] 359 list $c $msg 360} {1 {no such mutex "dummy"}} 361 362test thread-14.4 {thread::eval - nested eval} { 363 thread::eval {thread::eval {thread::eval {set x 5}}} 364} {5} 365 366test thread-15.0 {thread::configure - bad arguments} { 367 set c [catch {thread::configure} msg] 368 list $c $msg 369} {1 {wrong # args: should be "thread::configure threadlId ?optionName? ?value? ?optionName value?..."}} 370 371test thread-15.1 {thread::configure - bad thread id argument} { 372 set c [catch {thread::configure dummy} msg] 373 list $c $msg 374} {1 {invalid thread handle "dummy"}} 375 376test thread-15.2 {thread::configure - bad configure option} { 377 set c [catch {thread::configure [thread::id] -dummy} msg] 378 list $c $msg 379} {1 {bad option "-dummy", should be one of -eventmark, -unwindonerror or -errorstate}} 380 381test thread-15.3 {thread::configure - read all configure options} { 382 ThreadReap 383 set tid [thread::create] 384 catch {unset opts} 385 set opts [thread::configure $tid] 386 ThreadReap 387 expr {[llength $opts] % 2} 388} {0} 389 390test thread-15.4 {thread::configure - check configure option names} { 391 ThreadReap 392 set tid [thread::create] 393 update 394 after 10 395 catch {unset opts} 396 array set opts [thread::configure $tid] 397 ThreadReap 398 array names opts 399} {-errorstate -unwindonerror -eventmark} 400 401test thread-15.5 {thread::configure - get one config option} { 402 ThreadReap 403 set tid [thread::create] 404 update 405 after 10 406 set l "" 407 lappend l [thread::configure $tid -eventmark] 408 lappend l [thread::configure $tid -unwindonerror] 409 lappend l [thread::configure $tid -errorstate] 410 ThreadReap 411 set l 412} {0 0 0} 413 414test thread-15.6 {thread::configure - set -unwindonerror option} { 415 ThreadReap 416 set tid [thread::create] 417 update 418 after 10 419 thread::configure $tid -unwindonerror 1 420 set c [catch {thread::send $tid {set dummy}}] 421 update 422 after 10 423 set e [thread::exists $tid] 424 ThreadReap 425 list $c $e 426} {1 0} 427 428test thread-15.7 {thread::configure - set -errorstate option} { 429 ThreadReap 430 set tid [thread::create] 431 update 432 after 10 433 thread::configure $tid -errorstate 1 434 set c [thread::send $tid {set dummy} msg] 435 ThreadReap 436 list $c $msg 437} {1 {thread is in error}} 438 439test thread-15.8 {thread::configure - set -eventmark option} { 440 ThreadReap 441 set tid [thread::create] 442 update 443 after 10 444 thread::configure $tid -eventmark 1 445 thread::send -async $tid {after 2000} 446 set t1 [clock seconds] 447 thread::send -async $tid {after 2000} 448 set t2 [clock seconds] 449 ThreadReap 450 expr {($t2 - $t1) >= 2} 451} {1} 452 453test thread-16.0 {thread::errorproc - args} { 454 set x [catch {thread::errorproc foo bar} msg] 455 list $x $msg 456} {1 {wrong # args: should be "thread::errorproc ?proc?"}} 457 458test thread-16.1 {thread::errorproc - errorproc change} { 459 thread::errorproc foo 460 thread::errorproc ThreadError 461 set new [thread::errorproc] 462} {ThreadError} 463 464test thread-16.2 {thread::errorproc - async reporting} { 465 set etid "" 466 set emsg "" 467 proc myerrproc {tid msg} { 468 global etid emsg 469 set etid $tid 470 set emsg $msg 471 } 472 ThreadReap 473 thread::errorproc myerrproc 474 set tid [thread::create] 475 update 476 after 10 477 thread::send -async $tid {set x} 478 after 10 479 update 480 ThreadReap 481 list [expr {$etid == $tid}] $emsg 482} {1 {can't read "x": no such variable 483 while executing 484"set x"}} 485 486test thread-17.1 {thread::transfer - channel lists} {chanTransfer} { 487 ThreadReap 488 set tid [thread::create] 489 set file [open $dummy r] 490 set res [regexp $file [file channels]] 491 thread::transfer $tid $file 492 lappend res [regexp $file [file channels]] 493 lappend res [regexp $file [thread::send $tid {file channels}]] 494 thread::send $tid "close $file" 495 ThreadReap 496 set res 497} {1 0 1} 498 499test thread-17.2 {thread::transfer - target thread dying} {chanTransfer} { 500 ThreadReap 501 set tid [thread::create] 502 set file [open $dummy r] 503 thread::send -async $tid {after 3000 ; thread::release} 504 catch {thread::transfer $tid $file} msg 505 close $file 506 ThreadReap 507 set msg 508} {transfer failed: target thread died} 509 510test thread-17.3 {thread::transfer - clearing of fileevents} {chanTransfer} { 511 proc _HandleIt_ {} { 512 global gotEvents tid file 513 if {$gotEvents == 0} { 514 thread::transfer $tid $file 515 # From now on no events should be delivered anymore, 516 # restricting the end value to 1 517 } 518 incr gotEvents 519 } 520 ThreadReap 521 set tid [thread::create] 522 set file [open $dummy r] 523 set gotEvents 0 524 fileevent $file readable _HandleIt_ 525 vwait gotEvents 526 thread::send $tid "close $file" 527 ThreadReap 528 set gotEvents 529} {1} 530 531test thread-17.4 {thread::transfer - file - readable?} {chanTransfer} { 532 ThreadReap 533 set tid [thread::create] 534 set file [open $dummy r] 535 set res [regexp $file [file channels]] 536 thread::transfer $tid $file 537 set res [string length [thread::send $tid "read -nonewline $file"]] 538 thread::send $tid "close $file" 539 ThreadReap 540 set res 541} [string length [::tcltest::viewFile dummyForTransfer]] 542 543test thread-17.5 {thread::transfer - file - closeable?} {chanTransfer} { 544 set tid [thread::create] 545 set file [open $dummy r] 546 set res [regexp $file [file channels]] 547 thread::transfer $tid $file 548 set res [thread::send $tid "close $file"] 549 ThreadReap 550 set res 551} {} 552 553test thread-17.6 {thread::transfer - socket - readable?} {chanTransfer} { 554 set tid [thread::create] 555 set lsock "" 556 proc accept {sock host port} {global lsock ; set lsock $sock} 557 set listener [socket -server accept 0] 558 set port [lindex [fconfigure $listener -sockname] 2] 559 set socket [socket localhost $port] 560 vwait lsock 561 562 thread::transfer $tid $socket 563 564 puts $lsock hello 565 flush $lsock 566 567 set res [thread::send $tid [list gets $socket]] 568 thread::send $tid [list close $socket] 569 570 ThreadReap 571 close $listener 572 close $lsock 573 574 set res 575} {hello} 576 577test thread-17.7 {thread::transfer - socket - closeable?} {chanTransfer} { 578 set tid [thread::create] 579 set lsock "" 580 proc accept {sock host port} {global lsock ; set lsock $sock} 581 set listener [socket -server accept 0] 582 set port [lindex [fconfigure $listener -sockname] 2] 583 set socket [socket localhost $port] 584 vwait lsock 585 586 thread::transfer $tid $socket 587 588 set res [thread::send $tid "regexp {$socket} \[file channels\]"] 589 lappend res [thread::send $tid [list close $socket]] 590 lappend res [thread::send $tid "regexp {$socket} \[file channels\]"] 591 592 ThreadReap 593 close $listener 594 close $lsock 595 596 set res 597} {1 {} 0} 598 599# We cannot test console channels, nor serials. Because we do not 600# really know if they are available, and under what names. But a pipe 601# channel, which uses the same type of code is something we can 602# do. Lucky us. 603 604test thread-17.8 {thread::transfer - pipe - readable?} {chanTransfer} { 605 set tid [thread::create] 606 607 set s [makeFile { 608 puts hello 609 flush stdout 610 exit 611 } pscript] 612 set pipe [open "|[info nameofexecutable] $s" r] 613 614 thread::transfer $tid $pipe 615 616 thread::send $tid [list set pipe $pipe] 617 618 set res [thread::send $tid {gets $pipe}] 619 thread::send $tid {catch {close $pipe}} 620 621 ThreadReap 622 removeFile pscript 623 624 set res 625} {hello} 626 627# The difference between 9 and 10 is the location of the close 628# operation. For 9 it is the original thread, for 10 the other 629# thread. 10 currently fails. It seems to be some signal stuff. 630 631test thread-17.9 {thread::transfer - pipe - closable?} {chanTransfer} { 632 set tid [thread::create] 633 634 set s [makeFile { 635 fileevent stdin readable {if {[eof stdin]} {exit 0} ; gets stdin} 636 vwait forever 637 exit 0 638 } pscript] 639 set pipe [open "|[info nameofexecutable] $s" r+] 640 thread::send $tid [list set chan $pipe] 641 642 thread::transfer $tid $pipe 643 thread::send $tid {thread::detach $chan} 644 thread::attach $pipe 645 646 set res [regexp $pipe [file channels]] 647 lappend res [close $pipe] 648 lappend res [regexp $pipe [file channels]] 649 650 ThreadReap 651 removeFile pscript 652 653 set res 654} {1 {} 0} 655 656test thread-17.10 {thread::transfer - pipe - closable?} {chanTransfer} { 657 658 set tid [thread::create] 659 660 set s [makeFile { 661 fileevent stdin readable {if {[eof stdin]} {exit 0} ; gets stdin} 662 vwait forever 663 exit 0 664 } pscript] 665 set pipe [open "|[info nameofexecutable] $s" r+] 666 thread::send $tid [list set chan $pipe] 667 668 thread::transfer $tid $pipe 669 670 set res [thread::send $tid {regexp $chan [file channels]}] 671 672 if {[catch { 673 # This can fail on Linux, because there a thread cannot 'wait' on 674 # the children of a different thread (in the same process). This 675 # is for Linux < 2.4. For 2.4 it should be possible, but the 676 # language is cautionary, so it may still fail. 677 678 lappend res [thread::send $tid {close $chan}] 679 }]} { 680 # Fake a result 681 lappend res {} 682 } 683 684 lappend res [thread::send $tid {regexp $chan [file channels]}] 685 686 ThreadReap 687 removeFile pscript 688 689 set res 690} {1 {} 0} 691 692test thread-17.11a {thread::transfer - pipe - readable event - no transfer} { 693 set tid [thread::create] 694 695 set s [makeFile { 696 after 5000 {exit 0} 697 fileevent stdin readable { 698 if {[eof stdin]} {exit 0} 699 if {[gets stdin line] <0} return 700 puts response 701 } 702 vwait forever 703 exit 0 704 } pscript] ;# {} 705 706 set pipe [open "|[info nameofexecutable] $s" r+] 707 708 fconfigure $pipe -blocking 0 709 fileevent $pipe readable {read $pipe ; set cond ok} 710 after 3000 {set cond timeout} 711 712 puts $pipe tick ; flush $pipe 713 714 vwait ::cond 715 catch {close $pipe} 716 removeFile pscript 717 718 set cond 719} ok 720 721test thread-17.11b {thread::transfer - pipe - readable event - with transfer} { 722 set tid [thread::create] 723 724 set s [makeFile { 725 after 5000 {exit 0} 726 fileevent stdin readable { 727 if {[eof stdin]} {exit 0} 728 if {[gets stdin line] <0} return 729 puts response 730 } 731 vwait forever 732 exit 0 733 } pscript] ;# {} 734 set pipe [open "|[info nameofexecutable] $s" r+] 735 736 thread::transfer $tid $pipe 737 738 thread::send $tid [list set chan $pipe] 739 set cond [thread::send $tid { 740 fconfigure $chan -blocking 0 741 fileevent $chan readable {read $chan ; set cond ok} 742 after 3000 {set cond timeout} 743 744 puts $chan tick ; flush $chan 745 746 vwait ::cond 747 catch {close $pipe} 748 set cond 749 }] 750 751 ThreadReap 752 removeFile pscript 753 754 set cond 755} ok 756 757 758test thread-18.0 {thread::detach - args} { 759 set x [catch {thread::detach} msg] 760 list $x $msg 761} {1 {wrong # args: should be "thread::detach channel"}} 762 763 764test thread-18.1 {thread::detach - channel} { 765 global fd 766 set fd [open $dummy r] 767 set r1 [regexp $fd [file channels]] 768 thread::detach $fd 769 set r2 [regexp $fd [file channels]] 770 list $r1 $r2 771} {1 0} 772 773test thread-18.2 {thread::attach - in different thread} { 774 global fd 775 ThreadReap 776 set tid [thread::create] 777 thread::send $tid "thread::attach $fd" 778 set r1 [thread::send $tid "regexp $fd \[file channels\]"] 779 thread::send $tid "thread::detach $fd" 780 list $r1 781} {1} 782 783test thread-18.3 {thread::attach - in same thread} { 784 global fd 785 thread::attach $fd 786 set r1 [regexp $fd [file channels]] 787 close $fd 788 set r1 789} {1} 790 791test thread-19.0 {thread::mutex - args} { 792 set x [catch {thread::mutex} msg] 793 list $x $msg 794} {1 {wrong # args: should be "thread::mutex option ?args?"}} 795 796test thread-19.1 {thread::mutex - command options} { 797 set x [catch {thread::mutex dummy} msg] 798 list $x $msg 799} {1 {bad option "dummy": must be create, destroy, lock, or unlock}} 800 801test thread-19.2 {thread::mutex - more command options} { 802 set x [catch {thread::mutex create -dummy} msg] 803 list $x $msg 804} {1 {wrong # args: should be "thread::mutex create ?-recursive?"}} 805 806 807test thread-19.3 {thread::mutex - create exclusive mutex} { 808 set emutex [thread::mutex create] 809 set c [regexp {mid[0-9]+} $emutex] 810 thread::mutex destroy $emutex 811 set c 812} {1} 813 814test thread-19.4 {thread::mutex - create recursive mutex} { 815 set rmutex [thread::mutex create -recursive] 816 set c [regexp {rid[0-9]+} $rmutex] 817 thread::mutex destroy $rmutex 818 set c 819} {1} 820 821test thread-19.5 {thread::mutex - lock/unlock exclusive mutex} { 822 set emutex [thread::mutex create] 823 thread::mutex lock $emutex 824 thread::mutex unlock $emutex 825 thread::mutex destroy $emutex 826} {} 827 828test thread-19.6 {thread::mutex - deadlock exclusive mutex} { 829 set emutex [thread::mutex create] 830 thread::mutex lock $emutex 831 set x [catch {thread::mutex lock $emutex} msg] 832 thread::mutex unlock $emutex 833 thread::mutex destroy $emutex 834 list $x $msg 835} {1 {locking the same exclusive mutex twice from the same thread}} 836 837test thread-19.7 {thread::mutex - lock invalid mutex} { 838 set x [catch {thread::mutex lock dummy} msg] 839 list $x $msg 840} {1 {no such mutex "dummy"}} 841 842test thread-19.8 {thread::mutex - lock/unlock recursive mutex} { 843 set rmutex [thread::mutex create -recursive] 844 thread::mutex lock $rmutex 845 thread::mutex unlock $rmutex 846 thread::mutex destroy $rmutex 847} {} 848 849test thread-19.9 {thread::mutex - deadlock exclusive mutex} { 850 set rmutex [thread::mutex create -recursive] 851 thread::mutex lock $rmutex 852 set x [catch {thread::mutex lock $rmutex} msg] 853 thread::mutex unlock $rmutex 854 thread::mutex unlock $rmutex 855 thread::mutex destroy $rmutex 856 list $x $msg 857} {0 {}} 858 859test thread-19.10 {thread::mutex - destroy locked exclusive mutex} { 860 set emutex [thread::mutex create] 861 thread::mutex lock $emutex 862 set x [catch {thread::mutex destroy $emutex} msg] 863 thread::mutex unlock $emutex 864 thread::mutex destroy $emutex 865 list $x $msg 866} {1 {mutex is in use}} 867 868test thread-19.11 {thread::mutex - destroy locked recursive mutex} { 869 set rmutex [thread::mutex create -recursive] 870 thread::mutex lock $rmutex 871 set x [catch {thread::mutex destroy $rmutex} msg] 872 thread::mutex unlock $rmutex 873 thread::mutex destroy $rmutex 874 list $x $msg 875} {1 {mutex is in use}} 876 877test thread-19.12 {thread::mutex - lock exclusive between threads} { 878 ThreadReap 879 set tid [thread::create] 880 set emutex [thread::mutex create] 881 thread::send -async $tid [subst { 882 thread::mutex lock $emutex 883 after 2000 884 thread::mutex unlock $emutex 885 }] 886 update 887 after 10 888 set time1 [clock seconds] 889 thread::mutex lock $emutex 890 set time2 [clock seconds] 891 thread::mutex unlock $emutex 892 ThreadReap 893 thread::mutex destroy $emutex 894 expr {($time2 - $time1) >= 1} 895} {1} 896 897test thread-19.13 {thread::mutex - lock args} { 898 set x [catch {thread::mutex lock} msg] 899 list $x $msg 900} {1 {wrong # args: should be "thread::mutex lock mutexHandle"}} 901 902test thread-19.14 {thread::mutex - unlock args} { 903 set x [catch {thread::mutex unlock} msg] 904 list $x $msg 905} {1 {wrong # args: should be "thread::mutex unlock mutexHandle"}} 906 907test thread-19.15 {thread::mutex - destroy args} { 908 set x [catch {thread::mutex destroy} msg] 909 list $x $msg 910} {1 {wrong # args: should be "thread::mutex destroy mutexHandle"}} 911 912test thread-20.0 {thread::rwmutex - args} { 913 set x [catch {thread::rwmutex} msg] 914 list $x $msg 915} {1 {wrong # args: should be "thread::rwmutex option ?args?"}} 916 917test thread-20.1 {thread::rwmutex - command options} { 918 set x [catch {thread::rwmutex dummy} msg] 919 list $x $msg 920} {1 {bad option "dummy": must be create, destroy, rlock, wlock, or unlock}} 921 922test thread-20.2 {thread::rwmutex - more command options} { 923 set x [catch {thread::rwmutex create dummy} msg] 924 list $x $msg 925} {1 {wrong # args: should be "thread::rwmutex create"}} 926 927test thread-20.3 {thread::rwmutex - more command options} { 928 set x [catch {thread::rwmutex create dummy} msg] 929 list $x $msg 930} {1 {wrong # args: should be "thread::rwmutex create"}} 931 932test thread-20.4 {thread::rwmutex - mutex handle} { 933 set rwmutex [thread::rwmutex create] 934 set c [regexp {wid[0-9]+} $rwmutex] 935 thread::rwmutex destroy $rwmutex 936 set c 937} {1} 938 939test thread-20.5 {thread::rwmutex - bad handle} { 940 set x [catch {thread::rwmutex rlock dummy} msg] 941 list $x $msg 942} {1 {no such mutex "dummy"}} 943 944test thread-20.6 {thread::mutex - destroy readlocked mutex} { 945 set rwmutex [thread::rwmutex create] 946 thread::rwmutex rlock $rwmutex 947 set x [catch {thread::rwmutex destroy $rwmutex} msg] 948 thread::rwmutex unlock $rwmutex 949 thread::rwmutex destroy $rwmutex 950 list $x $msg 951} {1 {mutex is in use}} 952 953test thread-20.7 {thread::mutex - destroy writelocked mutex} { 954 set rwmutex [thread::rwmutex create] 955 thread::rwmutex wlock $rwmutex 956 set x [catch {thread::rwmutex destroy $rwmutex} msg] 957 thread::rwmutex unlock $rwmutex 958 thread::rwmutex destroy $rwmutex 959 list $x $msg 960} {1 {mutex is in use}} 961 962test thread-20.8 {thread::rwmutex - readlock mutex} { 963 ThreadReap 964 set tid [thread::create] 965 set rwmutex [thread::rwmutex create] 966 thread::send -async $tid [subst { 967 thread::rwmutex rlock $rwmutex 968 after 1000 969 thread::rwmutex unlock $rwmutex 970 }] 971 update 972 after 10 973 set time1 [clock seconds] 974 thread::rwmutex rlock $rwmutex 975 set time2 [clock seconds] 976 thread::rwmutex unlock $rwmutex 977 ThreadReap 978 thread::rwmutex destroy $rwmutex 979 expr {($time2 - $time1) < 1} 980} {1} 981 982test thread-20.9 {thread::rwmutex - writelock mutex} { 983 ThreadReap 984 set tid [thread::create] 985 set rwmutex [thread::rwmutex create] 986 thread::send -async $tid [subst { 987 thread::rwmutex wlock $rwmutex 988 after 2000 989 thread::rwmutex unlock $rwmutex 990 }] 991 update 992 after 10 993 set time1 [clock seconds] 994 thread::rwmutex rlock $rwmutex 995 set time2 [clock seconds] 996 thread::rwmutex unlock $rwmutex 997 ThreadReap 998 thread::rwmutex destroy $rwmutex 999 expr {($time2 - $time1) >= 1} 1000} {1} 1001 1002test thread-20.10 {thread::rwmutex - readlock args} { 1003 set x [catch {thread::rwmutex rlock} msg] 1004 list $x $msg 1005} {1 {wrong # args: should be "thread::rwmutex rlock mutexHandle"}} 1006 1007test thread-20.11 {thread::rwmutex - writelock args} { 1008 set x [catch {thread::rwmutex wlock} msg] 1009 list $x $msg 1010} {1 {wrong # args: should be "thread::rwmutex wlock mutexHandle"}} 1011 1012test thread-20.12 {thread::rwmutex - unlock args} { 1013 set x [catch {thread::rwmutex unlock} msg] 1014 list $x $msg 1015} {1 {wrong # args: should be "thread::rwmutex unlock mutexHandle"}} 1016 1017test thread-20.13 {thread::rwmutex - destroy args} { 1018 set x [catch {thread::rwmutex destroy} msg] 1019 list $x $msg 1020} {1 {wrong # args: should be "thread::rwmutex destroy mutexHandle"}} 1021 1022test thread-20.14 {thread::mutex - write-lock write-locked mutex} { 1023 set rwmutex [thread::rwmutex create] 1024 thread::rwmutex wlock $rwmutex 1025 set x [catch {thread::rwmutex wlock $rwmutex} msg] 1026 thread::rwmutex unlock $rwmutex 1027 thread::rwmutex destroy $rwmutex 1028 list $x $msg 1029} {1 {write-locking the same read-write mutex twice from the same thread}} 1030 1031test thread-20.15 {thread::mutex - read-lock write-locked mutex} { 1032 set rwmutex [thread::rwmutex create] 1033 thread::rwmutex wlock $rwmutex 1034 set x [catch {thread::rwmutex rlock $rwmutex} msg] 1035 thread::rwmutex unlock $rwmutex 1036 thread::rwmutex destroy $rwmutex 1037 list $x $msg 1038} {1 {read-locking already write-locked mutex from the same thread}} 1039 1040test thread-20.16 {thread::mutex - unlock not locked mutex} { 1041 set rwmutex [thread::rwmutex create] 1042 set x [catch {thread::rwmutex unlock $rwmutex} msg] 1043 thread::rwmutex destroy $rwmutex 1044 list $x $msg 1045} {1 {mutex is not locked}} 1046 1047test thread-21.0 {thread::cond - args} { 1048 set x [catch {thread::cond} msg] 1049 list $x $msg 1050} {1 {wrong # args: should be "thread::cond option ?args?"}} 1051 1052test thread-21.1 {thread::cond - command options} { 1053 set x [catch {thread::cond dummy} msg] 1054 list $x $msg 1055} {1 {bad option "dummy": must be create, destroy, notify, or wait}} 1056 1057test thread-21.2 {thread::cond - more command options} { 1058 set x [catch {thread::cond create dummy} msg] 1059 list $x $msg 1060} {1 {wrong # args: should be "thread::cond create"}} 1061 1062test thread-21.3 {thread::cond - cond handle} { 1063 set cond [thread::cond create] 1064 set c [regexp {cid[0-9]+} $cond] 1065 thread::cond destroy $cond 1066 set c 1067} {1} 1068 1069test thread-21.4 {thread::cond - destroy args} { 1070 set x [catch {thread::cond destroy} msg] 1071 list $x $msg 1072} {1 {wrong # args: should be "thread::cond destroy condHandle ?args?"}} 1073 1074test thread-21.5 {thread::cond - destroy bad handle} { 1075 set x [catch {thread::cond destroy dummy} msg] 1076 list $x $msg 1077} {1 {no such condition variable "dummy"}} 1078 1079test thread-21.6 {thread::cond - notify args} { 1080 set x [catch {thread::cond notify} msg] 1081 list $x $msg 1082} {1 {wrong # args: should be "thread::cond notify condHandle ?args?"}} 1083 1084test thread-21.7 {thread::cond - wait args} { 1085 set x [catch {thread::cond wait} msg] 1086 list $x $msg 1087} {1 {wrong # args: should be "thread::cond wait condHandle ?args?"}} 1088 1089test thread-21.8 {thread::cond - wait bad handle} { 1090 set x [catch {thread::cond wait dummy} msg] 1091 list $x $msg 1092} {1 {no such condition variable "dummy"}} 1093 1094test thread-21.9 {thread::cond - wait no mutex} { 1095 set cond [thread::cond create] 1096 set x [catch {thread::cond wait $cond} msg] 1097 thread::cond destroy $cond 1098 list $x $msg 1099} {1 {wrong # args: should be "thread::cond wait condHandle mutexHandle ?timeout?"}} 1100 1101test thread-21.10 {thread::cond - wait bad mutex} { 1102 set cond [thread::cond create] 1103 set x [catch {thread::cond wait $cond dummy} msg] 1104 thread::cond destroy $cond 1105 list $x $msg 1106} {1 {no such mutex "dummy"}} 1107 1108test thread-21.11 {thread::cond - wait unlocked mutex} { 1109 set cond [thread::cond create] 1110 set emutex [thread::mutex create] 1111 set x [catch {thread::cond wait $cond $emutex} msg] 1112 thread::cond destroy $cond 1113 thread::mutex destroy $emutex 1114 list $x $msg 1115} {1 {mutex not locked or wrong type}} 1116 1117test thread-21.12 {thread::cond - wait locked mutex from wrong thread} { 1118 ThreadReap 1119 set tid [thread::create] 1120 set emutex [thread::mutex create] 1121 set cond [thread::cond create] 1122 thread::mutex lock $emutex 1123 thread::send -async $tid [subst -nocommands { 1124 set code [catch {thread::cond wait $cond $emutex 1000} result] 1125 }] 1126 update 1127 after 20 1128 thread::cond notify $cond 1129 set c [thread::send $tid "set code"] 1130 set r [thread::send $tid "set result"] 1131 ThreadReap 1132 thread::cond destroy $cond 1133 thread::mutex unlock $emutex 1134 thread::mutex destroy $emutex 1135 list $c $r 1136} {1 {mutex not locked or wrong type}} 1137 1138test thread-21.13 {thread::cond - wait recursive mutex} { 1139 set cond [thread::cond create] 1140 set rmutex [thread::mutex create -recursive] 1141 set x [catch {thread::cond wait $cond $rmutex} msg] 1142 thread::cond destroy $cond 1143 thread::mutex destroy $rmutex 1144 list $x $msg 1145} {1 {mutex not locked or wrong type}} 1146 1147test thread-21.14 {thread::cond - wait readwrite mutex} { 1148 set cond [thread::cond create] 1149 set rwmutex [thread::rwmutex create] 1150 set x [catch {thread::cond wait $cond $rwmutex} msg] 1151 thread::cond destroy $cond 1152 thread::rwmutex destroy $rwmutex 1153 list $x $msg 1154} {1 {mutex not locked or wrong type}} 1155 1156test thread-21.15 {thread::cond - regular timed wait} { 1157 ThreadReap 1158 set tid [thread::create] 1159 set emutex [thread::mutex create] 1160 set cond [thread::cond create] 1161 thread::send -async $tid [subst { 1162 thread::mutex lock $emutex 1163 thread::cond wait $cond $emutex 2000 1164 thread::mutex unlock $emutex 1165 set test 1 1166 }] 1167 update 1168 after 10 1169 set time1 [clock seconds] 1170 thread::cond notify $cond 1171 set c [thread::send $tid "info exists test"] 1172 set time2 [clock seconds] 1173 ThreadReap 1174 thread::mutex destroy $emutex 1175 thread::cond destroy $cond 1176 list $c [expr {($time2 - $time1) < 2}] 1177} {1 1} 1178 1179test thread-21.16 {thread::cond - delete waited variable} { 1180 ThreadReap 1181 set tid [thread::create] 1182 set emutex [thread::mutex create] 1183 set cond [thread::cond create] 1184 thread::send -async $tid [subst { 1185 thread::mutex lock $emutex 1186 thread::cond wait $cond $emutex 500 1187 thread::mutex unlock $emutex 1188 }] 1189 update 1190 after 10 1191 set c1 [catch {thread::cond destroy $cond} r1] 1192 thread::cond notify $cond 1193 after 1000 1194 set c2 [catch {thread::cond destroy $cond} r2] 1195 ThreadReap 1196 thread::mutex destroy $emutex 1197 list $c1 $c2 $r1 $r2 1198} {1 0 {condition variable is in use} {}} 1199 1200removeFile dummyForTransfer 1201::tcltest::cleanupTests 1202