diff options
author | dgp <dgp@users.sourceforge.net> | 2014-06-13 21:15:13 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2014-06-13 21:15:13 (GMT) |
commit | 2aea826894f2e787994224a7cd6b2f1023c42c4f (patch) | |
tree | a9890fc1b6ab6d56f4c4ab5a3ed5a1ca3a12a78a /tests/socket.test | |
parent | 2be0ba5d68aaf52c90586aa91cc877a835b58df3 (diff) | |
download | tcl-2aea826894f2e787994224a7cd6b2f1023c42c4f.zip tcl-2aea826894f2e787994224a7cd6b2f1023c42c4f.tar.gz tcl-2aea826894f2e787994224a7cd6b2f1023c42c4f.tar.bz2 |
Draft test for [1758a0b603].
Diffstat (limited to 'tests/socket.test')
-rw-r--r-- | tests/socket.test | 41 |
1 files changed, 41 insertions, 0 deletions
diff --git a/tests/socket.test b/tests/socket.test index 2953c39..b390627 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -616,6 +616,47 @@ test socket-2.12 {} {socket stdio} { close $f set ::done } 0 +test socket-2.13 {Bug 1758a0b603} {socket stdio} { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept { client host port } { + chan configure $client -blocking 0 -buffering line -buffersize 1 + puts $client [string repeat . 720000] + puts ready + chan event $client writable [list setup $client] + } + proc setup client { + chan event $client writable {set forever write} + after 5 {set forever timeout} + } + vwait forever + puts $forever + } + close $f + set pipe [open |[list [interpreter] $path(script)] r] + gets $pipe port + set sock [socket localhost $port] + chan configure $sock -blocking 0 -buffering line + chan event $sock readable [list read_lines $sock $pipe ] + proc read_lines { sock pipe } { + gets $pipe + gets $sock line + after idle [list stop $sock $pipe] + chan event $sock readable {} + } + proc stop {sock pipe} { + variable done + close $sock + set done [gets $pipe] + } + variable done + vwait [namespace which -variable done] + close $pipe + set done +} write test socket-3.1 {socket conflict} {socket stdio} { file delete $path(script) |