286 lines
8.5 KiB
Plaintext
286 lines
8.5 KiB
Plaintext
# 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.
|
|
|
|
if {[lsearch [namespace children] ::tcltest] == -1} {
|
|
package require tcltest
|
|
namespace import -force ::tcltest::*
|
|
}
|
|
|
|
# Some tests require the testthread command
|
|
|
|
testConstraint testthread [expr {[info commands testthread] != {}}]
|
|
|
|
if {[testConstraint testthread]} {
|
|
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} {testthread} {
|
|
list [catch {testthread} msg] $msg
|
|
} {1 {wrong # args: should be "testthread option ?args?"}}
|
|
test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
|
|
list [catch {testthread foo} msg] $msg
|
|
} {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
|
|
test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
|
|
list [threadReap] [llength [testthread names]]
|
|
} {1 1}
|
|
test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
|
|
threadReap
|
|
set serverthread [testthread create]
|
|
update
|
|
set numthreads [llength [testthread names]]
|
|
threadReap
|
|
set numthreads
|
|
} {2}
|
|
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
|
|
threadReap
|
|
testthread create {set x 5}
|
|
foreach try {0 1 2 4 5 6} {
|
|
# Try various ways to yield
|
|
update
|
|
after 10
|
|
set l [llength [testthread names]]
|
|
if {$l == 1} {
|
|
break
|
|
}
|
|
}
|
|
threadReap
|
|
set l
|
|
} {1}
|
|
test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
|
|
threadReap
|
|
testthread create {testthread exit}
|
|
update
|
|
after 10
|
|
set result [llength [testthread names]]
|
|
threadReap
|
|
set result
|
|
} {1}
|
|
test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
|
|
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} {testthread} {
|
|
string compare [testthread id] $::tcltest::mainThread
|
|
} {0}
|
|
test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
|
|
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} {testthread} {
|
|
string compare [testthread names] $::tcltest::mainThread
|
|
} {0}
|
|
test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
|
|
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} {testthread} {
|
|
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} {testthread} {
|
|
threadReap
|
|
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} {testthread} {
|
|
set tid [expr $::tcltest::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} {testthread} {
|
|
threadReap
|
|
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} {testthread} {
|
|
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} {
|
|
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} {testthread} {
|
|
threadReap
|
|
catch {unset tid}
|
|
foreach t {0 1 2} {
|
|
upvar #0 t$t tid
|
|
set tid [testthread create]
|
|
}
|
|
threadReap
|
|
} 1
|
|
|
|
test thread-3.1 {TclThreadList} {testthread} {
|
|
threadReap
|
|
catch {unset tid}
|
|
set len [llength [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 $::tcltest::mainThread $l1]] \
|
|
[lsort -integer $l2]]
|
|
threadReap
|
|
list $len $c
|
|
} {1 0}
|
|
|
|
test thread-4.1 {TclThreadSend to self} {testthread} {
|
|
catch {unset x}
|
|
testthread send [testthread id] {
|
|
set x 4
|
|
}
|
|
set x
|
|
} {4}
|
|
test thread-4.2 {TclThreadSend -async} {testthread} {
|
|
threadReap
|
|
set len [llength [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
|
|
threadReap
|
|
list $len [llength [testthread names]] $two
|
|
} {1 1 2}
|
|
test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
|
|
threadReap
|
|
set len [llength [testthread names]]
|
|
set serverthread [testthread create]
|
|
set x [catch {testthread send $serverthread {set undef}} msg]
|
|
set savedErrorInfo $::errorInfo
|
|
threadReap
|
|
list $len $x $msg $savedErrorInfo
|
|
} {1 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}"}}
|
|
test thread-4.4 {TclThreadSend preserve code} {testthread} {
|
|
threadReap
|
|
set len [llength [testthread names]]
|
|
set serverthread [testthread create]
|
|
set ::errorInfo {}
|
|
set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg]
|
|
set savedErrorInfo $::errorInfo
|
|
threadReap
|
|
list $len $x $msg $savedErrorInfo
|
|
} {1 3 {} {}}
|
|
test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
|
|
threadReap
|
|
set ::tcltest::mainThread [testthread names]
|
|
set serverthread [testthread create]
|
|
set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
|
|
set savedErrorCode $::errorCode
|
|
threadReap
|
|
list $x $msg $savedErrorCode
|
|
} {1 ERR CODE}
|
|
|
|
|
|
test thread-5.0 {Joining threads} {testthread} {
|
|
threadReap
|
|
set serverthread [testthread create -joinable]
|
|
testthread send -async $serverthread {after 1000 ; testthread exit}
|
|
set res [testthread join $serverthread]
|
|
threadReap
|
|
set res
|
|
} {0}
|
|
test thread-5.1 {Joining threads after the fact} {testthread} {
|
|
threadReap
|
|
set serverthread [testthread create -joinable]
|
|
testthread send -async $serverthread {testthread exit}
|
|
after 2000
|
|
set res [testthread join $serverthread]
|
|
threadReap
|
|
set res
|
|
} {0}
|
|
test thread-5.2 {Try to join a detached thread} {testthread} {
|
|
threadReap
|
|
set serverthread [testthread create]
|
|
testthread send -async $serverthread {after 1000 ; testthread exit}
|
|
catch {set res [testthread join $serverthread]} msg
|
|
threadReap
|
|
lrange $msg 0 2
|
|
} {cannot join thread}
|
|
|
|
test thread-6.1 {freeing very large object trees in a thread} testthread {
|
|
# conceptual duplicate of obj-32.1
|
|
threadReap
|
|
set serverthread [testthread create -joinable]
|
|
testthread send -async $serverthread {
|
|
set x {}
|
|
for {set i 0} {$i<100000} {incr i} {
|
|
set x [list $x {}]
|
|
}
|
|
unset x
|
|
testthread exit
|
|
}
|
|
catch {set res [testthread join $serverthread]} msg
|
|
threadReap
|
|
set res
|
|
} {0}
|
|
|
|
test thread-8.1 {threaded fork stress} -constraints {thread} -setup {
|
|
unset -nocomplain ::threadCount ::execCount ::threads ::thread
|
|
set ::threadCount 10
|
|
set ::execCount 10
|
|
} -body {
|
|
set ::threads [list]
|
|
for {set i 0} {$i < $::threadCount} {incr i} {
|
|
lappend ::threads [thread::create -joinable [string map \
|
|
[list %execCount% $::execCount] {
|
|
proc execLs {} {
|
|
if {$::tcl_platform(platform) eq "windows"} then {
|
|
return [exec $::env(COMSPEC) /c DIR]
|
|
} else {
|
|
return [exec /bin/ls]
|
|
}
|
|
}
|
|
set j {%execCount%}; while {[incr j -1]} {execLs}
|
|
}]]
|
|
}
|
|
foreach ::thread $::threads {
|
|
thread::join $::thread
|
|
}
|
|
} -cleanup {
|
|
unset -nocomplain ::threadCount ::execCount ::threads ::thread
|
|
} -result {}
|
|
|
|
# cleanup
|
|
::tcltest::cleanupTests
|
|
return
|