diff options
author | andreas_kupries <andreas_kupries@noemail.net> | 2001-12-17 22:55:50 (GMT) |
---|---|---|
committer | andreas_kupries <andreas_kupries@noemail.net> | 2001-12-17 22:55:50 (GMT) |
commit | 184581ca5384a0f5d89d9576f6255a37f557e463 (patch) | |
tree | c72adb127ab7cc740ed3a92cd4663280034f7ef9 /tests | |
parent | e8b0f77b9d6d3ed35ed05952805dbd9e5f3ca8a0 (diff) | |
download | tcl-184581ca5384a0f5d89d9576f6255a37f557e463.zip tcl-184581ca5384a0f5d89d9576f6255a37f557e463.tar.gz tcl-184581ca5384a0f5d89d9576f6255a37f557e463.tar.bz2 |
* Applied #219311 on behalf of Rolf Schroedter
<schroedter@users.sourceforge.net> to prevent fcopy on serial
ports from flooding the event queue.
FossilOrigin-Name: 0e625dfd2b5e8f922da7dcdb19b0fe8e48088abf
Diffstat (limited to 'tests')
-rw-r--r-- | tests/io.test | 51 | ||||
-rw-r--r-- | tests/iogt.test | 5 |
2 files changed, 51 insertions, 5 deletions
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*} |