diff options
Diffstat (limited to 'tests/socket.test')
| -rw-r--r-- | tests/socket.test | 86 |
1 files changed, 85 insertions, 1 deletions
diff --git a/tests/socket.test b/tests/socket.test index 4a9bcb9..7f5c5c2 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -71,6 +71,24 @@ testConstraint exec [llength [info commands exec]] # from 49152 through 65535. proc randport {} { expr {int(rand()*16383+49152)} } +# Test the latency of tcp connections over the loopback interface. Some OSes +# (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes +# up to 200ms for a packet sent to localhost to arrive. We're measuring this +# here, so that OSes that don't have this problem can run the tests at full +# speed. +set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0] +set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]] +vwait s1; close $server +fconfigure $s1 -buffering line +fconfigure $s2 -buffering line +set t1 [clock milliseconds] +puts $s2 test1; gets $s1 +puts $s2 test2; gets $s1 +close $s1; close $s2 +set t2 [clock milliseconds] +set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin +unset t1 t2 s1 s2 server + # If remoteServerIP or remoteServerPort are not set, check in the environment # variables for externally set values. # @@ -584,7 +602,7 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a fconfigure $sock -blocking 1 puts $s2 two flush $s2 - after idle {set x 1} + after $latency {set x 1}; # NetBSD fails here if we do [after idle] vwait x fconfigure $sock -blocking 0 lappend result c:[gets $sock] @@ -1699,6 +1717,72 @@ if {$remoteProcChan ne ""} { catch {close $commandSocket} catch {close $remoteProcChan} } +unset ::tcl::unsupported::socketAF +test socket-14.0 {[socket -async] when server only listens on one address family} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after 1000 {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.1 {[socket -async] fileevent while still connecting} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + lappend x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [expr {[fconfigure $client -error] eq ""}] + } + set after [after 1000 {set x timeout}] + vwait x + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result {ok 1} +test socket-14.2 {[socket -async] fileevent connection refused} \ + -constraints [list socket supported_any] \ + -body { + set client [socket -async localhost [randport]] + fileevent $client writable {set x [fconfigure $client -error]} + set after [after 1000 {set x timeout}] + vwait x + if {$x eq "timeout"} { + append x ": [fconfigure $client -error]" + } + set x + } -cleanup { + after cancel $after + close $client + unset x + } -result "connection refused" + ::tcltest::cleanupTests flush stdout return |