Merge fixes for [socket -async] and other improvements to the unix socket code

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