summaryrefslogtreecommitdiffstats
path: root/tests/ioCmd.test
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-08-04 07:47:22 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-08-04 07:47:22 (GMT)
commitef03a2c7809309b2255f7c82c6abe0db2e4160bf (patch)
treefd7b6368f954a4c1a95289f5dc388a409605c11c /tests/ioCmd.test
parentbf9624b12a9e6fe010e025b8f76d3e29c8399725 (diff)
parent24ef33dc101a3e9114318b884c1e99d792f4739d (diff)
downloadtcl-ef03a2c7809309b2255f7c82c6abe0db2e4160bf.zip
tcl-ef03a2c7809309b2255f7c82c6abe0db2e4160bf.tar.gz
tcl-ef03a2c7809309b2255f7c82c6abe0db2e4160bf.tar.bz2
merge trunk
Diffstat (limited to 'tests/ioCmd.test')
-rw-r--r--tests/ioCmd.test120
1 files changed, 120 insertions, 0 deletions
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 4c08229..5eb0206 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
@@ -2575,6 +2578,7 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
set res
} -cleanup {
proc foo {args} {onfinal; set ::done-24.15 1; return 3}
+ after 1000 {set ::done-24.15 2}
vwait done-24.15
rename foo {}
unset res
@@ -2603,16 +2607,132 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to
proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1}
# Flush (sic!) the event-queue to capture the write from a
# BG-flush.
+ after 1000 {set ::endbody-24.16 2}
vwait endbody-24.16
set res
} -cleanup {
proc foo {args} {onfinal; set ::done-24.16 1; return 3}
+ after 1000 {set ::done-24.16 2}
vwait done-24.16
rename foo {}
unset res
} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \
-constraints {testchannel thread}
+test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
+ -constraints {testchannel thread} -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