diff options
Diffstat (limited to 'tests/thread.test')
| -rw-r--r-- | tests/thread.test | 56 |
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 |