summaryrefslogtreecommitdiffstats
path: root/tests/thread.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/thread.test')
-rw-r--r--tests/thread.test56
1 files changed, 25 insertions, 31 deletions
diff --git a/tests/thread.test b/tests/thread.test
index 037766d..15fa2c6 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -10,7 +10,7 @@
# 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.10.18.1 2009/10/18 11:15:10 mistachkin Exp $
+# RCS: @(#) $Id: thread.test,v 1.18.2.1 2009/10/18 11:21:38 mistachkin Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -19,11 +19,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
# Some tests require the testthread command
-set ::tcltest::testConstraints(testthread) \
- [expr {[info commands testthread] != {}}]
-
-if {$::tcltest::testConstraints(testthread)} {
+testConstraint testthread [expr {[info commands testthread] != {}}]
+if {[testConstraint testthread]} {
testthread errorproc ThreadError
proc ThreadError {id info} {
@@ -40,15 +38,12 @@ if {$::tcltest::testConstraints(testthread)} {
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]
@@ -57,7 +52,6 @@ test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
threadReap
set numthreads
} {2}
-
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
threadReap
testthread create {set x 5}
@@ -73,7 +67,6 @@ test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
threadReap
set l
} {1}
-
test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
threadReap
testthread create {testthread exit}
@@ -83,35 +76,28 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
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]
@@ -119,13 +105,11 @@ test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
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}]
@@ -133,12 +117,10 @@ test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
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
@@ -183,7 +165,6 @@ test thread-4.1 {TclThreadSend to self} {testthread} {
}
set x
} {4}
-
test thread-4.2 {TclThreadSend -async} {testthread} {
threadReap
set len [llength [testthread names]]
@@ -198,13 +179,12 @@ test thread-4.2 {TclThreadSend -async} {testthread} {
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
+ 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
@@ -212,23 +192,22 @@ test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
"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 x [catch {testthread send $serverthread {break}} msg]
- set savedErrorInfo $errorInfo
+ 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
+ set savedErrorCode $::errorCode
threadReap
list $x $msg $savedErrorCode
} {1 ERR CODE}
@@ -242,7 +221,6 @@ test thread-5.0 {Joining threads} {testthread} {
threadReap
set res
} {0}
-
test thread-5.1 {Joining threads after the fact} {testthread} {
threadReap
set serverthread [testthread create -joinable]
@@ -252,7 +230,6 @@ test thread-5.1 {Joining threads after the fact} {testthread} {
threadReap
set res
} {0}
-
test thread-5.2 {Try to join a detached thread} {testthread} {
threadReap
set serverthread [testthread create]
@@ -262,6 +239,23 @@ test thread-5.2 {Try to join a detached thread} {testthread} {
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}
+
# cleanup
::tcltest::cleanupTests
return