diff options
Diffstat (limited to 'tests/socket.test')
| -rw-r--r-- | tests/socket.test | 248 |
1 files changed, 223 insertions, 25 deletions
diff --git a/tests/socket.test b/tests/socket.test index 09b34ad..51219e6 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -63,14 +63,32 @@ package require tcltest 2 namespace import -force ::tcltest::* -# Some tests require the testthread and exec commands -testConstraint testthread [llength [info commands testthread]] +# Some tests require the Thread package or exec command +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range # 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. # @@ -99,15 +117,28 @@ if 0 { } foreach {af localhost} { - any 127.0.0.1 inet 127.0.0.1 inet6 ::1 } { - set ::tcl::unsupported::socketAF $af # Check if the family is supported and set the constraint accordingly - testConstraint supported_$af [expr {![catch {socket -server foo 0} sock]}] + testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}] catch {close $sock} - +} +testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] + +set sock [socket -server foo -myaddr localhost 0] +set sockname [fconfigure $sock -sockname] +close $sock +testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}] +testConstraint localhost_v6 [expr {"::1" in $sockname}] + + +foreach {af localhost} { + any 127.0.0.1 + inet 127.0.0.1 + inet6 ::1 +} { + set ::tcl::unsupported::socketAF $af # # Check if we're supposed to do tests against the remote server # @@ -584,7 +615,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] @@ -800,6 +831,24 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ interp bgerror {} $handler } -result {divide by zero} +test socket_$af-6.2 { + readable fileevent on server socket +} -setup { + set sock [socket -server dummy 0] +} -constraints [list socket supported_$af] -body { + fileevent $sock readable dummy +} -cleanup { + close $sock +} -returnCodes 1 -result "channel is not readable" + +test socket_$af-6.3 {writable fileevent on server socket} -setup { + set sock [socket -server dummy 0] +} -constraints [list socket supported_$af] -body { + fileevent $sock writable dummy +} -cleanup { + close $sock +} -returnCodes 1 -result "channel is not writable" + test socket_$af-7.1 {testing socket specific options} -setup { file delete $path(script) set f [open $path(script) w] @@ -1592,7 +1641,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 - after 5000 set failed 1 + set after [after 5000 [list set failed 1]] proc getdata { file } { # Read handler on the client socket. global x @@ -1619,12 +1668,13 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { vwait x return $x } -cleanup { + after cancel $after catch {close $p} } -result {accepted socket was not inherited} -test socket_$af-13.1 {Testing use of shared socket between two threads} -setup { - threadReap - set path(script) [makeFile [string map [list @localhost@ $localhost] { +test socket_$af-13.1 {Testing use of shared socket between two threads} -body { + # create a thread + set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] { set f [socket -server accept -myaddr @localhost@ 0] set listen [lindex [fconfigure $f -sockname] 2] proc accept {s a p} { @@ -1646,15 +1696,9 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup { set i 0 vwait x close $f - # thread cleans itself up. - testthread exit - }] script] -} -constraints [list socket supported_$af testthread] -body { - # create a thread - set serverthread [testthread create [list source $path(script) ] ] - update - set port [testthread send $serverthread {set listen}] - update + thread::wait + }]] + set port [thread::send $serverthread {set listen}] set s [socket $localhost $port] fconfigure $s -buffering line catch { @@ -1662,11 +1706,9 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup { gets $s result } close $s - update - append result " " [threadReap] -} -cleanup { - removeFile script -} -result {hello 1} + thread::release $serverthread + append result " " [llength [thread::names]] +} -result {hello 1} -constraints [list socket supported_$af thread] # ---------------------------------------------------------------------- @@ -1680,6 +1722,162 @@ if {$remoteProcChan ne ""} { catch {close $commandSocket} catch {close $remoteProcChan} } +unset ::tcl::unsupported::socketAF +test socket-14.0 {[socket -async] when server only listens on IPv4} \ + -constraints [list socket supported_any localhost_v4] \ + -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 localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + set after [after 1000 {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x; # we only want to see both events, the order doesn't matter + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result {{} ok} +test socket-14.2 {[socket -async] fileevent connection refused} \ + -constraints [list socket supported_any] \ + -body { + if {[catch {socket -async localhost [randport]} client]} { + regexp {[^:]*: (.*)} $client -> x + } else { + fileevent $client writable {set x [fconfigure $client -error]} + set after [after 1000 {set x timeout}] + vwait x + after cancel $after + if {$x eq "timeout"} { + append x ": [fconfigure $client -error]" + } + close $client + } + set x + } -cleanup { + unset x + } -result "connection refused" +test socket-14.3 {[socket -async] when server only listens on IPv6} \ + -constraints [list socket supported_any localhost_v6] \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::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.4 {[socket -async] and both, readdable and writable fileevents} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + fileevent $client readable {lappend x [gets $client]} + set after [after 1000 {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x + } -cleanup { + after cancel $after + close $client + close $server + unset x + } -result {{} bye} +test socket-14.5 {[socket -async] which fails before any connect() can be made} \ + -constraints [list socket supported_any] \ + -body { + # address from rfc5737 + socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] + } \ + -returnCodes 1 \ + -result {couldn't open socket: cannot assign requested address} +test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ + -constraints [list socket supported_inet supported_inet6] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + foreach _ {1 2} { + lappend x [lindex [fconfigure $client -sockname] 0] + lappend x [fconfigure $client -error] + update + } + lappend x [gets $client] + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result [list ::1 "connection refused" 127.0.0.1 "" bye] + ::tcltest::cleanupTests flush stdout return |