diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclIO.c | 43 | ||||
| -rw-r--r-- | tests/io.test | 51 | ||||
| -rw-r--r-- | tests/iogt.test | 5 | ||||
| -rw-r--r-- | win/tclWinSerial.c | 38 |
5 files changed, 120 insertions, 23 deletions
@@ -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; |