Attachment "tcllib-dns.patch" to
ticket [6c1c739c78]
added by
anonymous
2014-05-13 17:58:29.
--- modules/dns/dns.tcl.orig 2014-05-13 12:46:59.000000000 -0500
+++ modules/dns/dns.tcl 2014-05-13 12:48:28.000000000 -0500
@@ -69,12 +69,12 @@
}
variable types
- array set types {
- A 1 NS 2 MD 3 MF 4 CNAME 5 SOA 6 MB 7 MG 8 MR 9
+ array set types {
+ A 1 NS 2 MD 3 MF 4 CNAME 5 SOA 6 MB 7 MG 8 MR 9
NULL 10 WKS 11 PTR 12 HINFO 13 MINFO 14 MX 15 TXT 16
SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252 MAILB 253 MAILA 254
ANY 255 * 255
- }
+ }
variable classes
array set classes { IN 1 CS 2 CH 3 HS 4 * 255}
@@ -107,25 +107,25 @@
if {[llength $args] == 1} {
set cget 1
}
-
+
while {[string match -* [lindex $args 0]]} {
switch -glob -- [lindex $args 0] {
-n* -
-ser* {
if {$cget} {
- return $options(nameserver)
+ return $options(nameserver)
} else {
- set options(nameserver) [Pop args 1]
+ set options(nameserver) [Pop args 1]
}
}
- -po* {
+ -po* {
if {$cget} {
return $options(port)
} else {
- set options(port) [Pop args 1]
+ set options(port) [Pop args 1]
}
}
- -ti* {
+ -ti* {
if {$cget} {
return $options(timeout)
} else {
@@ -142,14 +142,14 @@
return -code error "invalid protocol \"$proto\":\
protocol must be either \"udp\" or \"tcp\""
}
- set options(protocol) $proto
+ set options(protocol) $proto
}
}
- -sea* {
+ -sea* {
if {$cget} {
return $options(search)
} else {
- set options(search) [Pop args 1]
+ set options(search) [Pop args 1]
}
}
-log* {
@@ -214,7 +214,7 @@
foreach {opt value} [uri::split $query] {
if {$value != {} && [info exists state(-$opt)]} {
set state(-$opt) $value
- }
+ }
}
set state(query) $URI(query)
${log}::debug "parsed query: $query"
@@ -255,7 +255,7 @@
get ceptcl or tcludp"
}
}
-
+
# Check for reverse lookups
if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
set addr [lreverse [split $state(query) .]]
@@ -265,7 +265,7 @@
}
BuildMessage $token
-
+
if {$state(-protocol) == "tcp"} {
TcpTransmit $token
if {$state(-command) == {}} {
@@ -274,7 +274,7 @@
} else {
UdpTransmit $token
}
-
+
return $token
}
@@ -460,7 +460,7 @@
# FRINK: nocheck
variable $token
upvar 0 $token state
-
+
set result {}
switch -glob -- $type {
-qu* -
@@ -543,7 +543,7 @@
append state(request) $qsection $nsdata
}
1 {
- # IQUERY
+ # IQUERY
set state(request) [binary format SSSSSS $state(id) \
[expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
0 $qdcount 0 0 0]
@@ -603,9 +603,9 @@
switch -exact -- $rr(type) {
CNAME - MB - MD - MF - MG - MR - NS - PTR {
- set rr(rdata) [PackName $rr(rdata)]
+ set rr(rdata) [PackName $rr(rdata)]
}
- HINFO {
+ HINFO {
array set r {CPU {} OS {}}
array set r $rr(rdata)
set rr(rdata) [PackString $r(CPU)]
@@ -630,7 +630,7 @@
set s [string range $str $n [incr n 253]]
append rr(rdata) [PackString $s]
}
- }
+ }
NULL {}
SOA {
array set r {MNAME {} RNAME {}
@@ -721,7 +721,7 @@
$token timeout\
"operation timed out"]]
}
-
+
if {[llength [package provide ceptcl]] > 0} {
# using ceptcl
set state(sock) [cep -type datagram $state(-nameserver) $state(-port)]
@@ -734,9 +734,9 @@
fconfigure $state(sock) -translation binary -buffering none
set state(status) connect
puts -nonewline $state(sock) $state(request)
-
+
fileevent $state(sock) readable [list [namespace current]::UdpEvent $token]
-
+
return $token
}
@@ -799,7 +799,7 @@
switch -- $status {
0 {
set state(status) ok
- Finish $token
+ Finish $token
}
1 { Finish $token "Format error - unable to interpret the query." }
2 { Finish $token "Server failure - internal server error." }
@@ -838,10 +838,10 @@
# Handle incomplete reads - check the size and keep reading.
if {![info exists state(size)]} {
binary scan $result S state(size)
- set result [string range $result 2 end]
+ set result [string range $result 2 end]
}
append state(reply) $result
-
+
# check the length and flags and chop off the tcp length prefix.
if {[string length $state(reply)] >= $state(size)} {
binary scan $result S id
@@ -891,14 +891,14 @@
#Receive [namespace current]::$id
Receive $token
}
-
+
# -------------------------------------------------------------------------
proc ::dns::Flags {token {varname {}}} {
# FRINK: nocheck
variable $token
upvar 0 $token state
-
+
if {$varname != {}} {
upvar $varname flags
}
@@ -1051,7 +1051,7 @@
set r {}
lappend r name [ReadName data $index offset]
incr index $offset
-
+
# Read off QTYPE and QCLASS for this query.
set ndx $index
incr index 3
@@ -1065,10 +1065,10 @@
}
return $result
}
-
+
# -------------------------------------------------------------------------
-# Read an answer section from a DNS message.
+# Read an answer section from a DNS message.
#
proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} {
variable types
@@ -1080,7 +1080,7 @@
set r {}
lappend r name [ReadName data $index offset]
incr index $offset
-
+
# Read off TYPE, CLASS, TTL and RDLENGTH
binary scan [string range $data $index end] SSIS type class ttl rdlength
@@ -1104,7 +1104,7 @@
set rdata [ip::contract [ip::ToString $rdata]]
}
NS - CNAME - PTR {
- set rdata [ReadName data $index off]
+ set rdata [ReadName data $index off]
}
MX {
binary scan $rdata S preference
@@ -1128,7 +1128,7 @@
SOA {
set x $index
set rdata [list MNAME [ReadName data $x off]]
- incr x $off
+ incr x $off
lappend rdata RNAME [ReadName data $x off]
incr x $off
lappend rdata SERIAL [ReadULong data $x off]
@@ -1154,7 +1154,7 @@
# Read a 32bit integer from a DNS packet. These are compatible with
-# the ReadName proc. Additionally - ReadULong takes measures to ensure
+# the ReadName proc. Additionally - ReadULong takes measures to ensure
# the unsignedness of the value obtained.
#
proc ::dns::ReadLong {datavar index usedvar} {
@@ -1176,8 +1176,8 @@
if {[binary scan $data @${index}cccc b1 b2 b3 b4]} {
set used 4
# This gets us an unsigned value.
- set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
- + (($b2 & 0xFF) << 16) + ($b1 << 24)}]
+ set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
+ + (($b2 & 0xFF) << 16) + ($b1 << 24)}]
}
return $r
}
@@ -1190,12 +1190,12 @@
if {[binary scan [string range $data $index end] cc b1 b2]} {
set used 2
# This gets us an unsigned value.
- set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
+ set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
}
return $r
}
-# Read off the NAME or QNAME element. This reads off each label in turn,
+# Read off the NAME or QNAME element. This reads off each label in turn,
# dereferencing pointer labels until we have finished. The length of data
# used is passed back using the usedvar variable.
#
@@ -1207,13 +1207,13 @@
set r {}
set len 1
set max [string length $data]
-
+
while {$len != 0 && $index < $max} {
# Read the label length (and preread the pointer offset)
binary scan [string range $data $index end] cc len lenb
set len [expr {$len & 0xFF}]
incr index
-
+
if {$len != 0} {
if {[expr {$len & 0xc0}]} {
binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
@@ -1327,18 +1327,18 @@
catch {
uri::register {dns} {
- set escape [set [namespace parent [namespace current]]::basic::escape]
- set host [set [namespace parent [namespace current]]::basic::host]
- set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+ variable hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort]
- set class [string map {* \\\\*} \
+ variable class [string map {* \\\\*} \
"class=([join [array names ::dns::classes] {|}])"]
- set type [string map {* \\\\*} \
+ variable type [string map {* \\\\*} \
"type=([join [array names ::dns::types] {|}])"]
- set classOrType "(?:${class}|${type})"
- set classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?"
+ variable classOrType "(?:${class}|${type})"
+ variable classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?"
- set query "${host}(${classOrTypeSpec})?"
+ variable query "${host}(${classOrTypeSpec})?"
variable schemepart "(//${hostOrPort}/)?(${query})"
variable url "dns:$schemepart"
}
@@ -1378,7 +1378,7 @@
set parts(nameserver) $tmp(host)
set parts(port) $tmp(port)
}
-
+
# what's left is the query domain name.
set parts(query) [string trimleft $uri /]
}
