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

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

1 files changed, 71 insertions, 1 deletions

diff --git a/tests/io.test b/tests/io.test
index 696366b..f59226d 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.40.2.15 2008/04/07 19:41:00 andreas_kupries Exp $
+# RCS: @(#) $Id: io.test,v 1.40.2.16 2008/04/07 22:17:37 andreas_kupries Exp $
 
 if {[catch {package require tcltest 2}]} {
     puts stderr "Skipping tests in [info script].  tcltest 2 required."
@@ -7013,6 +7013,76 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
     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