diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | tests/ioCmd.test | 114 |
2 files changed, 122 insertions, 0 deletions
@@ -1,3 +1,11 @@ +2012-05-09 Andreas Kupries <andreask@activestate.com> + + * tests/ioCmd.test [Bug 3522560]: Added a test which crashes the + core if it were not disabled as knownBug. For a reflected channel + transfered to a different thread the [chan postevent] run in the + handler thread tries to execute the owner threads's fileevent + scripts by itself, wrongly reaching across thread boundaries. + 2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: Properly close nonblocking channels even when diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 1d34861..17c4952 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2616,6 +2616,120 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to } -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \ -constraints {testchannel thread knownBug} +test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ + -constraints {testchannel thread knownBug} -setup { + # This test exposes how the execution of postevent in the handler thread causes + # a crash if we are not properly injecting the events into the owning thread instead. + # With the injection the test will simply complete without crash. + + set beat 10000 + set drive 999 + set data ...---... + + proc LOG {text} { + #puts stderr "[thread::id]: $text" + return + } + + proc POST {hi} { + LOG "-> [info level 0]" + chan postevent $hi read + LOG "<- [info level 0]" + + set ::timer [after $::drive [info level 0]] + return + } + + proc HANDLER {op ch args} { + lappend ::res [lrange [info level 0] 1 end] + LOG "-> [info level 0]" + set ret {} + switch -glob -- $op { + init* {set ret {initialize finalize watch read}} + watch { + set l [lindex $args 0] + if {[llength $l]} { + set ::timer [after $::drive [list POST $ch]] + } else { + after cancel $::timer + } + } + finalize { + catch { after cancel $::timer } + after 500 {set ::forever now} + } + read { + set ret $::data + set ::data {} ; # Next is EOF. + } + } + LOG "<- [info level 0] : $ret" + return $ret + } +} -body { + LOG BEGIN + set ch [chan create {read} HANDLER] + + set tid [thread::create { + proc LOG {text} { + #puts stderr "\t\t\t\t\t\t[thread::id]: $text" + return + } + LOG THREAD-STARTED + load {} Tcltest + proc bgerror s { + LOG BGERROR:$s + } + vwait forever + LOG THREAD-DONE + }] + + testchannel cut $ch + thread::send $tid [list set thech $ch] + thread::send $tid [list set beat $beat] + thread::send -async $tid { + LOG SPLICE-BEG + testchannel splice $thech + LOG SPLICE-END + proc PROCESS {ch} { + LOG "-> [info level 0]" + if {[eof $ch]} { + close $ch + set ::done 1 + set c <<EOF>> + } else { + set c [read $ch 1] + } + LOG "GOTCHAR: $c" + LOG "<- [info level 0]" + } + LOG THREAD-FILEEVENT + fconfigure $thech -translation binary -blocking 0 + fileevent $thech readable [list PROCESS $thech] + LOG THREAD-NOEVENT-LOOP + set done 0 + while {!$done} { + after $beat + LOG THREAD-HEARTBEAT + update + } + LOG THREAD-LOOP-DONE + thread::exit + } + + LOG MAIN_WAITING + vwait forever + LOG MAIN_DONE + + set res +} -cleanup { + rename LOG {} + rename POST {} + rename HANDLER {} + unset beat drive data forever res tid ch +} -match glob \ + -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} + # --- === *** ########################### # method cgetall |