diff options
author | stanton <stanton> | 1998-09-21 23:39:52 (GMT) |
---|---|---|
committer | stanton <stanton> | 1998-09-21 23:39:52 (GMT) |
commit | 494c2de3a748b449c69ce322a1a741f5a31fd4d5 (patch) | |
tree | c3ece48c0ae3f4ba54787e0e8e729b65752ef3f9 /tests/thread.test | |
parent | 7a698c0488d99c0af42022714638ae1ba2afaa49 (diff) | |
download | tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.zip tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.tar.gz tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.tar.bz2 |
Added contents of Tcl 8.1a2
Diffstat (limited to 'tests/thread.test')
-rw-r--r-- | tests/thread.test | 217 |
1 files changed, 217 insertions, 0 deletions
diff --git a/tests/thread.test b/tests/thread.test new file mode 100644 index 0000000..a68f54e --- /dev/null +++ b/tests/thread.test @@ -0,0 +1,217 @@ +# Commands covered: (test)thread +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) thread.test 1.4 98/02/19 11:53:53 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[info command testthread] == ""} { + return +} + +set mainthread [testthread names] +proc ThreadReap {} { + global mainthread + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != $mainthread} { + catch {testthread send -async $tid {testthread exit}} + update + } + } + } + testthread errorproc ThreadError + return [llength [testthread names]] +} +testthread errorproc ThreadError +proc ThreadError {id info} { + global threadError + set threadError $info +} +proc ThreadNullError {id info} { + # ignore +} + +test thread-1.1 {Tcl_ThreadObjCmd: no args} { + list [catch {testthread} msg] $msg +} {1 {wrong # args: should be "testthread option ?args?"}} + +test thread-1.2 {Tcl_ThreadObjCmd: bad option} { + list [catch {testthread foo} msg] $msg +} {1 {bad option "foo": must be create, exit, id, names, send, wait, or errorproc}} + +test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} { + list [catch {testthread names} mainthread] [llength $mainthread] +} {0 1} + +test thread-1.4 {Tcl_ThreadObjCmd: thread create } { + set serverthread [testthread create] + update + set numthreads [llength [testthread names]] +} {2} +ThreadReap + +test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} { + testthread create {set x 5} + foreach try {0 1 2 4 5 6} { + update + set l [llength [testthread names]] + if {$l == 1} { + break + } + } + set l +} {1} +ThreadReap + +test thread-1.6 {Tcl_ThreadObjCmd: thread exit} { + testthread create {testthread exit} + update + llength [testthread names] +} {1} +ThreadReap + +test thread-1.7 {Tcl_ThreadObjCmd: thread id args} { + 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} { + string compare [testthread id] $mainthread +} {0} + +test thread-1.9 {Tcl_ThreadObjCmd: thread names args} { + 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} { + string compare [testthread names] $mainthread +} {0} + +test thread-1.11 {Tcl_ThreadObjCmd: send args} { + 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} { + 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} { + set serverthread [testthread create] + set five [testthread send $serverthread {set x 5}] + ThreadReap + set five +} 5 + +test thread-1.14 {Tcl_ThreadObjCmd: send bad id} { + set tid [expr $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} { + set serverthread [testthread create {set z 5 ; testthread wait}] + set five [testthread send $serverthread {set z}] + ThreadReap + set five +} 5 + +test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} { + 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 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} { + catch {unset tid} + foreach t {0 1 2} { + upvar #0 t$t tid + set tid [testthread create] + } + ThreadReap +} 1 + +test thread-3.1 {TclThreadList} { + catch {unset tid} + set mainthread [testthread names] + set l1 {} + foreach t {0 1 2} { + lappend l1 [testthread create] + } + set l2 [testthread names] + list $l1 $l2 + set c [string compare [lsort -integer [concat $mainthread $l1]] [lsort -integer $l2]] + ThreadReap + set c +} 0 + +test thread-4.1 {TclThreadSend to self} { + catch {unset x} + testthread send [testthread id] { + set x 4 + } + set x +} {4} + +test thread-4.1 {TclThreadSend -async} { + set mainthread [testthread names] + set serverthread [testthread create] + testthread send -async $serverthread { + after 1000 + testthread exit + } + set two [llength [testthread names]] + after 1500 {set done 1} + vwait done + list [llength [testthread names]] $two +} {1 2} + +test thread-4.2 {TclThreadSend preserve errorInfo} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {set undef}} msg] + list $x $msg $errorInfo +} {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}"}} +ThreadReap + +test thread-4.3 {TclThreadSend preserve code} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {break}} msg] + list $x $msg $errorInfo +} {3 {} {}} +ThreadReap + +test thread-4.4 {TclThreadSend preserve errorCode} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg] + list $x $msg $errorCode +} {1 ERR CODE} +ThreadReap + |