Artifact
3c33f9299c2dcf6a126c8ccfdc0d8817391b7b7b:
Attachment "dns.diff" to
ticket [1610330fff]
added by
teopetuk
2006-12-07 01:52:04.
--- dns.tcl.orig 2006-10-08 13:36:59.000000000 +0400
+++ dns.tcl 2006-12-06 21:14:49.000000000 +0300
@@ -660,10 +660,6 @@
variable $token
upvar 0 $token state
- # For TCP the message must be prefixed with a 16bit length field.
- set req [binary format S [string length $state(request)]]
- append req $state(request)
-
# setup the timeout
if {$state(-timeout) > 0} {
set state(after) [after $state(-timeout) \
@@ -672,16 +668,36 @@
"operation timed out"]]
}
- set s [socket $state(-nameserver) $state(-port)]
- fconfigure $s -blocking 0 -translation binary -buffering none
+ # Sometimes DNS servers drop TCP requests. So it's better to
+ # use asynchronous connect
+ set s [socket -async $state(-nameserver) $state(-port)]
+ fileevent $s writable [list [namespace origin TcpConnected] $token $s]
set state(sock) $s
set state(status) connect
+ return $token
+}
+
+proc ::dns::TcpConnected {token s} {
+ variable $token
+ upvar 0 $token state
+
+ fileevent $s writable {}
+ if {[catch {fconfigure $s -peername}]} {
+ # TCP connection failed
+ Finish $token "can't connect to server"
+ return
+ }
+
+ fconfigure $s -blocking 0 -translation binary -buffering none
+
+ # For TCP the message must be prefixed with a 16bit length field.
+ set req [binary format S [string length $state(request)]]
+ append req $state(request)
+
puts -nonewline $s $req
fileevent $s readable [list [namespace current]::TcpEvent $token]
-
- return $token
}
# -------------------------------------------------------------------------
