diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/chanio.test | 72 | ||||
| -rw-r--r-- | tests/io.test | 72 |
2 files changed, 142 insertions, 2 deletions
diff --git a/tests/chanio.test b/tests/chanio.test index d44902d..7580d30 100644 --- a/tests/chanio.test +++ b/tests/chanio.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: chanio.test,v 1.3.2.3 2008/04/06 00:52:09 kennykb Exp $ +# RCS: @(#) $Id: chanio.test,v 1.3.2.4 2008/04/07 22:33:30 andreas_kupries Exp $ if {[catch {package require tcltest 2}]} { chan puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -6982,6 +6982,76 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { catch {removeFile err} catch {unset ::forever} } -result OK +test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { + set err [makeFile {} err] + set pipe [open "|[info nameofexecutable] 2> $err" r+] + chan configure $pipe -translation binary -buffering line + chan puts $pipe { + chan configure stderr -buffering line + # Kill server when pipe closed by invoker. + proc bye args { + if {![chan eof stdin]} { chan gets stdin ; return } + chan puts stderr BYE + exit + } + # Server code. Bi-directional copy between 2 sockets. + proc geof {sok} { + chan puts stderr DONE/$sok + chan close $sok + } + proc new {sok args} { + chan puts stderr NEW/$sok + global l srv + chan configure $sok -translation binary -buffering none + lappend l $sok + if {[llength $l]==2} { + chan close $srv + foreach {a b} $l break + chan copy $a $b -command [list geof $a] + chan copy $b $a -command [list geof $b] + chan puts stderr 2COPY + } + chan puts stderr ... + } + chan puts stderr SRV + set l {} + set srv [socket -server new 9999] + chan puts stderr WAITING + chan event stdin readable bye + chan puts OK + vwait forever + } + # wait for OK from server. + chan gets $pipe + # Now the two clients. + proc ::done {sock} { + if {[chan eof $sock]} { chan close $sock ; return } + lappend ::forever [chan gets $sock] + return + } + set a [socket 127.0.0.1 9999] + set b [socket 127.0.0.1 9999] + chan configure $a -translation binary -buffering none + chan configure $b -translation binary -buffering none + chan event $a readable [list ::done $a] + chan event $b readable [list ::done $b] +} -constraints {stdio openpipe fcopy} -body { + # Now pass data through the server in both directions. + set ::forever {} + chan puts $a AB + vwait ::forever + chan puts $b BA + vwait ::forever + set ::forever +} -cleanup { + catch {chan close $a} + catch {chan close $b} + chan close $pipe + rename ::done {} + after 1000 ;# Give Windows time to kill the process + removeFile err + catch {unset ::forever} +} -result {AB BA} test chan-io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive diff --git a/tests/io.test b/tests/io.test index 27ccdbd..4b495fa 100644 --- a/tests/io.test +++ b/tests/io.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: io.test,v 1.80.2.3 2008/04/06 00:52:10 kennykb Exp $ +# RCS: @(#) $Id: io.test,v 1.80.2.4 2008/04/07 22:33:30 andreas_kupries Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -6981,6 +6981,76 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { catch {removeFile err} catch {unset ::forever} } -result OK +test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { + set err [makeFile {} err] + set pipe [open "|[info nameofexecutable] 2> $err" r+] + fconfigure $pipe -translation binary -buffering line + puts $pipe { + fconfigure stderr -buffering line + # Kill server when pipe closed by invoker. + proc bye args { + if {![eof stdin]} { gets stdin ; return } + puts stderr BYE + exit + } + # Server code. Bi-directional copy between 2 sockets. + proc geof {sok} { + puts stderr DONE/$sok + close $sok + } + proc new {sok args} { + puts stderr NEW/$sok + global l srv + fconfigure $sok -translation binary -buffering none + lappend l $sok + if {[llength $l]==2} { + close $srv + foreach {a b} $l break + fcopy $a $b -command [list geof $a] + fcopy $b $a -command [list geof $b] + puts stderr 2COPY + } + puts stderr ... + } + puts stderr SRV + set l {} + set srv [socket -server new 9999] + puts stderr WAITING + fileevent stdin readable bye + puts OK + vwait forever + } + # wait for OK from server. + gets $pipe + # Now the two clients. + proc ::done {sock} { + if {[eof $sock]} { close $sock ; return } + lappend ::forever [gets $sock] + return + } + set a [socket 127.0.0.1 9999] + set b [socket 127.0.0.1 9999] + fconfigure $a -translation binary -buffering none + fconfigure $b -translation binary -buffering none + fileevent $a readable [list ::done $a] + fileevent $b readable [list ::done $b] +} -constraints {stdio openpipe fcopy} -body { + # Now pass data through the server in both directions. + set ::forever {} + puts $a AB + vwait ::forever + puts $b BA + vwait ::forever + set ::forever +} -cleanup { + catch {close $a} + catch {close $b} + close $pipe + rename ::done {} + after 1000 ;# Give Windows time to kill the process + removeFile err + catch {unset ::forever} +} -result {AB BA} test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive |