* Applied #219311 on behalf of Rolf Schroedter

	  <schroedter@users.sourceforge.net> to prevent fcopy on serial
	  ports from flooding the event queue.

5 files changed, 120 insertions, 23 deletions

diff --git a/ChangeLog b/ChangeLog
index ac3f2a3..32dcdc2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2001-12-17  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 
+
+	* Applied #219311 on behalf of Rolf Schroedter
+	  <schroedter@users.sourceforge.net> to prevent fcopy on serial
+	  ports from flooding the event queue.
+
 2001-12-11  Miguel Sofer  <msofer@users.sourceforge.net>
 
 	* doc/CrtInterp.3:
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 22f22bc..fa3d1d4 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.42 2001/12/12 22:32:35 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.43 2001/12/17 22:55:50 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -7272,7 +7272,7 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
     if (inPtr != outPtr) {
 	if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) {
 	    if (SetBlockMode(NULL, outPtr,
-		    nonBlocking ? TCL_MODE_BLOCKING : TCL_MODE_NONBLOCKING)
+		    nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
 		    != TCL_OK) {
 		if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
 		    SetBlockMode(NULL, inPtr,
@@ -7354,6 +7354,7 @@ CopyData(csPtr, mask)
     char* buffer;
 
     int inBinary, outBinary, sameEncoding; /* Encoding control */
+    int underflow;	/* input underflow */
 
     inChan	= (Tcl_Channel) csPtr->readPtr;
     outChan	= (Tcl_Channel) csPtr->writePtr;
@@ -7400,16 +7401,17 @@ CopyData(csPtr, mask)
 	 */
 
 	if ((csPtr->toRead == -1) || (csPtr->toRead > csPtr->bufSize)) {
-	    size = csPtr->bufSize;
+	    sizeb = csPtr->bufSize;
 	} else {
-	    size = csPtr->toRead;
+	    sizeb = csPtr->toRead;
 	}
 
 	if (inBinary || sameEncoding) {
-	    size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, size);
+	    size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
 	} else {
-	    size = DoReadChars(inStatePtr->topChanPtr, bufObj, size, 0 /* No append */);
+	    size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */);
 	}
+	underflow = (size >= 0) && (size < sizeb);	/* input underflow */
 
 	if (size < 0) {
 	    readError:
@@ -7418,16 +7420,17 @@ CopyData(csPtr, mask)
 		    Tcl_GetChannelName(inChan), "\": ",
 		    Tcl_PosixError(interp), (char *) NULL);
 	    break;
-	} else if (size == 0) {
+	} else if (underflow) {
 	    /*
 	     * We had an underflow on the read side.  If we are at EOF,
 	     * then the copying is done, otherwise set up a channel
 	     * handler to detect when the channel becomes readable again.
 	     */
 	    
-	    if (Tcl_Eof(inChan)) {
+	    if ((size == 0) && Tcl_Eof(inChan)) {
 		break;
-	    } else if (!(mask & TCL_READABLE)) {
+	    }
+	    if (! Tcl_Eof(inChan) && !(mask & TCL_READABLE)) {
 		if (mask & TCL_WRITABLE) {
 		    Tcl_DeleteChannelHandler(outChan, CopyEventProc,
 			    (ClientData) csPtr);
@@ -7435,11 +7438,13 @@ CopyData(csPtr, mask)
 		Tcl_CreateChannelHandler(inChan, TCL_READABLE,
 			CopyEventProc, (ClientData) csPtr);
 	    }
-	    if (bufObj != (Tcl_Obj*) NULL) {
-	        Tcl_DecrRefCount (bufObj);
-		bufObj = (Tcl_Obj*) NULL;
+	    if (size == 0) {
+	        if (bufObj != (Tcl_Obj*) NULL) {
+		    Tcl_DecrRefCount (bufObj);
+		    bufObj = (Tcl_Obj*) NULL;
+		}
+		return TCL_OK;
 	    }
-	    return TCL_OK;
 	}
 
 	/*
@@ -7486,11 +7491,21 @@ CopyData(csPtr, mask)
 	csPtr->total += size;
 
 	/*
+	 * Break loop if EOF && (size>0)
+	 */
+
+        if (Tcl_Eof(inChan)) {
+            break;
+        }
+
+	/*
 	 * Check to see if the write is happening in the background.  If so,
 	 * stop copying and wait for the channel to become writable again.
+	 * After input underflow we already installed a readable handler
+	 * therefore we don't need a writable handler.
 	 */
 
-	if (outStatePtr->flags & BG_FLUSH_SCHEDULED) {
+	if ( ! underflow && (outStatePtr->flags & BG_FLUSH_SCHEDULED) ) {
 	    if (!(mask & TCL_WRITABLE)) {
 		if (mask & TCL_READABLE) {
 		    Tcl_DeleteChannelHandler(inChan, CopyEventProc,
diff --git a/tests/io.test b/tests/io.test
index 6c1a710..2d535e6 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -12,7 +12,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.21 2001/09/11 17:30:44 andreas_kupries Exp $
+# RCS: @(#) $Id: io.test,v 1.22 2001/12/17 22:55:51 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -6610,6 +6610,55 @@ test io-53.6 {CopyData: error during fcopy} {stdio} {
     set fcopyTestDone	;# 0 for plain end of file
 } {0}
 
+proc doFcopy {in out {bytes 0} {error {}}} {
+    global fcopyTestDone fcopyTestCount
+    incr fcopyTestCount $bytes
+    if {[string length $error]} {
+	    set fcopyTestDone 1
+    } elseif {[eof $in]} {
+	    set fcopyTestDone 0
+    } else {
+        # Delay next fcopy to wait for size>0 input bytes
+        after 100 [list 
+            fcopy $in $out -size 1000 -command [list doFcopy $in $out]
+        ]
+    }
+}
+
+test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
+    removeFile pipe
+    removeFile test1
+    catch {unset fcopyTestDone}
+    set fcopyTestCount 0
+    set f1 [open pipe w]
+    puts $f1 {
+	# Write  10 bytes / 10 msec
+	proc Write {count} {
+	    puts -nonewline "1234567890"
+	    if {[incr count -1]} {
+	        after 10 [list Write $count]
+	    } else {
+	        set ::ready 1
+	    }
+	}
+	fconfigure stdout -buffering none
+	Write 345 ;# 3450 bytes ~3.45 sec
+	vwait ready
+	exit 0
+    }
+    close $f1
+    set in [open "|[list $::tcltest::tcltest pipe &]" r+]
+    set out [open test1 w]
+    doFcopy $in $out
+    if ![info exists fcopyTestDone] {
+	vwait fcopyTestDone
+    }
+    catch {close $in}
+    close $out
+    # -1=error 0=script error N=number of bytes
+    expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
+} {3450}
+
 test io-54.1 {Recursive channel events} {socket} {
     # This test checks to see if file events are delivered during recursive
     # event loops when there is buffered data on the channel.
diff --git a/tests/iogt.test b/tests/iogt.test
index ebb0ab6..a737634 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -10,7 +10,7 @@
 # Copyright (c) 2000 Andreas Kupries.
 # All rights reserved.
 # 
-# RCS: @(#) $Id: iogt.test,v 1.2 2000/09/28 06:38:22 hobbs Exp $
+# RCS: @(#) $Id: iogt.test,v 1.3 2001/12/17 22:55:51 andreas_kupries Exp $
 
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -512,7 +512,6 @@ query/maxRead
 read
 query/maxRead
 flush/read
-query/maxRead
 delete/read
 --------
 create/write
@@ -565,7 +564,6 @@ read {
 }
 query/maxRead {} -1
 flush/read {} {}
-query/maxRead {} -1
 delete/read {} *ignored*
 --------
 create/write {} *ignored*
@@ -624,7 +622,6 @@ write %^&*()_+-= %^&*()_+-=
 write {
 } {
 }
-query/maxRead {} -1
 delete/read {} *ignored*
 flush/write {} {}
 delete/write {} *ignored*}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 318ffa5..ba4e3da 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -11,7 +11,7 @@
  *
  * Serial functionality implemented by Rolf.Schroedter@dlr.de
  *
- * RCS: @(#) $Id: tclWinSerial.c,v 1.14 2001/10/15 17:34:53 hobbs Exp $
+ * RCS: @(#) $Id: tclWinSerial.c,v 1.15 2001/12/17 22:55:51 andreas_kupries Exp $
  */
 
 #include "tclWinInt.h"
@@ -79,6 +79,8 @@ typedef struct SerialInfo {
     int readable;               /* flag that the channel is readable */
     int writable;               /* flag that the channel is writable */
     int blockTime;              /* max. blocktime in msec */
+    int lastEventTime;		/* Time in milliseconds since last readable event */
+				/* Next readable event only after blockTime */
     DWORD error;                /* pending error code returned by
                                  * ClearCommError() */
     DWORD lastError;            /* last error code, can be fetched with
@@ -325,7 +327,7 @@ ProcExitHandler(
  *----------------------------------------------------------------------
  */
 
-void
+static void
 SerialBlockTime(
     int msec)          /* milli-seconds */
 {
@@ -338,6 +340,29 @@ SerialBlockTime(
 /*
  *----------------------------------------------------------------------
  *
+ * SerialGetMilliseconds --
+ *
+ *  Get current time in milliseconds,
+ *  Don't care about integer overruns
+ *
+ * Results:
+ *  None.
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialGetMilliseconds(
+    void)
+{
+    Tcl_Time time;
+
+    TclpGetTime(&time);
+
+    return (time.sec * 1000 + time.usec / 1000);
+}
+/*
+ *----------------------------------------------------------------------
+ *
  * SerialSetupProc --
  *
  *  This procedure is invoked before Tcl_DoOneEvent blocks waiting
@@ -417,6 +442,7 @@ SerialCheckProc(
     int needEvent;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
     COMSTAT cStat;
+    int time;
 
     if (!(flags & TCL_FILE_EVENTS)) {
         return;
@@ -466,7 +492,11 @@ SerialCheckProc(
                     if( (cStat.cbInQue > 0) ||
                             (infoPtr->error & SERIAL_READ_ERRORS) ) {
                         infoPtr->readable = 1;
-                        needEvent = 1;
+			time = SerialGetMilliseconds();
+			if ( (time - infoPtr->lastEventTime) >= infoPtr->blockTime) {
+			    needEvent = 1;
+			    infoPtr->lastEventTime = time;
+			}
                     }
                 }
             }
@@ -475,7 +505,6 @@ SerialCheckProc(
         /*
          * Queue an event if the serial is signaled for reading or writing.
          */
-
         if (needEvent) {
             infoPtr->flags |= SERIAL_PENDING;
             evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
@@ -1366,6 +1395,7 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
     infoPtr->writable = 1;
     infoPtr->toWrite = infoPtr->writeQueue = 0;
     infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
+    infoPtr->lastEventTime = 0;
     infoPtr->lastError = infoPtr->error = 0;
     infoPtr->threadId = Tcl_GetCurrentThread();
     infoPtr->sysBufRead = infoPtr->sysBufWrite = 4096;