1 # dns.tcl - Steve Bennett <steveb@workware.net.au>
3 # Modified for Jim Tcl to:
4 # - use udp transport by default
5 # - use sendto/recvfrom
6 # - don't try to determine local nameservers
7 # - remove support for dns uris and finding local nameservers
8 # - remove logging calls
9 # (both of these in order to remove dependencies on tcllib)
13 # dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
15 # Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035
16 # for information about the DNS protocol. This should insulate Tcl scripts
17 # from problems with using the system library resolver for slow name servers.
19 # This implementation uses TCP only for DNS queries. The protocol reccommends
20 # that UDP be used in these cases but Tcl does not include UDP sockets by
21 # default. The package should be simple to extend to use a TclUDP extension
24 # Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
25 # if or when the proposed draft becomes accepted.
27 # Support added for RFC1886 - DNS Extensions to support IP version 6
28 # Support added for RFC2782 - DNS RR for specifying the location of services
29 # Support added for RFC1995 - Incremental Zone Transfer in DNS
32 # - When using tcp we should make better use of the open connection and
33 # send multiple queries along the same connection.
35 # - We must switch to using TCP for truncated UDP packets.
37 # - Read RFC 2136 - dynamic updating of DNS
39 # -------------------------------------------------------------------------
40 # See the file "license.terms" for information on usage and redistribution
41 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
42 # -------------------------------------------------------------------------
44 # $Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $
46 package require
binary
47 package require
namespace
49 namespace eval ::dns {
50 variable version
1.3.3-jim2
51 variable rcsid
{$Id: dns.tcl
,v
1.36 2008/11/22 12:28:54 mic42 Exp
$}
53 namespace export configure resolve name address cname
\
54 status reset wait cleanup errorcode
57 if {![info exists
options]} {
63 nameserver
{localhost
}
66 #variable log [logger::init dns]
67 #${log}::setlevel $options(loglevel)
72 A
1 NS
2 MD
3 MF
4 CNAME
5 SOA
6 MB
7 MG
8 MR
9
73 NULL
10 WKS
11 PTR
12 HINFO
13 MINFO
14 MX
15 TXT
16
74 SPF
16 AAAA
28 SRV
33 IXFR
251 AXFR
252 MAILB
253 MAILA
254
79 array set classes
{ IN
1 CS
2 CH
3 HS
4 * 255}
82 if {![info exists uid
]} {
87 # -------------------------------------------------------------------------
90 # Configure the DNS package. In particular the local nameserver will need
91 # to be set. With no options, returns a list of all current settings.
93 proc ::dns::configure {args
} {
97 if {[llength $args] < 1} {
99 foreach opt
[lsort [array names
options]] {
100 lappend r
-$opt $options($opt)
106 if {[llength $args] == 1} {
110 while {[string match
-* [lindex $args 0]]} {
111 switch -glob -- [lindex $args 0] {
115 return $options(nameserver
)
117 set options(nameserver
) [Pop args
1]
122 return $options(port
)
124 set options(port
) [Pop args
1]
129 return $options(timeout
)
131 set options(timeout
) [Pop args
1]
136 return $options(protocol
)
138 set proto
[string tolower
[Pop args
1]]
139 if {[string compare udp
$proto] == 0 \
140 && [string compare tcp
$proto] == 0} {
141 return -code error "invalid protocol \"$proto\":\
142 protocol must be either \"udp\" or \"tcp\""
144 set options(protocol
) $proto
149 return $options(search
)
151 set options(search
) [Pop args
1]
156 return $options(loglevel
)
158 set options(loglevel
) [Pop args
1]
159 ${log
}::setlevel $options(loglevel
)
162 -- { Pop args
; break }
164 set opts
[join [lsort [array names
options]] ", -"]
165 return -code error "bad option [lindex $args 0]:\
166 must be one of -$opts"
175 # -------------------------------------------------------------------------
178 # Create a DNS query and send to the specified name server. Returns a token
179 # to be used to obtain any further information about this query.
181 proc ::dns::resolve {query args
} {
186 # get a guaranteed unique and non-present token id.
188 while {[info exists
[set token
[namespace current
]::$id]]} {
195 # Setup token/state defaults.
197 set state
(query
) $query
199 set state
(opcode
) 0; # 0 = query, 1 = inverse query.
200 set state
(-type) A
; # DNS record type (A address)
201 set state
(-class) IN
; # IN (internet address space)
202 set state
(-recurse) 1; # Recursion Desired
203 set state
(-command) {}; # asynchronous handler
204 set state
(-timeout) $options(timeout
); # connection timeout default.
205 set state
(-nameserver) $options(nameserver
);# default nameserver
206 set state
(-port) $options(port
); # default namerservers port
207 set state
(-search) $options(search
); # domain search list
208 set state
(-protocol) $options(protocol
); # which protocol udp/tcp
210 # Support for DNS URL's removed
212 while {[string match
-* [lindex $args 0]]} {
213 switch -glob -- [lindex $args 0] {
215 -ser* { set state
(-nameserver) [Pop args
1] }
216 -po* { set state
(-port) [Pop args
1] }
217 -ti* { set state
(-timeout) [Pop args
1] }
218 -co* { set state
(-command) [Pop args
1] }
219 -cl* { set state
(-class) [Pop args
1] }
220 -ty* { set state
(-type) [Pop args
1] }
221 -pr* { set state
(-protocol) [Pop args
1] }
222 -sea* { set state
(-search) [Pop args
1] }
223 -re* { set state
(-recurse) [Pop args
1] }
224 -inv* { set state
(opcode
) 1 }
225 -status {set state
(opcode
) 2}
226 -data { set state
(qdata
) [Pop args
1] }
228 set opts
[join [lsort [array names state
-*]] ", "]
229 return -code error "bad option [lindex $args 0]: \
236 if {$state(-nameserver) == {}} {
237 return -code error "no nameserver specified"
240 # Check for reverse lookups
241 if {[regexp {^
(?
:\d
{0,3}\.
){3}\d
{0,3}$} $state(query
)]} {
242 set addr
[lreverse
[split $state(query
) .
]]
243 lappend addr in-addr arpa
244 set state
(query
) [join $addr .
]
250 if {$state(-protocol) == "tcp"} {
252 if {$state(-command) == {}} {
263 # -------------------------------------------------------------------------
266 # Return a list of domain names returned as results for the last query.
268 proc ::dns::name {token
} {
271 array set reply
[Decode
$token]
273 switch -exact -- $flags(opcode
) {
276 foreach answer
$reply(AN
) {
278 if {![info exists AN
(type
)]} {set AN
(type
) {}}
279 switch -exact -- $AN(type
) {
281 if {[info exists AN
(rdata
)]} {lappend r
$AN(rdata
)}
284 if {[info exists AN
(name
)]} {
294 foreach answer
$reply(QD
) {
300 return -code error "not supported for this query type"
307 # Return a list of the IP addresses returned for this query.
309 proc ::dns::address {token
} {
311 array set reply
[Decode
$token]
312 foreach answer
$reply(AN
) {
315 if {[info exists AN
(type
)]} {
316 switch -exact -- $AN(type
) {
330 # Return a list of all CNAME results returned for this query.
332 proc ::dns::cname {token
} {
334 array set reply
[Decode
$token]
335 foreach answer
$reply(AN
) {
338 if {[info exists AN
(type
)]} {
339 if {$AN(type
) == "CNAME"} {
348 # Return the decoded answer records. This can be used for more complex
349 # queries where the answer isn't supported byb cname/address/name.
350 proc ::dns::result {token args
} {
351 array set reply
[eval [linsert $args 0 Decode
$token]]
355 # -------------------------------------------------------------------------
358 # Get the status of the request.
360 proc ::dns::status {token
} {
361 upvar #0 $token state
362 return $state(status
)
366 # Get the error message. Empty if no error.
368 proc ::dns::error {token
} {
369 upvar #0 $token state
370 if {[info exists state
(error)]} {
377 # Get the error code. This is 0 for a successful transaction.
379 proc ::dns::errorcode {token
} {
380 upvar #0 $token state
381 set flags
[Flags
$token]
382 set ndx
[lsearch -exact $flags errorcode
]
384 return [lindex $flags $ndx]
388 # Reset a connection with optional reason.
390 proc ::dns::reset {token
{why reset
} {errormsg
{}}} {
391 upvar #0 $token state
392 set state
(status
) $why
393 if {[string length
$errormsg] > 0 && ![info exists state
(error)]} {
394 set state
(error) $errormsg
396 catch {fileevent $state(sock
) readable
{}}
401 # Wait for a request to complete and return the status.
403 proc ::dns::wait {token
} {
404 upvar #0 $token state
406 if {$state(status
) == "connect"} {
407 vwait [subst $token](status
)
410 return $state(status
)
414 # Remove any state associated with this token.
416 proc ::dns::cleanup {token
} {
417 upvar #0 $token state
418 if {[info exists state
]} {
419 catch {close $state(sock
)}
420 catch {after cancel
$state(after)}
425 # -------------------------------------------------------------------------
428 # Dump the raw data of the request and reply packets.
430 proc ::dns::dump {args
} {
431 if {[llength $args] == 1} {
433 set token
[lindex $args 0]
434 } elseif
{ [llength $args] == 2 } {
435 set type
[lindex $args 0]
436 set token
[lindex $args 1]
438 return -code error "wrong # args:\
439 should be \"dump ?option? methodName\""
447 switch -glob -- $type {
450 set result
[DumpMessage
$state(request
)]
453 set result
[DumpMessage
$state(reply
)]
456 error "unrecognised option: must be one of \
457 \"-query\", \"-request\" or \"-reply\""
465 # Perform a hex dump of binary data.
467 proc ::dns::DumpMessage {data
} {
469 binary scan $data c
* r
471 append result
[format "%02x " [expr {$c & 0xff}]]
476 # -------------------------------------------------------------------------
479 # Contruct a DNS query packet.
481 proc ::dns::BuildMessage {token
} {
489 if {! [info exists types
($state(-type))] } {
490 return -code error "invalid DNS query type"
493 if {! [info exists classes
($state(-class))] } {
494 return -code error "invalid DNS query class"
502 # In theory we can send multiple queries. In practice, named doesn't
503 # appear to like that much. If it did work we'd do this:
504 # foreach domain [linsert $options(search) 0 {}] ...
507 # Pack the query: QNAME QTYPE QCLASS
508 set qsection
[PackName
$state(query
)]
509 append qsection
[binary format SS
\
510 $types($state(-type))\
511 $classes($state(-class))]
514 if {[string length
$state(qdata
)] > 0} {
515 set nsdata
[eval [linsert $state(qdata
) 0 PackRecord
]]
519 switch -exact -- $state(opcode
) {
522 set state
(request
) [binary format SSSSSS
$state(id
) \
523 [expr {($state(opcode
) << 11) |
($state(-recurse) << 8)}] \
524 $qdcount 0 $nscount 0]
525 append state
(request
) $qsection $nsdata
529 set state
(request
) [binary format SSSSSS
$state(id
) \
530 [expr {($state(opcode
) << 11) |
($state(-recurse) << 8)}] \
532 append state
(request
) \
533 [binary format cSSI
0 \
534 $types($state(-type)) $classes($state(-class)) 0]
535 switch -exact -- $state(-type) {
537 append state
(request
) \
538 [binary format Sc4
4 [split $state(query
) .
]]
541 append state
(request
) \
542 [binary format Sc4
4 [split $state(query
) .
]]
545 return -code error "inverse query not supported for this type"
550 return -code error "operation not supported"
557 # Pack a human readable dns name into a DNS resource record format.
558 proc ::dns::PackName {name
} {
560 foreach part
[split [string trim
$name .
] .
] {
561 set len
[string length
$part]
562 append data
[binary format ca
$len $len $part]
568 # Pack a character string - byte length prefixed
569 proc ::dns::PackString {text} {
570 set len
[string length
$text]
571 set data
[binary format ca
$len $len $text]
575 # Pack up a single DNS resource record. See RFC1035: 3.2 for the format
577 # eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com}
579 proc ::dns::PackRecord {args
} {
582 array set rr
{name
"" type A class IN ttl
0 rdlength
0 rdata
""}
584 set data
[PackName
$rr(name
)]
586 switch -exact -- $rr(type
) {
587 CNAME
- MB
- MD
- MF
- MG
- MR
- NS
- PTR
{
588 set rr
(rdata
) [PackName
$rr(rdata
)]
591 array set r
{CPU
{} OS
{}}
592 array set r
$rr(rdata
)
593 set rr
(rdata
) [PackString
$r(CPU
)]
594 append rr
(rdata
) [PackString
$r(OS
)]
597 array set r
{RMAILBX
{} EMAILBX
{}}
598 array set r
$rr(rdata
)
599 set rr
(rdata
) [PackString
$r(RMAILBX
)]
600 append rr
(rdata
) [PackString
$r(EMAILBX
)]
603 foreach {pref exch
} $rr(rdata
) break
604 set rr
(rdata
) [binary format S
$pref]
605 append rr
(rdata
) [PackName
$exch]
609 set len
[string length
[set str
$rr(rdata
)]]
611 for {set n
0} {$n < $len} {incr n
} {
612 set s
[string range
$str $n [incr n
253]]
613 append rr
(rdata
) [PackString
$s]
618 array set r
{MNAME
{} RNAME
{}
619 SERIAL
0 REFRESH
0 RETRY
0 EXPIRE
0 MINIMUM
0}
620 array set r
$rr(rdata
)
621 set rr
(rdata
) [PackName
$r(MNAME
)]
622 append rr
(rdata
) [PackName
$r(RNAME
)]
623 append rr
(rdata
) [binary format IIIII
$r(SERIAL
) \
624 $r(REFRESH
) $r(RETRY
) $r(EXPIRE
) $r(MINIMUM
)]
628 # append the root label and the type flag and query class.
629 append data
[binary format SSIS
$types($rr(type
)) \
630 $classes($rr(class
)) $rr(ttl
) [string length
$rr(rdata
)]]
631 append data
$rr(rdata
)
635 # -------------------------------------------------------------------------
638 # Transmit a DNS request over a tcp connection.
640 proc ::dns::TcpTransmit {token
} {
646 if {$state(-timeout) > 0} {
647 set state
(after) [after $state(-timeout) \
648 [list [namespace origin reset
] \
650 "operation timed out"]]
653 # Jim Tcl has no async connect ...
655 set s
[socket stream
$state(-nameserver):$state(-port)]
656 fileevent $s writable
[list [namespace origin TcpConnected
] $token $s]
658 set state
(status
) connect
663 proc ::dns::TcpConnected {token s
} {
667 fileevent $s writable
{}
669 # Jim Tcl has no async connect ...
670 # if {[catch {fconfigure $s -peername}]} {
671 # # TCP connection failed
672 # Finish $token "can't connect to server"
676 fconfigure $s -blocking 0 -translation binary -buffering none
678 # For TCP the message must be prefixed with a 16bit length field.
679 set req
[binary format S
[string length
$state(request
)]]
680 append req
$state(request
)
682 puts -nonewline $s $req
684 fileevent $s readable
[list [namespace current
]::TcpEvent $token]
687 # -------------------------------------------------------------------------
689 # Transmit a DNS request using UDP datagrams
692 # This requires a UDP implementation that can transmit binary data.
693 # As yet I have been unable to test this myself and the tcludp package
696 proc ::dns::UdpTransmit {token
} {
702 if {$state(-timeout) > 0} {
703 set state
(after) [after $state(-timeout) \
704 [list [namespace origin reset
] \
706 "operation timed out"]]
709 set state
(sock
) [socket dgram
]
710 #fconfigure $state(sock) -translation binary -buffering none
711 set state
(status
) connect
712 $state(sock
) sendto
$state(request
) $state(-nameserver):$state(-port)
714 fileevent $state(sock
) readable
[list [namespace current
]::UdpEvent $token]
719 # -------------------------------------------------------------------------
722 # Tidy up after a tcp transaction.
724 proc ::dns::Finish {token
{errormsg
""}} {
728 global errorInfo errorCode
730 if {[string length
$errormsg] != 0} {
731 set state
(error) $errormsg
732 set state
(status
) error
734 catch {close $state(sock
)}
735 catch {after cancel
$state(after)}
736 if {[info exists state
(-command)] && $state(-command) != {}} {
737 if {[catch {eval $state(-command) {$token}} err
]} {
738 if {[string length
$errormsg] == 0} {
739 set state
(error) [list $err $errorInfo $errorCode]
740 set state
(status
) error
743 if {[info exists state
(-command)]} {
744 unset state
(-command)
749 # -------------------------------------------------------------------------
752 # Handle end-of-file on a tcp connection.
754 proc ::dns::Eof {token
} {
758 set state
(status
) eof
762 # -------------------------------------------------------------------------
765 # Process a DNS reply packet (protocol independent)
767 proc ::dns::Receive {token
} {
772 binary scan $state(reply
) SS id flags
773 set status
[expr {$flags & 0x000F}]
780 1 { Finish
$token "Format error - unable to interpret the query." }
781 2 { Finish
$token "Server failure - internal server error." }
782 3 { Finish
$token "Name Error - domain does not exist" }
783 4 { Finish
$token "Not implemented - the query type is not available." }
784 5 { Finish
$token "Refused - your request has been refused by the server." }
786 Finish
$token "unrecognised error code: $err"
791 # -------------------------------------------------------------------------
794 # file event handler for tcp socket. Wait for the reply data.
796 proc ::dns::TcpEvent {token
} {
808 set status
[catch {read $state(sock
)} result
]
810 ${log
}::debug "Event error: $result"
811 Finish
$token "error reading data: $result"
812 } elseif
{ [string length
$result] >= 0 } {
814 # Handle incomplete reads - check the size and keep reading.
815 if {![info exists state
(size
)]} {
816 binary scan $result S state
(size
)
817 set result
[string range
$result 2 end
]
819 append state
(reply
) $result
821 # check the length and flags and chop off the tcp length prefix.
822 if {[string length
$state(reply
)] >= $state(size
)} {
823 binary scan $result S id
824 set id
[expr {$id & 0xFFFF}]
825 if {$id != [expr {$state(id
) & 0xFFFF}]} {
826 ${log
}::error "received packed with incorrect id"
828 # bug #1158037 - doing this causes problems > 65535 requests!
829 #Receive [namespace current]::$id
832 ${log
}::debug "Incomplete tcp read:\
833 [string length $state(reply)] should be $state(size)"
836 Finish
$token "Event error: $err"
838 } elseif
{ [eof $state(sock
)] } {
840 } elseif
{ [fblocked $state(sock
)] } {
841 ${log
}::debug "Event blocked"
843 ${log
}::critical "Event error: this can't happen!"
844 Finish
$token "Event error: this can't happen!"
848 # -------------------------------------------------------------------------
851 # file event handler for udp sockets.
852 proc ::dns::UdpEvent {token
} {
858 set payload
[$state(sock
) recvfrom
1500]
859 append state
(reply
) $payload
861 binary scan $payload S id
862 set id
[expr {$id & 0xFFFF}]
863 if {$id != [expr {$state(id
) & 0xFFFF}]} {
864 ${log
}::error "received packed with incorrect id"
866 # bug #1158037 - doing this causes problems > 65535 requests!
867 #Receive [namespace current]::$id
871 # -------------------------------------------------------------------------
873 proc ::dns::Flags {token
{varname
{}}} {
878 if {$varname != {}} {
882 array set flags
{query
0 opcode
0 authoritative
0 errorcode
0
883 truncated
0 recursion_desired
0 recursion_allowed
0}
885 binary scan $state(reply
) SSSSSS mid hdr nQD nAN nNS nAR
887 set flags
(response
) [expr {($hdr & 0x8000) >> 15}]
888 set flags
(opcode
) [expr {($hdr & 0x7800) >> 11}]
889 set flags
(authoritative
) [expr {($hdr & 0x0400) >> 10}]
890 set flags
(truncated
) [expr {($hdr & 0x0200) >> 9}]
891 set flags
(recursion_desired
) [expr {($hdr & 0x0100) >> 8}]
892 set flags
(recursion_allowed
) [expr {($hdr & 0x0080) >> 7}]
893 set flags
(errorcode
) [expr {($hdr & 0x000F)}]
895 return [array get flags
]
898 # -------------------------------------------------------------------------
901 # Decode a DNS packet (either query or response).
903 proc ::dns::Decode {token args
} {
909 array set opts
{-rdata 0 -query 0}
910 while {[string match
-* [set option [lindex $args 0]]]} {
911 switch -exact -- $option {
912 -rdata { set opts
(-rdata) 1 }
913 -query { set opts
(-query) 1 }
915 return -code error "bad option \"$option\":\
923 binary scan $state(request
) SSSSSSc
* mid hdr nQD nAN nNS nAR data
925 binary scan $state(reply
) SSSSSSc
* mid hdr nQD nAN nNS nAR data
928 set fResponse
[expr {($hdr & 0x8000) >> 15}]
929 set fOpcode
[expr {($hdr & 0x7800) >> 11}]
930 set fAuthoritative
[expr {($hdr & 0x0400) >> 10}]
931 set fTrunc
[expr {($hdr & 0x0200) >> 9}]
932 set fRecurse
[expr {($hdr & 0x0100) >> 8}]
933 set fCanRecurse
[expr {($hdr & 0x0080) >> 7}]
934 set fRCode
[expr {($hdr & 0x000F)}]
937 if {$fResponse} {set flags
"QR"} else {set flags
"Q"}
938 set opcodes
[list QUERY IQUERY STATUS
]
939 lappend flags
[lindex $opcodes $fOpcode]
940 if {$fAuthoritative} {lappend flags
"AA"}
941 if {$fTrunc} {lappend flags
"TC"}
942 if {$fRecurse} {lappend flags
"RD"}
943 if {$fCanRecurse} {lappend flags
"RA"}
946 Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\
955 set QD
[ReadQuestion
$nQD $state(reply
) ndx
]
957 set AN
[ReadAnswer
$nAN $state(reply
) ndx
$opts(-rdata)]
959 set NS
[ReadAnswer
$nNS $state(reply
) ndx
$opts(-rdata)]
961 set AR
[ReadAnswer
$nAR $state(reply
) ndx
$opts(-rdata)]
966 # -------------------------------------------------------------------------
968 proc ::dns::Expand {data
} {
970 binary scan $data c
* d
972 lappend r
[expr {$c & 0xFF}]
978 # -------------------------------------------------------------------------
980 # Pop the nth element off a list. Used in options processing.
982 proc ::dns::Pop {varname
{nth
0}} {
984 set r
[lindex $args $nth]
985 set args
[lreplace $args $nth $nth]
989 # -------------------------------------------------------------------------
991 proc ::dns::KeyOf {arrayname value
{default {}}} {
992 upvar $arrayname array
993 set lst
[array get
array]
994 set ndx
[lsearch -exact $lst $value]
997 set r
[lindex $lst $ndx]
1005 # -------------------------------------------------------------------------
1006 # Read the question section from a DNS message. This always starts at index
1007 # 12 of a message but may be of variable length.
1009 proc ::dns::ReadQuestion {nitems data indexvar
} {
1012 upvar $indexvar index
1015 for {set cn
0} {$cn < $nitems} {incr cn
} {
1017 lappend r name
[ReadName data
$index offset
]
1020 # Read off QTYPE and QCLASS for this query.
1023 binary scan [string range
$data $ndx $index] SS qtype qclass
1024 set qtype
[expr {$qtype & 0xFFFF}]
1025 set qclass
[expr {$qclass & 0xFFFF}]
1027 lappend r type
[KeyOf types
$qtype $qtype] \
1028 class
[KeyOf classes
$qclass $qclass]
1034 # -------------------------------------------------------------------------
1036 # Read an answer section from a DNS message.
1038 proc ::dns::ReadAnswer {nitems data indexvar
{raw
0}} {
1041 upvar $indexvar index
1044 for {set cn
0} {$cn < $nitems} {incr cn
} {
1046 lappend r name
[ReadName data
$index offset
]
1049 # Read off TYPE, CLASS, TTL and RDLENGTH
1050 binary scan [string range
$data $index end
] SSIS type class ttl rdlength
1052 set type
[expr {$type & 0xFFFF}]
1053 set type
[KeyOf types
$type $type]
1055 set class
[expr {$class & 0xFFFF}]
1056 set class
[KeyOf classes
$class $class]
1058 set ttl
[expr {$ttl & 0xFFFFFFFF}]
1059 set rdlength
[expr {$rdlength & 0xFFFF}]
1061 set rdata
[string range
$data $index [expr {$index + $rdlength - 1}]]
1066 set rdata
[join [Expand
$rdata] .
]
1069 set rdata
[ip
::contract [ip
::ToString $rdata]]
1072 set rdata
[ReadName data
$index off
]
1075 binary scan $rdata S preference
1076 set exchange
[ReadName data
[expr {$index + 2}] off
]
1077 set rdata
[list $preference $exchange]
1081 set rdata
[list priority
[ReadUShort data
$x off
]]
1083 lappend rdata weight
[ReadUShort data
$x off
]
1085 lappend rdata port
[ReadUShort data
$x off
]
1087 lappend rdata target
[ReadName data
$x off
]
1091 set rdata
[ReadString data
$index $rdlength]
1095 set rdata
[list MNAME
[ReadName data
$x off
]]
1097 lappend rdata RNAME
[ReadName data
$x off
]
1099 lappend rdata SERIAL
[ReadULong data
$x off
]
1101 lappend rdata REFRESH
[ReadLong data
$x off
]
1103 lappend rdata RETRY
[ReadLong data
$x off
]
1105 lappend rdata EXPIRE
[ReadLong data
$x off
]
1107 lappend rdata MINIMUM
[ReadULong data
$x off
]
1113 incr index
$rdlength
1114 lappend r type
$type class
$class ttl
$ttl rdlength
$rdlength rdata
$rdata
1121 # Read a 32bit integer from a DNS packet. These are compatible with
1122 # the ReadName proc. Additionally - ReadULong takes measures to ensure
1123 # the unsignedness of the value obtained.
1125 proc ::dns::ReadLong {datavar index usedvar
} {
1130 if {[binary scan $data @${index
}I r
]} {
1136 proc ::dns::ReadULong {datavar index usedvar
} {
1141 if {[binary scan $data @${index
}cccc b1 b2 b3 b4
]} {
1143 # This gets us an unsigned value.
1144 set r
[expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
1145 + (($b2 & 0xFF) << 16) + ($b1 << 24)}]
1150 proc ::dns::ReadUShort {datavar index usedvar
} {
1155 if {[binary scan [string range
$data $index end
] cc b1 b2
]} {
1157 # This gets us an unsigned value.
1158 set r
[expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
1163 # Read off the NAME or QNAME element. This reads off each label in turn,
1164 # dereferencing pointer labels until we have finished. The length of data
1165 # used is passed back using the usedvar variable.
1167 proc ::dns::ReadName {datavar index usedvar
} {
1170 set startindex
$index
1174 set max
[string length
$data]
1176 while {$len != 0 && $index < $max} {
1177 # Read the label length (and preread the pointer offset)
1178 binary scan [string range
$data $index end
] cc len lenb
1179 set len
[expr {$len & 0xFF}]
1183 if {[expr {$len & 0xc0}]} {
1184 binary scan [binary format cc
[expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
1186 lappend r
[ReadName data
$offset junk
]
1189 lappend r
[string range
$data $index [expr {$index + $len - 1}]]
1194 set used
[expr {$index - $startindex}]
1198 proc ::dns::ReadString {datavar index length
} {
1200 set startindex
$index
1203 set max
[expr {$index + $length}]
1205 while {$index < $max} {
1206 binary scan [string range
$data $index end
] c len
1207 set len
[expr {$len & 0xFF}]
1211 append r
[string range
$data $index [expr {$index + $len - 1}]]
1218 # -------------------------------------------------------------------------
1221 package provide dns
$dns::version
1223 # -------------------------------------------------------------------------
1225 # indent-tabs-mode: nil