os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/thread.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/thread.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,264 @@
1.4 +# Commands covered: (test)thread
1.5 +#
1.6 +# This file contains a collection of tests for one or more of the Tcl
1.7 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.8 +# generates output for errors. No output means no errors were found.
1.9 +#
1.10 +# Copyright (c) 1996 Sun Microsystems, Inc.
1.11 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.12 +#
1.13 +# See the file "license.terms" for information on usage and redistribution
1.14 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 +#
1.16 +# RCS: @(#) $Id: thread.test,v 1.10 2000/05/02 22:02:36 kupries Exp $
1.17 +
1.18 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.19 + package require tcltest
1.20 + namespace import -force ::tcltest::*
1.21 +}
1.22 +
1.23 +# Some tests require the testthread command
1.24 +
1.25 +set ::tcltest::testConstraints(testthread) \
1.26 + [expr {[info commands testthread] != {}}]
1.27 +
1.28 +if {$::tcltest::testConstraints(testthread)} {
1.29 +
1.30 + testthread errorproc ThreadError
1.31 +
1.32 + proc ThreadError {id info} {
1.33 + global threadError
1.34 + set threadError $info
1.35 + }
1.36 +
1.37 + proc ThreadNullError {id info} {
1.38 + # ignore
1.39 + }
1.40 +}
1.41 +
1.42 +
1.43 +test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
1.44 + list [catch {testthread} msg] $msg
1.45 +} {1 {wrong # args: should be "testthread option ?args?"}}
1.46 +
1.47 +test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
1.48 + list [catch {testthread foo} msg] $msg
1.49 +} {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
1.50 +
1.51 +test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
1.52 + list [threadReap] [llength [testthread names]]
1.53 +} {1 1}
1.54 +
1.55 +test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
1.56 + threadReap
1.57 + set serverthread [testthread create]
1.58 + update
1.59 + set numthreads [llength [testthread names]]
1.60 + threadReap
1.61 + set numthreads
1.62 +} {2}
1.63 +
1.64 +test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
1.65 + threadReap
1.66 + testthread create {set x 5}
1.67 + foreach try {0 1 2 4 5 6} {
1.68 + # Try various ways to yield
1.69 + update
1.70 + after 10
1.71 + set l [llength [testthread names]]
1.72 + if {$l == 1} {
1.73 + break
1.74 + }
1.75 + }
1.76 + threadReap
1.77 + set l
1.78 +} {1}
1.79 +
1.80 +test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
1.81 + threadReap
1.82 + testthread create {testthread exit}
1.83 + update
1.84 + after 10
1.85 + set result [llength [testthread names]]
1.86 + threadReap
1.87 + set result
1.88 +} {1}
1.89 +
1.90 +test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
1.91 + set x [catch {testthread id x} msg]
1.92 + list $x $msg
1.93 +} {1 {wrong # args: should be "testthread id"}}
1.94 +
1.95 +test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} {
1.96 + string compare [testthread id] $::tcltest::mainThread
1.97 +} {0}
1.98 +
1.99 +test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
1.100 + set x [catch {testthread names x} msg]
1.101 + list $x $msg
1.102 +} {1 {wrong # args: should be "testthread names"}}
1.103 +
1.104 +test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} {
1.105 + string compare [testthread names] $::tcltest::mainThread
1.106 +} {0}
1.107 +
1.108 +test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
1.109 + set x [catch {testthread send} msg]
1.110 + list $x $msg
1.111 +} {1 {wrong # args: should be "testthread send ?-async? id script"}}
1.112 +
1.113 +test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
1.114 + set x [catch {testthread send abc command} msg]
1.115 + list $x $msg
1.116 +} {1 {expected integer but got "abc"}}
1.117 +
1.118 +test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
1.119 + threadReap
1.120 + set serverthread [testthread create]
1.121 + set five [testthread send $serverthread {set x 5}]
1.122 + threadReap
1.123 + set five
1.124 +} 5
1.125 +
1.126 +test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
1.127 + set tid [expr $::tcltest::mainThread + 10]
1.128 + set x [catch {testthread send $tid {set x 5}} msg]
1.129 + list $x $msg
1.130 +} {1 {invalid thread id}}
1.131 +
1.132 +test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
1.133 + threadReap
1.134 + set serverthread [testthread create {set z 5 ; testthread wait}]
1.135 + set five [testthread send $serverthread {set z}]
1.136 + threadReap
1.137 + set five
1.138 +} 5
1.139 +
1.140 +test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
1.141 + set x [catch {testthread errorproc foo bar} msg]
1.142 + list $x $msg
1.143 +} {1 {wrong # args: should be "testthread errorproc proc"}}
1.144 +
1.145 +test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
1.146 + testthread errorproc foo
1.147 + testthread errorproc ThreadError
1.148 +} {}
1.149 +
1.150 +# The tests above also cover:
1.151 +# TclCreateThread, except when pthread_create fails
1.152 +# NewThread, safe and regular
1.153 +# ThreadErrorProc, except for printing to standard error
1.154 +
1.155 +test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
1.156 + threadReap
1.157 + catch {unset tid}
1.158 + foreach t {0 1 2} {
1.159 + upvar #0 t$t tid
1.160 + set tid [testthread create]
1.161 + }
1.162 + threadReap
1.163 +} 1
1.164 +
1.165 +test thread-3.1 {TclThreadList} {testthread} {
1.166 + threadReap
1.167 + catch {unset tid}
1.168 + set len [llength [testthread names]]
1.169 + set l1 {}
1.170 + foreach t {0 1 2} {
1.171 + lappend l1 [testthread create]
1.172 + }
1.173 + set l2 [testthread names]
1.174 + list $l1 $l2
1.175 + set c [string compare \
1.176 + [lsort -integer [concat $::tcltest::mainThread $l1]] \
1.177 + [lsort -integer $l2]]
1.178 + threadReap
1.179 + list $len $c
1.180 +} {1 0}
1.181 +
1.182 +test thread-4.1 {TclThreadSend to self} {testthread} {
1.183 + catch {unset x}
1.184 + testthread send [testthread id] {
1.185 + set x 4
1.186 + }
1.187 + set x
1.188 +} {4}
1.189 +
1.190 +test thread-4.2 {TclThreadSend -async} {testthread} {
1.191 + threadReap
1.192 + set len [llength [testthread names]]
1.193 + set serverthread [testthread create]
1.194 + testthread send -async $serverthread {
1.195 + after 1000
1.196 + testthread exit
1.197 + }
1.198 + set two [llength [testthread names]]
1.199 + after 1500 {set done 1}
1.200 + vwait done
1.201 + threadReap
1.202 + list $len [llength [testthread names]] $two
1.203 +} {1 1 2}
1.204 +
1.205 +test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
1.206 + threadReap
1.207 + set len [llength [testthread names]]
1.208 + set serverthread [testthread create]
1.209 + set x [catch {testthread send $serverthread {set undef}} msg]
1.210 + threadReap
1.211 + list $len $x $msg $errorInfo
1.212 +} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
1.213 + while executing
1.214 +"set undef"
1.215 + invoked from within
1.216 +"testthread send $serverthread {set undef}"}}
1.217 +
1.218 +test thread-4.4 {TclThreadSend preserve code} {testthread} {
1.219 + threadReap
1.220 + set len [llength [testthread names]]
1.221 + set serverthread [testthread create]
1.222 + set x [catch {testthread send $serverthread {break}} msg]
1.223 + threadReap
1.224 + list $len $x $msg $errorInfo
1.225 +} {1 3 {} {}}
1.226 +
1.227 +test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
1.228 + threadReap
1.229 + set ::tcltest::mainThread [testthread names]
1.230 + set serverthread [testthread create]
1.231 + set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
1.232 + threadReap
1.233 + list $x $msg $errorCode
1.234 +} {1 ERR CODE}
1.235 +
1.236 +
1.237 +test thread-5.0 {Joining threads} {testthread} {
1.238 + threadReap
1.239 + set serverthread [testthread create -joinable]
1.240 + testthread send -async $serverthread {after 1000 ; testthread exit}
1.241 + set res [testthread join $serverthread]
1.242 + threadReap
1.243 + set res
1.244 +} {0}
1.245 +
1.246 +test thread-5.1 {Joining threads after the fact} {testthread} {
1.247 + threadReap
1.248 + set serverthread [testthread create -joinable]
1.249 + testthread send -async $serverthread {testthread exit}
1.250 + after 2000
1.251 + set res [testthread join $serverthread]
1.252 + threadReap
1.253 + set res
1.254 +} {0}
1.255 +
1.256 +test thread-5.2 {Try to join a detached thread} {testthread} {
1.257 + threadReap
1.258 + set serverthread [testthread create]
1.259 + testthread send -async $serverthread {after 1000 ; testthread exit}
1.260 + catch {set res [testthread join $serverthread]} msg
1.261 + threadReap
1.262 + lrange $msg 0 2
1.263 +} {cannot join thread}
1.264 +
1.265 +# cleanup
1.266 +::tcltest::cleanupTests
1.267 +return