diff options
Diffstat (limited to 'tests')
-rw-r--r-- | tests/aio.test | 179 | ||||
-rw-r--r-- | tests/runall.tcl | 8 | ||||
-rw-r--r-- | tests/socket.test | 77 | ||||
-rw-r--r-- | tests/ssl.test | 14 |
4 files changed, 251 insertions, 27 deletions
diff --git a/tests/aio.test b/tests/aio.test index a012518..f6852b9 100644 --- a/tests/aio.test +++ b/tests/aio.test @@ -8,11 +8,20 @@ testConstraint posixaio [expr {$tcl_platform(platform) eq {unix} && !$tcl_platfo set f [open testdata.in wb] $f puts test-data $f close +# create a test file file with several lines +set f [open copy.in wb] +$f puts line1 +$f puts line2 +$f puts line3 +$f close + set f [open testdata.in rb] defer { $f close file delete testdata.in + file delete copy.in + file delete copy.out } test aio-1.1 {seek usage} -body { @@ -72,11 +81,7 @@ test aio-2.3 {read -ve len} -body { test aio-2.4 {read too many args} -body { $f read 20 extra -} -returnCodes error -match glob -result {wrong # args: should be "* read ?-nonewline|-pending|len?"} - -test aio-2.5 {read -pending on non-ssl} -body { - $f read -pending -} -returnCodes error -result {-pending not supported on this connection type} +} -returnCodes error -match glob -result {wrong # args: should be "* read ?-nonewline|len?"} test aio-3.1 {copy to invalid fh} -body { $f copy lambda @@ -137,7 +142,7 @@ test aio-9.1 {open: posix modes} -constraints posixaio -body { test aio-9.2 {open: posix modes, bad modes} -constraints posixaio -body { open testdata.in {CREAT TRUNC} -} -returnCodes error -result {testdata.in: Invalid argument} +} -returnCodes error -result {testdata.in: invalid open mode 'CREAT TRUNC'} test aio-9.3 {open: posix modes, bad modes} -constraints posixaio -body { open testdata.in {WRONG TRUNC} @@ -156,4 +161,166 @@ test aio-9.4 {open: posix modes} -constraints posixaio -cleanup { set buf } -result {write-data} +test copyto-1.1 {basic copyto} { + set in [open copy.in] + set out [open copy.out w] + $in copyto $out + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {line1 line2 line3} + +test copyto-1.2 {copyto with limit} { + set in [open copy.in] + set out [open copy.out w] + $in copyto $out 8 + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {line1 li {}} + +test copyto-1.3 {copyto after gets} { + set in [open copy.in] + set out [open copy.out w] + $in gets + $in copyto $out + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {line2 line3 {}} + +test copyto-1.4 {copyto after read} { + set in [open copy.in] + $in read 3 + set out [open copy.out w] + $in copyto $out + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {e1 line2 line3} + +test copyto-1.5 {copyto after gets, seek} { + set in [open copy.in] + $in gets + $in seek 2 start + set out [open copy.out w] + $in copyto $out + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {ne1 line2 line3} + +test copyto-1.6 {copyto from pipe} { + set in [open "|cat copy.in"] + set out [open copy.out w] + $in copyto $out + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {line1 line2 line3} + +test copyto-1.6 {copyto to pipe} { + set out [open "|cat >copy.out" w] + set in [open copy.in] + $in copyto $out + $in close + $out close + set ff [open copy.out] + set result [list [$ff gets] [$ff gets] [$ff gets]] + $ff close + set result +} {line1 line2 line3} + +# Creates a child process and returns {pid writehandle} +# The child expects to read $numlines lines of input and exits with a return +# code of 0 if ok +proc child_reader {numlines} { + # create a pipe with the child as a slightly slow reader + lassign [socket pipe] r w + + set pid [os.fork] + if {$pid == 0} { + # child + $w close + # sleep a moment to make sure the parent fills up the send buffer + sleep 0.5 + set n 0 + while {[$r gets buf] >= 0} { + incr n + } + #puts "child got $n/$numlines lines" + $r close + if {$n == $numlines} { + # This is what we expect + exit 99 + } + # This is not expected + exit 98 + } + # parent + $r close + + list $pid $w +} + +test autoflush-1.1 {pipe writer, blocking} -constraints socket -body { + lassign [child_reader 10000] pid w + + # Send data fast enough to fill up the send buffer + loop i 10000 { + $w puts "this is line $i" + } + + # No autoflush needed. The write won't return + # until queued + $w close + + lassign [wait $pid] - - rc + + list $rc +} -result {99} + +test autoflush-1.2 {pipe writer, non blocking} -constraints socket -body { + lassign [child_reader 10000] pid w + + $w ndelay 1 + + # Send data fast enough to fill up the send buffer + # With older jimtcl this would return an error "pipe: Resource temporarily unavailable" + loop i 10000 { + $w puts "this is line $i" + } + + # Now data should still be queued, wait for autoflush + lassign [time { + after idle {} + vwait done + }] t1 + + # puts "autoflush finished in ${t1}us, closing pipe" + $w close + + lassign [wait $pid] - - rc + + list $rc $t1 +} -match glob -result {99 *} + testreport diff --git a/tests/runall.tcl b/tests/runall.tcl index 96a56a9..5c9aa8b 100644 --- a/tests/runall.tcl +++ b/tests/runall.tcl @@ -47,11 +47,11 @@ if {[info commands interp] eq ""} { puts [format "%16s: --- error ($msg)" $script] incr total(fail) } elseif {[info return $opts(-code)] eq "exit"} { - # if the test explicitly called exit 99, + # if the test explicitly called exit 98 or 99, # it must be from a child process via os.fork, so - # silently exit - if {$msg eq "99"} { - exit 0 + # silently exit with that return code + if {$msg in {98 99}} { + exit $msg } } diff --git a/tests/socket.test b/tests/socket.test index 67fdb9c..1eb98b4 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -129,6 +129,8 @@ test socket-1.6 {pipe} -body { test socket-1.7 {socketpair} -body { lassign [socket pair] s1 s2 + $s1 buffering line + $s2 buffering line stdout flush if {[os.fork] == 0} { $s1 close @@ -338,20 +340,18 @@ set s [socket stream.server 0] if {[os.fork] == 0} { # child set c [socket stream [socket-connect-addr $s]] - # Note: We have to disable buffering here, otherwise - # when we read data in $c readable {} we many leave buffered - # data and readable won't retrigger. - $c buffering none $s close + $c ndelay 1 $c readable { - # when we read we need to also read any pending data, - # otherwise readable won't retrigger - set buf [$c read 1] - if {[string length $buf] == 0} { + # read everything available (non-blocking read) + set buf [$c read] + if {[string length $buf]} { + $c puts -nonewline $buf + $c flush + } + if {[$c eof]} { incr readdone $c close - } else { - $c puts -nonewline $buf } } vwait readdone @@ -365,6 +365,8 @@ defer { } $s close +$cs buffering line + # At this point, $cs is the server connection to the client in the child process test eventloop-1.1 {puts/gets} { @@ -372,14 +374,67 @@ test eventloop-1.1 {puts/gets} { $cs gets } hello -test eventloop-1.2 {puts/gets} { +test eventloop-1.2 {puts/read} { $cs puts -nonewline again + $cs flush lmap p [range 5] { set c [$cs read 1] set c } } {a g a i n} +test eventloop-1.3 {gets with no timeout and multiple newlines} { + $cs puts a\nb\nc\nd\ne + lmap p [range 5] { + $cs gets buf + set buf + } +} {a b c d e} + +test eventloop-1.4 {gets with timeout and multiple newlines} { + $cs timeout 100 + $cs puts a\nb\nc\nd\ne + lmap p [range 6] { + set rc [$cs gets buf] + set buf + } +} {a b c d e {}} + +test eventloop-1.5 {gets with timeout and incomplete line} { + $cs timeout 100 + $cs puts -nonewline first + list [$cs gets buf] $buf +} {-1 {}} + +test eventloop-1.6 {gets with timeout and complete line} { + $cs timeout 100 + $cs puts second + list [$cs gets buf] $buf +} {11 firstsecond} + +test eventloop-1.7 {gets when read with extra data} { + $cs timeout 100 + $cs puts -nonewline abcde + $cs flush + # This won't get get a line + $cs gets line + # now read should read the data + set data [$cs read -nonewline] + list $line $data +} {{} abcde} + +test eventloop-1.7 {read with timeout and no data} { + $cs timeout 100 + $cs read +} {} + +test eventloop-1.6 {read with timeout and data} { + $cs timeout 100 + $cs puts -nonewline data + $cs flush + $cs read +} {data} + test sockopt-1.1 {sockopt} -body { lsort [dict keys [$cs sockopt]] } -match glob -result {*tcp_nodelay*} diff --git a/tests/ssl.test b/tests/ssl.test index b01069d..d147c92 100644 --- a/tests/ssl.test +++ b/tests/ssl.test @@ -17,16 +17,16 @@ if {[os.fork] == 0} { # child set c [[socket stream 127.0.0.1:1443] ssl] $s close + $c ndelay 1 sleep 0.25 $c readable { - # when we read we need to also read any pending data, - # otherwise readable won't retrigger - set buf [$c read -pending] - if {[string length $buf] == 0} { + # read everything available and echo it back + set buf [$c read] + $c puts -nonewline $buf + $c flush + if {[$c eof]} { incr ssldone $c close - } else { - $c puts -nonewline $buf } } vwait ssldone @@ -42,6 +42,7 @@ defer { } # At this point, $cs is the server connection to the client in the child process +$cs buffering line test ssl-1.1 {puts/gets} { $cs puts hello @@ -50,6 +51,7 @@ test ssl-1.1 {puts/gets} { test ssl-1.2 {puts/gets} { $cs puts -nonewline again + $cs flush lmap p [range 5] { set c [$cs read 1] set c |