summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/chanio.test72
-rw-r--r--tests/io.test72
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