* 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.

1 files changed, 114 insertions, 0 deletions

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