--- 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
 }
 
 # -------------------------------------------------------------------------
