* generic/tclIO.c (Tcl_CloseEx,CloseWrite,CloseChannelPart,ChanCloseHalf):

	Rewrite the half-close to properly flush the channel, like is done
	for a full close, going through FlushChannel, and using the flag
	BG_FLUSH_SCHEDULED (async flush during close). New functions
	CloseWrite, CloseChannelPart, new flag CHANNEL_CLOSEDWRITE.

	* tests/chanio.test (chanio-28.[67]): Reactivated these
	tests. Replaced tclsh -> [interpreter] to get correct executable
	for the pipe process, and added after cancel to kill the fail
	timers when we are done. Removed the explicits calls to [flush],
	now that [close] handles this correctly.

4 files changed, 274 insertions, 28 deletions

diff --git a/ChangeLog b/ChangeLog
index 86fe926..b05976b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,17 @@
+2008-12-18  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclIO.c (Tcl_CloseEx,CloseWrite,CloseChannelPart,ChanCloseHalf):
+	Rewrite the half-close to properly flush the channel, like is done
+	for a full close, going through FlushChannel, and using the flag
+	BG_FLUSH_SCHEDULED (async flush during close). New functions
+	CloseWrite, CloseChannelPart, new flag CHANNEL_CLOSEDWRITE.
+
+	* tests/chanio.test (chanio-28.[67]): Reactivated these
+	tests. Replaced tclsh -> [interpreter] to get correct executable
+	for the pipe process, and added after cancel to kill the fail
+	timers when we are done. Removed the explicits calls to [flush],
+	now that [close] handles this correctly.
+
 2008-12-18  Don Porter	<dgp@users.sourceforge.net>
 
 	* generic/tclExecute.c:	Disabled apparently faulty assertion.
diff --git a/generic/tclIO.c b/generic/tclIO.c
index affa03b..b3df82e 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.156 2008/12/18 16:52:53 ferrieux Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.157 2008/12/18 23:48:39 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -62,6 +62,9 @@ static void		CleanupChannelHandlers(Tcl_Interp *interp,
 			    Channel *chanPtr);
 static int		CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
 			    int errorCode);
+static int		CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
+			    int errorCode, int flags);
+static int              CloseWrite(Tcl_Interp *interp, Channel* chanPtr);
 static void		CommonGetsCleanup(Channel *chanPtr);
 static int		CopyAndTranslateBuffer(ChannelState *statePtr,
 			    char *result, int space);
@@ -258,6 +261,15 @@ ChanClose(
 }
 
 static inline int
+ChanCloseHalf(
+    Channel *chanPtr,
+    Tcl_Interp *interp,
+    int flags)
+{
+    return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags);
+}
+
+static inline int
 ChanRead(
     Channel *chanPtr,
     char *dst,
@@ -2518,6 +2530,19 @@ FlushChannel(
 	    IsBufferEmpty(statePtr->curOutPtr))) {
 	return CloseChannel(interp, chanPtr, errorCode);
     }
+
+    /*
+     * If the write-side of the channel is flagged as closed, delete it when
+     * the output queue is empty and there is no output in the current output
+     * buffer.
+     */
+
+    if (GotFlag(statePtr, CHANNEL_CLOSEDWRITE) &&
+	    (statePtr->outQueueHead == NULL) &&
+	    ((statePtr->curOutPtr == NULL) ||
+	    IsBufferEmpty(statePtr->curOutPtr))) {
+	return CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE);
+    }
     return errorCode;
 }
 
@@ -3076,7 +3101,7 @@ Tcl_Close(
  *
  * Tcl_CloseEx --
  *
- *	Half closes a channel.
+ *      Closes one side of a channel, read or write.
  *
  * Results:
  *	A standard Tcl result.
@@ -3102,7 +3127,6 @@ Tcl_CloseEx(
 {
     Channel *chanPtr;		/* The real IO channel. */
     ChannelState *statePtr;	/* State of real IO channel. */
-    int result;			/* Of calling FlushChannel. */
 
     if (chan == NULL) {
 	return TCL_OK;
@@ -3166,35 +3190,241 @@ Tcl_CloseEx(
 	return TCL_ERROR;
     }
 
+    if (flags & TCL_CLOSE_READ) {  
 	/*
-	 * Flush any data if [close w]
+	 * Call the finalization code directly. There are no events to handle,
+	 * there cannot be for the read-side.
 	 */
 
-	if (flags & TCL_CLOSE_WRITE) {  
-		if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
-			SetFlag(statePtr, BUFFER_READY);
+	return CloseChannelPart (interp, chanPtr, 0, flags);
+
+    } else if (flags & TCL_CLOSE_WRITE) {  
+
+	if ((statePtr->curOutPtr != NULL) &&
+		IsBufferReady(statePtr->curOutPtr)) {
+	    SetFlag(statePtr, BUFFER_READY);
+	}
+	Tcl_Preserve(statePtr);
+	if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
+	    /*
+	     * We don't want to re-enter CloseWrite().
+	     */
+
+	    if (!GotFlag(statePtr, CHANNEL_CLOSEDWRITE)) {
+		if (CloseWrite(interp, chanPtr) != TCL_OK) {
+		    SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
+		    Tcl_Release(statePtr);
+		    return TCL_ERROR;
 		}
-		/*
-		 * Ignoring the outcome of the flush (like EPIPE), since we don't want
-		 * to disrupt the close path with such errors
-		 */
-		FlushChannel(NULL, chanPtr, 0);
+	    }
 	}
+	SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
+	Tcl_Release(statePtr);
+    }
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CloseWrite --
+ *
+ *	Closes the write side a channel.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Closes the write side of the channel.
+ *
+ * NOTE:
+ *	CloseWrite removes the channel as far as the user is concerned.
+ *	However, the ooutput data structures may continue to exist for a while
+ *	longer if it has a background flush scheduled. The device itself is
+ *	eventually closed and the channel structures modified, in
+ *	CloseChannelPart, below.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CloseWrite(
+    Tcl_Interp *interp,		/* Interpreter for errors. */
+    Channel* chanPtr)		/* The channel whose write side is being closed. May still be used by some interpreter */
+{
+    /* Notes: clear-channel-handlers - write side only ? or keep around, just not caled */
+    /* No close cllbacks are run - channel is still open (read side) */
+
+    ChannelState *statePtr = chanPtr->state;	/* State of real IO channel. */
+    int flushcode;
+    int result = 0;
+
+    /*
+     * Ensure that the last output buffer will be flushed.
+     */
+
+    if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
+	SetFlag(statePtr, BUFFER_READY);
+    }
 
     /*
-     * Finally do what is asked of us.
+     * The call to FlushChannel will flush any queued output and invoke the
+     * close function of the channel driver, or it will set up the channel to
+     * be flushed and closed asynchronously.
      */
 
-    result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp,
-					  flags);
+    SetFlag(statePtr, CHANNEL_CLOSEDWRITE);
+
+    flushcode = FlushChannel(interp, chanPtr, 0);
 
     /*
      * TIP #219.
      * Capture error messages put by the driver into the bypass area and put
      * them into the regular interpreter result.
+     *
+     * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags
+     * FlushChannel() has called CloseChannelPart(). While we can still access
+     * "chan" (no structures were freed), the only place which may still
+     * contain a message is the interpreter itself, and "CloseChannelPart" made
+     * sure to lift any channel message it generated into it. Hence the NULL
+     * argument in the call below.
      */
 
-    if (TclChanCaughtErrorBypass(interp, chan)) {
+    if (TclChanCaughtErrorBypass(interp, NULL)) {
+	result = EINVAL;
+    }
+
+    if ((flushcode != 0) || (result != 0)) {
+	return TCL_ERROR;
+    }
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CloseChannelPart --
+ *
+ *	Utility procedure to close a channel partially and free associated resources.
+ *
+ *	If the channel was stacked it will never be run (The higher level forbid this).
+ *
+ *	If the channel was not stacked, then we will free all the bits of the
+ *	chosen side (read, or write) for the TOP channel.
+ *
+ * Results:
+ *	Error code from an unreported error or the driver close2 operation.
+ *
+ * Side effects:
+ *	May free memory, may change the value of errno.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CloseChannelPart(
+    Tcl_Interp *interp,		/* Interpreter for errors. */
+    Channel* chanPtr,		/* The channel being closed. May still be used by some interpreter */
+    int errorCode,              /* Status of operation so far. */
+    int flags)                  /* Flags telling us which side to close. */
+{
+    ChannelState *statePtr;	/* State of real IO channel. */
+    int result;			/* Of calling the close2proc. */
+
+    statePtr = chanPtr->state;
+
+    if (flags & TCL_CLOSE_READ) {
+	/*
+	 * No more input can be consumed so discard any leftover input.
+	 */
+
+	DiscardInputQueued(statePtr, 1);
+
+    } else if (flags & TCL_CLOSE_WRITE) {
+
+	/*
+	 * The caller guarantees that there are no more buffers queued for
+	 * output.
+	 */
+
+	if (statePtr->outQueueHead != NULL) {
+	    Tcl_Panic("ClosechanHalf, closed write-side of channel: queued output left");
+	}
+
+	/*
+	 * If the EOF character is set in the channel, append that to the
+	 * output device.
+	 */
+
+	if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) {
+	    int dummy;
+	    char c = (char) statePtr->outEofChar;
+
+	    (void) ChanWrite(chanPtr, &c, 1, &dummy);
+	}
+
+	/*
+	 * TIP #219, Tcl Channel Reflection API.
+	 * Move a leftover error message in the channel bypass into the
+	 * interpreter bypass. Just clear it if there is no interpreter.
+	 */
+
+	if (statePtr->chanMsg != NULL) {
+	    if (interp != NULL) {
+		Tcl_SetChannelErrorInterp(interp,statePtr->chanMsg);
+	    }
+	    TclDecrRefCount(statePtr->chanMsg);
+	    statePtr->chanMsg = NULL;
+	}
+    }
+
+    /*
+     * Finally do what is asked of us. Close and free the channel driver state
+     * for the chosen side of the channel. This may leave a TIP #219 error
+     * message in the interp.
+     */
+
+    result = ChanCloseHalf (chanPtr, interp, flags);
+
+    /*
+     * If we are being called synchronously, report either any latent error on
+     * the channel or the current error.
+     */
+
+    if (statePtr->unreportedError != 0) {
+	errorCode = statePtr->unreportedError;
+
+	/*
+	 * TIP #219, Tcl Channel Reflection API.
+	 * Move an error message found in the unreported area into the regular
+	 * bypass (interp). This kills any message in the channel bypass area.
+	 */
+
+	if (statePtr->chanMsg != NULL) {
+	    TclDecrRefCount(statePtr->chanMsg);
+	    statePtr->chanMsg = NULL;
+	}
+	if (interp) {
+	    Tcl_SetChannelErrorInterp(interp,statePtr->unreportedMsg);
+	}
+    }
+    if (errorCode == 0) {
+	errorCode = result;
+	if (errorCode != 0) {
+	    Tcl_SetErrno(errorCode);
+	}
+    }
+
+    /*
+     * TIP #219.
+     * Capture error messages put by the driver into the bypass area and put
+     * them into the regular interpreter result. See also the bottom of
+     * CloseWrite().
+     */
+
+    if (TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
 	result = EINVAL;
     }
 
@@ -3206,8 +3436,7 @@ Tcl_CloseEx(
      * Remove the closed side from the channel mode/flags.
      */
 
-    statePtr->flags &= ~(flags & (TCL_READABLE | TCL_WRITABLE));
-
+    ResetFlag (statePtr, flags & (TCL_READABLE | TCL_WRITABLE));
     return TCL_OK;
 }
 
diff --git a/generic/tclIO.h b/generic/tclIO.h
index a90817b..fa78769 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.14 2008/10/04 12:33:34 nijtmans Exp $
+ * RCS: @(#) $Id: tclIO.h,v 1.15 2008/12/18 23:48:39 andreas_kupries Exp $
  */
 
 /*
@@ -339,6 +339,9 @@ typedef struct ChannelState {
 					 * Used by Channel Tcl_Obj type to
 					 * determine if we have to revalidate
 					 * the channel. */
+#define CHANNEL_CLOSEDWRITE	(1<<21)	/* Channel write side has been closed.
+					 * No further Tcl-level write IO on
+					 * the channel is allowed. */
 
 /*
  * For each channel handler registered in a call to Tcl_CreateChannelHandler,
diff --git a/tests/chanio.test b/tests/chanio.test
index 5ac00cb..0535bbd 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.18 2008/12/18 11:48:58 dkf Exp $
+# RCS: @(#) $Id: chanio.test,v 1.19 2008/12/18 23:48:39 andreas_kupries Exp $
 
 if {[catch {package require tcltest 2}]} {
     chan puts stderr "Skipping tests in [info script].  tcltest 2 required."
@@ -2128,28 +2128,28 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} {stdio unix testchannel o
     chan close $f
     set l
 } {file1 file2}
-test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} knownBug {
+test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} {
     set cat [makeFile {
 	fconfigure stdout -buffering line
 	while {[gets stdin line]>=0} {puts $line}
 	puts DONE
 	exit 0
     } cat.tcl]
-    set ::ff [open "|[list tclsh $cat]" r+]
+    set ::ff [open "|[list [interpreter] $cat]" r+]
     puts $::ff Hey
-    flush $ff
     close $::ff w
-    after 1000 {set ::done Failed}
+    set timer [after 1000 {set ::done Failed}]
     set ::acc {}
     fileevent $::ff readable {
 	if {[gets $::ff line]<0} {set ::done Succeeded;return}
 	lappend ::acc $line
     }
     vwait ::done
+    after cancel $timer
     close $::ff r
     list $::done $::acc
 } {Succeeded {Hey DONE}}
-test chan-io-28.7 {Tcl_CloseEx (half-close) socket} knownBug {
+test chan-io-28.7 {Tcl_CloseEx (half-close) socket} {
     set echo [makeFile {
 	proc accept {s args} {set ::sok $s}
 	set s [socket -server accept 0]
@@ -2161,19 +2161,19 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} knownBug {
 	puts $::sok DONE
 	exit 0
     } echo.tcl]
-    set ::ff [open "|[list tclsh $echo]" r]
+    set ::ff [open "|[list [interpreter] $echo]" r]
     gets $::ff port
     set ::s [socket 127.0.0.1 $port]
     puts $::s Hey
-    flush $::s
     close $::s w
-    after 1000 {set ::done Failed}
+    set timer [after 1000 {set ::done Failed}]
     set ::acc {}
     fileevent $::s readable {
 	if {[gets $::s line]<0} {set ::done Succeeded;return}
 	lappend ::acc $line
     }
     vwait ::done
+    after cancel $timer
     close $::s r
     close $::ff
     list $::done $::acc