summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2001-12-17 22:55:50 (GMT)
committerandreas_kupries <akupries@shaw.ca>2001-12-17 22:55:50 (GMT)
commita7a47278e09d2cc3f9430962ce717e6f59d8b74c (patch)
treec72adb127ab7cc740ed3a92cd4663280034f7ef9
parent43ebb993dc8d1553b9f8fa710987410e33102b24 (diff)
downloadtcl-a7a47278e09d2cc3f9430962ce717e6f59d8b74c.zip
tcl-a7a47278e09d2cc3f9430962ce717e6f59d8b74c.tar.gz
tcl-a7a47278e09d2cc3f9430962ce717e6f59d8b74c.tar.bz2
* Applied #219311 on behalf of Rolf Schroedter
<schroedter@users.sourceforge.net> to prevent fcopy on serial ports from flooding the event queue.
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclIO.c43
-rw-r--r--tests/io.test51
-rw-r--r--tests/iogt.test5
-rw-r--r--win/tclWinSerial.c38
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;