summaryrefslogtreecommitdiffstats
path: root/tests/thread.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/thread.test')
-rw-r--r--tests/thread.test240
1 files changed, 240 insertions, 0 deletions
diff --git a/tests/thread.test b/tests/thread.test
new file mode 100644
index 0000000..b3051ed
--- /dev/null
+++ b/tests/thread.test
@@ -0,0 +1,240 @@
+# Commands covered: (test)thread
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: thread.test,v 1.2 1999/04/16 00:47:35 stanton Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+if {[info command testthread] == ""} {
+ puts "skipping: tests require the testthread command"
+ ::tcltest::cleanupTests
+ 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} {
+ # Try various ways to yeild
+ update
+ after 10
+ 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
+ after 10
+ 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
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+