* 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, 148 insertions, 10 deletions

diff --git a/ChangeLog b/ChangeLog
index aeb4e44..58581c8 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 42e5588..b2bcabb 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.11.2.1 2009/08/06 22:28:44 andreas_kupries Exp $
+'\" RCS: @(#) $Id: refchan.n,v 1.11.2.2 2010/03/09 21:13:13 andreas_kupries Exp $
 .so man.macros
 .TH refchan n 8.5 Tcl "Tcl Built-In Commands"
 .BS
@@ -168,9 +168,43 @@ 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 \fIerror\fR (e.g. \fIbreak\fR, etc.) is treated
+Any exception beyond \fIerror\fR (e.g.\ \fIbreak\fR, etc.) is treated
 as and converted to an error.
 .RE
 .TP
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 305b3ad..f483870 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.28.2.8 2009/10/07 17:11:40 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIORChan.c,v 1.28.2.9 2010/03/09 21:13:13 andreas_kupries Exp $
  */
 
 #include <tclInt.h>
@@ -1327,8 +1327,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;
@@ -1343,6 +1348,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;
@@ -2291,8 +2304,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.
  *
  *----------------------------------------------------------------------
  */
@@ -2846,7 +2859,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 {
 	    /*
@@ -3088,5 +3107,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 4dde148..999e25c 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.36.2.7 2010/02/11 15:25:25 dkf Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.36.2.8 2010/03/09 21:13:13 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -1155,6 +1155,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
@@ -2472,6 +2506,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