* tests/io.test (io-53.10): Testcase for bi-directionaly fcopy.

	* tests/chanio.test:
	* generic/tclIO.c: Additional changes to data structures for fcopy
	* generic/tclIO.h: and channels to perform proper cleanup in case
	  of a channel having two background copy operations running as is
	  now possible.

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