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

5 files changed, 199 insertions, 31 deletions

diff --git a/ChangeLog b/ChangeLog
index 399ce04..f557550 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,20 @@
 2008-04-07  Andreas Kupries  <andreask@activestate.com>
 
+	* 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.
+
+	* tests/io.test (io-53.10): Testcase for bi-directionaly fcopy.
+	* generic/tclIO.c: Additional changes to data structures for fcopy
+	  and channels to perform proper cleanup in case of a channel
+	  having two background copy operations running as is now
+	  possible.
+
+2008-04-07  Andreas Kupries  <andreask@activestate.com>
+
 	* generic/tclIO.c (BUSY_STATE, CheckChannelErrors,
 	  TclCopyChannel): New macro, and the places using it. This change
 	  allows for bi-directional fcopy on channels. [Bug 1350564].
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 783011f..77d586c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIO.c,v 1.137.2.3 2008/04/07 19:42:03 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.137.2.4 2008/04/07 22:33:29 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -222,9 +222,8 @@ static Tcl_ObjType tclChannelType = {
     ((objPtr)->internalRep.otherValuePtr = (void *) (storePtr))
 
 #define BUSY_STATE(st,fl) \
-    ((st)->csPtr && \
-     ( (((fl)&TCL_READABLE)&&((st)->csPtr->readPtr ==(st)->topChanPtr)) || \
-       (((fl)&TCL_WRITABLE)&&((st)->csPtr->writePtr==(st)->topChanPtr))))
+     ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
+      (((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
 
 /*
  *---------------------------------------------------------------------------
@@ -1317,7 +1316,8 @@ Tcl_CreateChannel(
     statePtr->scriptRecordPtr	= NULL;
     statePtr->bufSize		= CHANNELBUFFER_DEFAULT_SIZE;
     statePtr->timer		= NULL;
-    statePtr->csPtr		= NULL;
+    statePtr->csPtrR		= NULL;
+    statePtr->csPtrW		= NULL;
 
     statePtr->outputStage	= NULL;
     if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
@@ -1478,13 +1478,18 @@ Tcl_StackChannel(
      */
 
     if ((mask & TCL_WRITABLE) != 0) {
-	CopyState *csPtr;
+        CopyState *csPtrR;
+        CopyState *csPtrW;
 
-	csPtr = statePtr->csPtr;
-	statePtr->csPtr = NULL;
+        csPtrR           = statePtr->csPtrR;
+	statePtr->csPtrR = NULL;
+
+        csPtrW           = statePtr->csPtrW;
+	statePtr->csPtrW = NULL;
 
 	if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
-	    statePtr->csPtr = csPtr;
+	    statePtr->csPtrR = csPtrR;
+	    statePtr->csPtrW = csPtrW;
 	    if (interp) {
 		Tcl_AppendResult(interp, "could not flush channel \"",
 			Tcl_GetChannelName(prevChan), "\"", NULL);
@@ -1492,7 +1497,8 @@ Tcl_StackChannel(
 	    return NULL;
 	}
 
-	statePtr->csPtr = csPtr;
+	statePtr->csPtrR = csPtrR;
+	statePtr->csPtrW = csPtrW;
     }
 
     /*
@@ -1624,13 +1630,18 @@ Tcl_UnstackChannel(
 	 */
 
 	if (statePtr->flags & TCL_WRITABLE) {
-	    CopyState *csPtr;
+	    CopyState *csPtrR;
+	    CopyState *csPtrW;
+
+	    csPtrR           = statePtr->csPtrR;
+	    statePtr->csPtrR = NULL;
 
-	    csPtr = statePtr->csPtr;
-	    statePtr->csPtr = NULL;
+	    csPtrW           = statePtr->csPtrW;
+	    statePtr->csPtrW = NULL;
 
 	    if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
-		statePtr->csPtr = csPtr;
+		statePtr->csPtrR = csPtrR;
+		statePtr->csPtrW = csPtrW;
 
 		/*
 		 * TIP #219, Tcl Channel Reflection API.
@@ -1648,7 +1659,8 @@ Tcl_UnstackChannel(
 		return TCL_ERROR;
 	    }
 
-	    statePtr->csPtr = csPtr;
+	    statePtr->csPtrR  = csPtrR;
+	    statePtr->csPtrW = csPtrW;
 	}
 
 	/*
@@ -3091,7 +3103,8 @@ Tcl_ClearChannelHandlers(
      * Cancel any pending copy operation.
      */
 
-    StopCopy(statePtr->csPtr);
+    StopCopy(statePtr->csPtrR);
+    StopCopy(statePtr->csPtrW);
 
     /*
      * Must set the interest mask now to 0, otherwise infinite loops
@@ -7096,12 +7109,10 @@ Tcl_GetChannelOption(
      * If we are in the middle of a background copy, use the saved flags.
      */
 
-    if (statePtr->csPtr) {
-	if (chanPtr == statePtr->csPtr->readPtr) {
-	    flags = statePtr->csPtr->readFlags;
-	} else {
-	    flags = statePtr->csPtr->writeFlags;
-	}
+    if (statePtr->csPtrR) {
+      flags = statePtr->csPtrR->readFlags;
+    } else if (statePtr->csPtrW) {
+      flags = statePtr->csPtrW->writeFlags;
     } else {
 	flags = statePtr->flags;
     }
@@ -7311,7 +7322,7 @@ Tcl_SetChannelOption(
      * If the channel is in the middle of a background copy, fail.
      */
 
-    if (statePtr->csPtr) {
+    if (statePtr->csPtrR || statePtr->csPtrW) {
 	if (interp) {
 	    Tcl_AppendResult(interp, "unable to set channel options: "
 		    "background copy in progress", NULL);
@@ -8498,8 +8509,9 @@ TclCopyChannel(
 	Tcl_IncrRefCount(cmdPtr);
     }
     csPtr->cmdPtr = cmdPtr;
-    inStatePtr->csPtr = csPtr;
-    outStatePtr->csPtr = csPtr;
+
+    inStatePtr->csPtrR  = csPtr;
+    outStatePtr->csPtrW = csPtr;
 
     /*
      * Start copying data between the channels.
@@ -9451,8 +9463,8 @@ StopCopy(
 	}
 	TclDecrRefCount(csPtr->cmdPtr);
     }
-    inStatePtr->csPtr = NULL;
-    outStatePtr->csPtr = NULL;
+    inStatePtr->csPtrR = NULL;
+    outStatePtr->csPtrW = NULL;
     ckfree((char *) csPtr);
 }
 
diff --git a/generic/tclIO.h b/generic/tclIO.h
index 411f48d..eab83eb 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIO.h,v 1.11 2007/12/13 15:23:18 dgp Exp $
+ * RCS: @(#) $Id: tclIO.h,v 1.11.2.1 2008/04/07 22:33:30 andreas_kupries Exp $
  */
 
 /*
@@ -219,7 +219,8 @@ typedef struct ChannelState {
 				 * handlers ("fileevent") on this channel. */
     int bufSize;		/* What size buffers to allocate? */
     Tcl_TimerToken timer;	/* Handle to wakeup timer for this channel. */
-    CopyState *csPtr;		/* State of background copy, or NULL. */
+    CopyState *csPtrR;		/* State of background copy for which channel is input, or NULL. */
+    CopyState *csPtrW;		/* State of background copy for which channel is output, or NULL. */
     Channel *topChanPtr;	/* Refers to topmost channel in a stack. Never
 				 * NULL. */
     Channel *bottomChanPtr;	/* Refers to bottommost channel in a stack.
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