* generic/tclIORChan.c: [Bug 2936225]: Thanks to Alexandre Ferrieux

	* doc/refchan.n: <ferrieux@users.sourceforge.net> for debugging and fixing
	* tests/ioCmd.test: the problem. It is the write-side equivalent
	to the bug fixed 2009-08-06.

4 files changed, 147 insertions, 9 deletions

diff --git a/ChangeLog b/ChangeLog
index 4ce46bd..3c2425e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2010-03-09  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclIORChan.c: [Bug 2936225]: Thanks to Alexandre Ferrieux
+	* doc/refchan.n: <ferrieux@users.sourceforge.net> for debugging and fixing
+	* tests/ioCmd.test: the problem. It is the write-side equivalent
+	to the bug fixed 2009-08-06.
+
 2010-03-09  Don Porter  <dgp@users.sourceforge.net>
 
 	* library/tzdata/America/Matamoros: New locale
diff --git a/doc/refchan.n b/doc/refchan.n
index 4edd7ad..5007a09 100644
--- a/doc/refchan.n
+++ b/doc/refchan.n
@@ -4,7 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
-'\" RCS: @(#) $Id: refchan.n,v 1.19 2010/03/03 18:30:28 andreas_kupries Exp $
+'\" RCS: @(#) $Id: refchan.n,v 1.20 2010/03/09 21:15:19 andreas_kupries Exp $
 .so man.macros
 .TH refchan n 8.5 Tcl "Tcl Built-In Commands"
 .BS
@@ -176,7 +176,41 @@ negative value implies that the write failed. Returning a value
 greater than the number of bytes given to the handler, or zero, is
 forbidden and will cause the Tcl core to throw an error.
 .PP
-If the subcommand throws an error the command which caused its
+To signal that the channel is not able to accept data for writing
+right now, it is necessary to throw the error "EAGAIN", i.e. to either
+.PP
+.CS
+return -code error EAGAIN
+.CE
+or
+.CS
+error EAGAIN
+.CE
+.PP
+For extensibility any error whose value is a negative integer number
+will cause the higher layers to set the C-level variable "\fBerrno\fR"
+to the absolute value of this number, signaling a system error.
+However, note that the exact mapping between these error numbers and
+their meanings is operating system dependent.
+.PP
+For example, while on Linux both
+.PP
+.CS
+return -code error -11
+.CE
+and
+.CS
+error -11
+.CE
+.PP
+are equivalent to the examples above, using the more readable string "EAGAIN",
+this is not true for BSD, where the equivalent number is -35.
+.PP
+The symbolic string however is the same across systems, and internally
+translated to the correct number. No other error value has such a mapping
+to a symbolic string.
+.PP
+If the subcommand throws any other error the command which caused its
 invocation (usually \fBputs\fR) will appear to have thrown this error.
 Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated
 as and converted to an error.
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 3139268..50374a5 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIORChan.c,v 1.45 2010/02/24 10:45:04 dkf Exp $
+ * RCS: @(#) $Id: tclIORChan.c,v 1.46 2010/03/09 21:15:19 andreas_kupries Exp $
  */
 
 #include <tclInt.h>
@@ -1331,8 +1331,13 @@ ReflectOutput(
 	ForwardOpToOwnerThread(rcPtr, ForwardedOutput, &p);
 
 	if (p.base.code != TCL_OK) {
-	    PassReceivedError(rcPtr->chan, &p);
-	    *errorCodePtr = EINVAL;
+	    if (p.base.code < 0) {
+		/* No error message, this is an errno signal. */
+		*errorCodePtr = -p.base.code;
+	    } else {
+                PassReceivedError(rcPtr->chan, &p);
+                *errorCodePtr = EINVAL;
+            }
 	    p.output.toWrite = -1;
 	} else {
 	    *errorCodePtr = EOK;
@@ -1347,6 +1352,14 @@ ReflectOutput(
 
     bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
     if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+	int code = ErrnoReturn(rcPtr, resObj);
+
+	if (code < 0) {
+	    Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
+	    *errorCodePtr = -code;
+	    return -1;
+	}
+
 	Tcl_SetChannelError(rcPtr->chan, resObj);
 	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
 	*errorCodePtr = EINVAL;
@@ -2295,8 +2308,8 @@ InvokeTclMethod(
  *	None.
  *
  * Users:
- *	Currently only ReflectInput(), to enable the signaling of EAGAIN.
- *	by non-blocking channels at buffer-empty, but not EOF.
+ *	ReflectInput/Output(), to enable the signaling of EAGAIN
+ *	on 0-sized short reads/writes.
  *
  *----------------------------------------------------------------------
  */
@@ -2857,7 +2870,13 @@ ForwardProc(
 		paramPtr->output.buf, paramPtr->output.toWrite);
 
 	if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
-	    ForwardSetObjError(paramPtr, resObj);
+	    int code = ErrnoReturn(rcPtr, resObj);
+
+	    if (code < 0) {
+		paramPtr->base.code = code;
+	    } else {
+		ForwardSetObjError(paramPtr, resObj);
+	    }
 	    paramPtr->output.toWrite = -1;
 	} else {
 	    /*
@@ -3099,5 +3118,7 @@ ForwardSetObjError(
  * mode: c
  * c-basic-offset: 4
  * fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
  * End:
  */
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index cafe3d9..4467492 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.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: ioCmd.test,v 1.51 2010/02/11 15:20:37 dkf Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.52 2010/03/09 21:15:19 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -1190,6 +1190,40 @@ test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}
+test iocmd-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup {
+    set res {}
+    proc foo {args} {
+	oninit; onfinal; track
+	return 3
+    }
+    set c [chan create {r w} foo]
+} -body {
+    note [puts -nonewline $c ABC ; flush $c]
+    set res
+} -cleanup {
+    close $c
+    rename foo {}
+    unset res
+} -result {{write rc* ABC} {}}
+test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup {
+    set res {}
+    proc foo {args} {
+	oninit; onfinal; track
+	# Note: The EAGAIN signals that the channel cannot accept
+	# write requests right now, this in turn causes the IO core to
+	# request the generation of writable events (see expected
+	# result below, and compare to case 24.14 above).
+	error EAGAIN
+    }
+    set c [chan create {r w} foo]
+} -body {
+    note [puts -nonewline $c ABC ; flush $c]
+    set res
+} -cleanup {
+    close $c
+    rename foo {}
+    unset res
+} -result {{write rc* ABC} {watch rc* write} {}}
 
 # --- === *** ###########################
 # method cgetall
@@ -2507,6 +2541,48 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
     -constraints {testchannel testthread}
+test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup {
+    set res {}
+    proc foo {args} {
+	oninit; onfinal; track
+	return 3
+    }
+    set c [chan create {r w} foo]
+} -body {
+    notes [inthread $c {
+	note [puts -nonewline $c ABC ; flush $c]
+	close $c
+	notes
+    } c]
+    set res
+} -cleanup {
+    rename foo {}
+    unset res
+} -result {{write rc* ABC} {}} \
+    -constraints {testchannel testthread}
+test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup {
+    set res {}
+    proc foo {args} {
+	oninit; onfinal; track
+	# Note: The EAGAIN signals that the channel cannot accept
+	# write requests right now, this in turn causes the IO core to
+	# request the generation of writable events (see expected
+	# result below, and compare to case 24.14 above).
+	error EAGAIN
+    }
+    set c [chan create {r w} foo]
+} -body {
+    notes [inthread $c {
+	note [puts -nonewline $c ABC ; flush $c]
+	close $c
+	notes
+    } c]
+    set res
+} -cleanup {
+    rename foo {}
+    unset res
+} -result {{write rc* ABC} {watch rc* write} {}} \
+    -constraints {testchannel testthread}
 
 # --- === *** ###########################
 # method cgetall