sl@0: # Commands covered:  (test)thread
sl@0: #
sl@0: # This file contains a collection of tests for one or more of the Tcl
sl@0: # built-in commands.  Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors.  No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1996 Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: thread.test,v 1.10 2000/05/02 22:02:36 kupries Exp $
sl@0: 
sl@0: if {[lsearch [namespace children] ::tcltest] == -1} {
sl@0:     package require tcltest
sl@0:     namespace import -force ::tcltest::*
sl@0: }
sl@0: 
sl@0: # Some tests require the testthread command
sl@0: 
sl@0: set ::tcltest::testConstraints(testthread) \
sl@0: 	[expr {[info commands testthread] != {}}]
sl@0: 
sl@0: if {$::tcltest::testConstraints(testthread)} {
sl@0: 
sl@0:     testthread errorproc ThreadError
sl@0: 
sl@0:     proc ThreadError {id info} {
sl@0: 	global threadError
sl@0: 	set threadError $info
sl@0:     }
sl@0: 
sl@0:     proc ThreadNullError {id info} {
sl@0: 	# ignore
sl@0:     }
sl@0: }
sl@0: 
sl@0: 
sl@0: test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
sl@0:     list [catch {testthread} msg] $msg
sl@0: } {1 {wrong # args: should be "testthread option ?args?"}}
sl@0: 
sl@0: test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
sl@0:     list [catch {testthread foo} msg] $msg
sl@0: } {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
sl@0: 
sl@0: test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
sl@0:     list [threadReap] [llength [testthread names]]
sl@0: } {1 1}
sl@0: 
sl@0: test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
sl@0:     threadReap
sl@0:     set serverthread [testthread create]
sl@0:     update
sl@0:     set numthreads [llength [testthread names]]
sl@0:     threadReap
sl@0:     set numthreads
sl@0: } {2}
sl@0: 
sl@0: test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
sl@0:     threadReap
sl@0:     testthread create {set x 5}
sl@0:     foreach try {0 1 2 4 5 6} {
sl@0: 	# Try various ways to yield
sl@0: 	update
sl@0: 	after 10
sl@0: 	set l [llength [testthread names]]
sl@0: 	if {$l == 1} {
sl@0: 	    break
sl@0: 	}
sl@0:     }
sl@0:     threadReap
sl@0:     set l
sl@0: } {1}
sl@0: 
sl@0: test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
sl@0:     threadReap
sl@0:     testthread create {testthread exit}
sl@0:     update
sl@0:     after 10
sl@0:     set result [llength [testthread names]]
sl@0:     threadReap
sl@0:     set result
sl@0: } {1}
sl@0: 
sl@0: test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
sl@0:     set x [catch {testthread id x} msg]
sl@0:     list $x $msg
sl@0: } {1 {wrong # args: should be "testthread id"}}
sl@0: 
sl@0: test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} {
sl@0:     string compare [testthread id] $::tcltest::mainThread
sl@0: } {0}
sl@0: 
sl@0: test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
sl@0:     set x [catch {testthread names x} msg]
sl@0:     list $x $msg
sl@0: } {1 {wrong # args: should be "testthread names"}}
sl@0: 
sl@0: test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} {
sl@0:     string compare [testthread names] $::tcltest::mainThread
sl@0: } {0}
sl@0: 
sl@0: test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
sl@0:     set x [catch {testthread send} msg]
sl@0:     list $x $msg
sl@0: } {1 {wrong # args: should be "testthread send ?-async? id script"}}
sl@0: 
sl@0: test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
sl@0:     set x [catch {testthread send abc command} msg]
sl@0:     list $x $msg
sl@0: } {1 {expected integer but got "abc"}}
sl@0: 
sl@0: test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
sl@0:     threadReap
sl@0:     set serverthread [testthread create]
sl@0:     set five [testthread send $serverthread {set x 5}]
sl@0:     threadReap
sl@0:     set five
sl@0: } 5
sl@0: 
sl@0: test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
sl@0:     set tid [expr $::tcltest::mainThread + 10]
sl@0:     set x [catch {testthread send $tid {set x 5}} msg]
sl@0:     list $x $msg
sl@0: } {1 {invalid thread id}}
sl@0: 
sl@0: test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
sl@0:     threadReap
sl@0:     set serverthread [testthread create {set z 5 ; testthread wait}]
sl@0:     set five [testthread send $serverthread {set z}]
sl@0:     threadReap
sl@0:     set five
sl@0: } 5
sl@0: 
sl@0: test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
sl@0:     set x [catch {testthread errorproc foo bar} msg]
sl@0:     list $x $msg
sl@0: } {1 {wrong # args: should be "testthread errorproc proc"}}
sl@0: 
sl@0: test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
sl@0:     testthread errorproc foo
sl@0:     testthread errorproc ThreadError
sl@0: } {}
sl@0: 
sl@0: # The tests above also cover:
sl@0: # TclCreateThread, except when pthread_create fails
sl@0: # NewThread, safe and regular
sl@0: # ThreadErrorProc, except for printing to standard error
sl@0: 
sl@0: test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
sl@0:     threadReap
sl@0:     catch {unset tid}
sl@0:     foreach t {0 1 2} {
sl@0: 	upvar #0 t$t tid
sl@0: 	set tid [testthread create]
sl@0:     }
sl@0:     threadReap
sl@0: } 1
sl@0: 
sl@0: test thread-3.1 {TclThreadList} {testthread} {
sl@0:     threadReap
sl@0:     catch {unset tid}
sl@0:     set len [llength [testthread names]]
sl@0:     set l1  {}
sl@0:     foreach t {0 1 2} {
sl@0: 	lappend l1 [testthread create]
sl@0:     }
sl@0:     set l2 [testthread names]
sl@0:     list $l1 $l2
sl@0:     set c [string compare \
sl@0: 	    [lsort -integer [concat $::tcltest::mainThread $l1]] \
sl@0: 	    [lsort -integer $l2]]
sl@0:     threadReap
sl@0:     list $len $c
sl@0: } {1 0}
sl@0: 
sl@0: test thread-4.1 {TclThreadSend to self} {testthread} {
sl@0:     catch {unset x}
sl@0:     testthread send [testthread id] {
sl@0: 	set x 4
sl@0:     }
sl@0:     set x
sl@0: } {4}
sl@0: 
sl@0: test thread-4.2 {TclThreadSend -async} {testthread} {
sl@0:     threadReap
sl@0:     set len [llength [testthread names]]
sl@0:     set serverthread [testthread create]
sl@0:     testthread send -async $serverthread {
sl@0: 	after 1000
sl@0: 	testthread exit
sl@0:     }
sl@0:     set two [llength [testthread names]]
sl@0:     after 1500 {set done 1}
sl@0:     vwait done
sl@0:     threadReap
sl@0:     list $len [llength [testthread names]] $two
sl@0: } {1 1 2}
sl@0: 
sl@0: test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
sl@0:     threadReap
sl@0:     set len [llength [testthread names]]
sl@0:     set serverthread [testthread create]
sl@0:     set x [catch {testthread send $serverthread {set undef}} msg]
sl@0:     threadReap
sl@0:     list $len $x $msg $errorInfo
sl@0: } {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
sl@0:     while executing
sl@0: "set undef"
sl@0:     invoked from within
sl@0: "testthread send $serverthread {set undef}"}}
sl@0: 
sl@0: test thread-4.4 {TclThreadSend preserve code} {testthread} {
sl@0:     threadReap
sl@0:     set len [llength [testthread names]]
sl@0:     set serverthread [testthread create]
sl@0:     set x [catch {testthread send $serverthread {break}} msg]
sl@0:     threadReap
sl@0:     list $len $x $msg $errorInfo
sl@0: } {1 3 {} {}}
sl@0: 
sl@0: test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
sl@0:     threadReap
sl@0:     set ::tcltest::mainThread [testthread names]
sl@0:     set serverthread [testthread create]
sl@0:     set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
sl@0:     threadReap
sl@0:     list $x $msg $errorCode
sl@0: } {1 ERR CODE}
sl@0: 
sl@0: 
sl@0: test thread-5.0 {Joining threads} {testthread} {
sl@0:     threadReap
sl@0:     set serverthread [testthread create -joinable]
sl@0:     testthread send -async $serverthread {after 1000 ; testthread exit}
sl@0:     set res [testthread join $serverthread]
sl@0:     threadReap
sl@0:     set res
sl@0: } {0}
sl@0: 
sl@0: test thread-5.1 {Joining threads after the fact} {testthread} {
sl@0:     threadReap
sl@0:     set serverthread [testthread create -joinable]
sl@0:     testthread send -async $serverthread {testthread exit}
sl@0:     after 2000
sl@0:     set res [testthread join $serverthread]
sl@0:     threadReap
sl@0:     set res
sl@0: } {0}
sl@0: 
sl@0: test thread-5.2 {Try to join a detached thread} {testthread} {
sl@0:     threadReap
sl@0:     set serverthread [testthread create]
sl@0:     testthread send -async $serverthread {after 1000 ; testthread exit}
sl@0:     catch {set res [testthread join $serverthread]} msg
sl@0:     threadReap
sl@0:     lrange $msg 0 2
sl@0: } {cannot join thread}
sl@0: 
sl@0: # cleanup
sl@0: ::tcltest::cleanupTests
sl@0: return