diff options
Diffstat (limited to 'tests/ioCmd.test')
-rw-r--r-- | tests/ioCmd.test | 179 |
1 files changed, 178 insertions, 1 deletions
diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 5a0d1ba..82c9645 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.41 2008/04/21 16:26:39 dgp Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.42 2008/04/24 18:51:01 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -779,6 +779,11 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. +# Stored in a script so that the threads and interpreters needing this +# code do not need their own copy but can access this variable. + +set helperscript { + proc note {item} {global res; lappend res $item; return} proc track {} {upvar args item; note $item; return} proc notes {items} {foreach i $items {note $i}} @@ -806,6 +811,10 @@ proc onfinal {} { if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } +} + +# Set everything up in the main thread. +eval $helperscript # --- --- --- --------- --------- --------- # method finalize @@ -1829,6 +1838,90 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { rename dummy {} } -returnCodes error -result {can not find reflected channel named "rc*"} +# --- === *** ########################### +# 'Pull the rug' tests. Create channel in a interpreter A, move to +# other interpreter B, destroy the origin interpreter (A) before or +# during access from B. Must not crash, must return proper errors. + +test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { + + set ida [interp create];#puts <<$ida>> + set idb [interp create];#puts <<$idb>> + + # Magic to get the test* commands in the slaves + load {} Tcltest $ida + load {} Tcltest $idb + + # Set up channel in interpreter + interp eval $ida $helperscript + set chan [interp eval $ida { + proc foo {args} {oninit seek; onfinal; track; return} + set chan [chan create {r w} foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd interpreter. + interp eval $ida [list testchannel cut $chan] + interp eval $idb [list testchannel splice $chan] + + # Kill origin interpreter, then access channel from 2nd interpreter. + interp delete $ida + + set res {} + lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg + lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg + lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg + lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg + lappend res [catch {interp eval $idb [list close $chan]} msg] $msg + set res + +} -constraints {testchannel} \ + -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} + +test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body { + + set ida [interp create];#puts <<$ida>> + set idb [interp create];#puts <<$idb>> + + # Magic to get the test* commands in the slaves + load {} Tcltest $ida + load {} Tcltest $idb + + # Set up channel in thread + set chan [interp eval $ida $helperscript] + set chan [interp eval $ida { + proc foo {args} { + oninit; onfinal; track; + # destroy interpreter during channel access + # Actually not possible for an interp to destory itself. + interp delete {} + return} + set chan [chan create {r w} foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd thread. + interp eval $ida [list testchannel cut $chan] + interp eval $idb [list testchannel splice $chan] + + # Run access from interpreter B, this will give us a synchronous + # response. + + interp eval $idb [list set chan $chan] + interp eval $idb [list set mid $tcltest::mainThread] + set res [interp eval $idb { + # wait a bit, give the main thread the time to start its event + # loop to wait for the response from B + after 2000 + catch { puts $chan shoo } res + set res + }] + set res +} -constraints {testchannel impossible} \ + -result {Owner lost} + # ### ### ### ######### ######### ######### ## Same tests as above, but exercising the code forwarding and ## receiving driver operations to the originator thread. @@ -3217,6 +3310,90 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { } -constraints {testchannel testthread} \ -result {{can not find reflected channel named "rc*"}} +# --- === *** ########################### +# 'Pull the rug' tests. Create channel in a thread A, move to other +# thread B, destroy the origin thread (A) before or during access from +# B. Must not crash, must return proper errors. + +test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { + + #puts <<$tcltest::mainThread>>main + set tida [testthread create];#puts <<$tida>> + set tidb [testthread create];#puts <<$tidb>> + + # Set up channel in thread + testthread send $tida $helperscript + set chan [testthread send $tida { + proc foo {args} {oninit seek; onfinal; track; return} + set chan [chan create {r w} foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd thread. + testthread send $tida [list testchannel cut $chan] + testthread send $tidb [list testchannel splice $chan] + + # Kill origin thread, then access channel from 2nd thread. + testthread send -async $tida {testthread exit} + after 100 + + set res {} + lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg + + lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg + tcltest::threadReap + set res + +} -constraints {testchannel testthread} \ + -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} + +test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { + + #puts <<$tcltest::mainThread>>main + set tida [testthread create];#puts <<$tida>> + set tidb [testthread create];#puts <<$tidb>> + + # Set up channel in thread + set chan [testthread send $tida $helperscript] + set chan [testthread send $tida { + proc foo {args} { + oninit; onfinal; track; + # destroy thread during channel access + testthread exit + return} + set chan [chan create {r w} foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd thread. + testthread send $tida [list testchannel cut $chan] + testthread send $tidb [list testchannel splice $chan] + + # Run access from thread B, wait for response from A (A is not + # using event loop at this point, so the event pile up in the + # queue. + + testthread send $tidb [list set chan $chan] + testthread send $tidb [list set mid $tcltest::mainThread] + testthread send -async $tidb { + # wait a bit, give the main thread the time to start its event + # loop to wait for the response from B + after 2000 + catch { puts $chan shoo } res + testthread send -async $mid [list set ::res $res] + } + vwait ::res + + tcltest::threadReap + set res +} -constraints {testchannel testthread} \ + -result {Owner lost} + # ### ### ### ######### ######### ######### # ### ### ### ######### ######### ######### |