diff options
author | dgp <dgp@users.sourceforge.net> | 2014-10-17 15:30:21 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2014-10-17 15:30:21 (GMT) |
commit | 1a3088ac3379f8ef5645a6fb601ed55a99c3870b (patch) | |
tree | 1a51cd19fa9faa40a5969f9034b6453a62093d31 /tests | |
parent | fc47c8aae5f8c68455ee588cfbe4f707e91bde7d (diff) | |
parent | 65acf25995e78db3c34b4cfd4998caf4edd4a5d8 (diff) | |
download | tcl-1a3088ac3379f8ef5645a6fb601ed55a99c3870b.zip tcl-1a3088ac3379f8ef5645a6fb601ed55a99c3870b.tar.gz tcl-1a3088ac3379f8ef5645a6fb601ed55a99c3870b.tar.bz2 |
[10dc6daa37] [gets] on a non-blocking channel must take care so that 1) At least one call to the channel driver input proc gets made. Failure to do this locks up the channel - catastrophic FAIL. 2) After any driver call reports BLOCKED, don't call again. This is less serious, but FAILs to respect the non-blocking setting. Code corrections and tests included, to restore 8.6.1 compat.
Diffstat (limited to 'tests')
-rw-r--r-- | tests/io.test | 68 |
1 files changed, 68 insertions, 0 deletions
diff --git a/tests/io.test b/tests/io.test index d9a5167..238032c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -4325,6 +4325,74 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { close $f set y } 300 +test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -translation binary -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.12 {TclGetsObjBinary, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} # Test Tcl_Seek and Tcl_Tell. |