You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1521 lines
46 KiB
1521 lines
46 KiB
# dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
|
# |
|
# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035 |
|
# for information about the DNS protocol. This should insulate Tcl scripts |
|
# from problems with using the system library resolver for slow name servers. |
|
# |
|
# This implementation uses TCP only for DNS queries. The protocol recommends |
|
# that UDP be used in these cases but Tcl does not include UDP sockets by |
|
# default. The package should be simple to extend to use a TclUDP extension |
|
# in the future. |
|
# |
|
# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating |
|
# if or when the proposed draft becomes accepted. |
|
# |
|
# Support added for RFC1886 - DNS Extensions to support IP version 6 |
|
# Support added for RFC2782 - DNS RR for specifying the location of services |
|
# Support added for RFC1995 - Incremental Zone Transfer in DNS |
|
# Support added for RFC7858 - DNS over Transport Layer Security |
|
# |
|
# TODO: |
|
# - When using tcp we should make better use of the open connection and |
|
# send multiple queries along the same connection. |
|
# |
|
# - We must switch to using TCP for truncated UDP packets. |
|
# |
|
# - Read RFC 2136 - dynamic updating of DNS |
|
# |
|
# ------------------------------------------------------------------------- |
|
# See the file "license.terms" for information on usage and redistribution |
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|
# ------------------------------------------------------------------------- |
|
|
|
package require Tcl 8.5 9; # tcl minimum version |
|
package require logger; # tcllib 1.3 |
|
package require uri; # tcllib 1.1 |
|
package require uri::urn; # tcllib 1.2 |
|
package require ip; # tcllib 1.7 |
|
|
|
namespace eval ::dns { |
|
namespace export configure resolve name address cname \ |
|
status reset wait cleanup errorcode |
|
|
|
variable options |
|
if {![info exists options]} { |
|
array set options { |
|
port 53 |
|
timeout 30000 |
|
protocol tcp |
|
search {} |
|
nameserver {localhost} |
|
loglevel warn |
|
usetls 0 |
|
cafile "" |
|
cadir "" |
|
} |
|
if {[file exists /etc/ssl/certs/ca-certificates.crt]} { |
|
set options(cafile) /etc/ssl/certs/ca-certificates.crt |
|
} |
|
variable log [logger::init dns] |
|
${log}::setlevel $options(loglevel) |
|
} |
|
|
|
# We can use either ceptcl or tcludp for UDP support. |
|
if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+ |
|
# If TclUDP 1.0.4 or better is available, use it. |
|
set options(protocol) udp |
|
} else { |
|
if {![catch {package require ceptcl} msg]} { |
|
set options(protocol) udp |
|
} |
|
} |
|
|
|
variable types |
|
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 NAPTR 35 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} |
|
|
|
variable uid |
|
if {![info exists uid]} { |
|
set uid 0 |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Configure the DNS package. In particular the local nameserver will need |
|
# to be set. With no options, returns a list of all current settings. |
|
# |
|
proc ::dns::configure {args} { |
|
variable options |
|
variable log |
|
|
|
if {[llength $args] < 1} { |
|
set r {} |
|
foreach opt [lsort [array names options]] { |
|
lappend r -$opt $options($opt) |
|
} |
|
return $r |
|
} |
|
|
|
set cget 0 |
|
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) |
|
} else { |
|
set options(nameserver) [Pop args 1] |
|
} |
|
} |
|
-po* { |
|
if {$cget} { |
|
return $options(port) |
|
} else { |
|
set options(port) [Pop args 1] |
|
} |
|
} |
|
-ti* { |
|
if {$cget} { |
|
return $options(timeout) |
|
} else { |
|
set options(timeout) [Pop args 1] |
|
} |
|
} |
|
-pr* { |
|
if {$cget} { |
|
return $options(protocol) |
|
} else { |
|
set proto [string tolower [Pop args 1]] |
|
if {[string compare udp $proto] == 0 \ |
|
&& [string compare tcp $proto] == 0} { |
|
return -code error "invalid protocol \"$proto\":\ |
|
protocol must be either \"udp\" or \"tcp\"" |
|
} |
|
set options(protocol) $proto |
|
} |
|
} |
|
-sea* { |
|
if {$cget} { |
|
return $options(search) |
|
} else { |
|
set options(search) [Pop args 1] |
|
} |
|
} |
|
-log* { |
|
if {$cget} { |
|
return $options(loglevel) |
|
} else { |
|
set options(loglevel) [Pop args 1] |
|
${log}::setlevel $options(loglevel) |
|
} |
|
} |
|
-cafile { |
|
if {$cget} { |
|
return $options(cafile) |
|
} else { |
|
set options(cafile) [Pop args 1] |
|
} |
|
} |
|
-cadir { |
|
if {$cget} { |
|
return $options(cadir) |
|
} else { |
|
set options(cadir) [Pop args 1] |
|
} |
|
} |
|
-- { Pop args ; break } |
|
default { |
|
set opts [join [lsort [array names options]] ", -"] |
|
return -code error "bad option [lindex $args 0]:\ |
|
must be one of -$opts" |
|
} |
|
} |
|
Pop args |
|
} |
|
|
|
return |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Create a DNS query and send to the specified name server. Returns a token |
|
# to be used to obtain any further information about this query. |
|
# |
|
proc ::dns::resolve {query args} { |
|
variable uid |
|
variable options |
|
variable log |
|
|
|
# get a guaranteed unique and non-present token id. |
|
set id [incr uid] |
|
while {[info exists [set token [namespace current]::$id]]} { |
|
set id [incr uid] |
|
} |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
# Setup token/state defaults. |
|
set state(id) $id |
|
set state(query) $query |
|
set state(qdata) "" |
|
set state(opcode) 0; # 0 = query, 1 = inverse query. |
|
set state(-type) A; # DNS record type (A address) |
|
set state(-class) IN; # IN (internet address space) |
|
set state(-recurse) 1; # Recursion Desired |
|
set state(-command) {}; # asynchronous handler |
|
set state(-timeout) $options(timeout); # connection timeout default. |
|
set state(-nameserver) $options(nameserver);# default nameserver |
|
set state(-port) $options(port); # default namerservers port |
|
set state(-search) $options(search); # domain search list |
|
set state(-protocol) $options(protocol); # which protocol udp/tcp |
|
set state(-usetls) $options(usetls); # use RFC7858 privacy |
|
set state(-cafile) $options(cafile); # certificate authority file |
|
set state(-cadir) $options(cadir); # certificate authority dir |
|
|
|
# Handle DNS URL's |
|
if {[string match "dns:*" $query]} { |
|
array set URI [uri::split $query] |
|
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" |
|
} |
|
|
|
while {[string match -* [lindex $args 0]]} { |
|
switch -glob -- [lindex $args 0] { |
|
-n* - ns - |
|
-ser* { set state(-nameserver) [Pop args 1] } |
|
-po* { set state(-port) [Pop args 1] } |
|
-usetls { set state(-usetls) [Pop args 1] } |
|
-cafile { set state(-cafile) [Pop args 1] } |
|
-cadir { set state(-cadir) [Pop args 1] } |
|
-ti* { set state(-timeout) [Pop args 1] } |
|
-co* { set state(-command) [Pop args 1] } |
|
-cl* { set state(-class) [Pop args 1] } |
|
-ty* { set state(-type) [Pop args 1] } |
|
-pr* { set state(-protocol) [Pop args 1] } |
|
-sea* { set state(-search) [Pop args 1] } |
|
-re* { set state(-recurse) [Pop args 1] } |
|
-inv* { set state(opcode) 1 } |
|
-status {set state(opcode) 2} |
|
-data { set state(qdata) [Pop args 1] } |
|
default { |
|
set opts [join [lsort [array names state -*]] ", "] |
|
return -code error "bad option [lindex $args 0]: \ |
|
must be $opts" |
|
} |
|
} |
|
Pop args |
|
} |
|
|
|
if {$state(-nameserver) == {}} { |
|
return -code error "no nameserver specified" |
|
} |
|
|
|
if {$state(-usetls)} { |
|
package require tls |
|
set state(-protocol) "tcp" |
|
if {$state(-port) == $options(port)} { |
|
set state(-port) 853 |
|
} |
|
} |
|
|
|
if {$state(-protocol) == "udp"} { |
|
if {[llength [package provide ceptcl]] == 0 \ |
|
&& [llength [package provide udp]] == 0} { |
|
return -code error "udp support is not available,\ |
|
get ceptcl or tcludp" |
|
} |
|
} |
|
|
|
# Check for reverse lookups. IPv4 first, then IPv6. |
|
if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} { |
|
set addr [lreverse [split $state(query) .]] |
|
lappend addr in-addr arpa |
|
set state(query) [join $addr .] |
|
set state(-type) PTR |
|
} elseif {[string match {*:*} $state(query)]} { |
|
set addr [ip::normalize $state(query)] |
|
set addr [split [string reverse $addr] :] |
|
set addr [join [split [join $addr ""] {}] .] |
|
lappend addr ip6 arpa |
|
set state(query) [join $addr .] |
|
set state(-type) PTR |
|
} |
|
|
|
BuildMessage $token |
|
|
|
if {$state(-protocol) == "tcp"} { |
|
TcpTransmit $token |
|
} else { |
|
UdpTransmit $token |
|
} |
|
if {$state(-command) == {}} { |
|
wait $token |
|
} |
|
return $token |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Return a list of domain names returned as results for the last query. |
|
# |
|
proc ::dns::name {token} { |
|
set r {} |
|
Flags $token flags |
|
array set reply [Decode $token] |
|
|
|
switch -exact -- $flags(opcode) { |
|
0 { |
|
# QUERY |
|
foreach answer $reply(AN) { |
|
array set AN $answer |
|
if {![info exists AN(type)]} {set AN(type) {}} |
|
switch -exact -- $AN(type) { |
|
MX - NS - PTR { |
|
if {[info exists AN(rdata)]} {lappend r $AN(rdata)} |
|
} |
|
default { |
|
if {[info exists AN(name)]} { |
|
lappend r $AN(name) |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
1 { |
|
# IQUERY |
|
foreach answer $reply(QD) { |
|
array set QD $answer |
|
lappend r $QD(name) |
|
} |
|
} |
|
default { |
|
return -code error "not supported for this query type" |
|
} |
|
} |
|
return $r |
|
} |
|
|
|
# Description: |
|
# Return a list of the IP addresses returned for this query. |
|
# |
|
proc ::dns::address {token} { |
|
set r {} |
|
array set reply [Decode $token] |
|
foreach answer $reply(AN) { |
|
array set AN $answer |
|
|
|
if {[info exists AN(type)]} { |
|
switch -exact -- $AN(type) { |
|
"A" { |
|
lappend r $AN(rdata) |
|
} |
|
"AAAA" { |
|
lappend r $AN(rdata) |
|
} |
|
} |
|
} |
|
} |
|
return $r |
|
} |
|
|
|
# Description: |
|
# Return a list of all CNAME results returned for this query. |
|
# |
|
proc ::dns::cname {token} { |
|
set r {} |
|
array set reply [Decode $token] |
|
foreach answer $reply(AN) { |
|
array set AN $answer |
|
|
|
if {[info exists AN(type)]} { |
|
if {$AN(type) == "CNAME"} { |
|
lappend r $AN(rdata) |
|
} |
|
} |
|
} |
|
return $r |
|
} |
|
|
|
# Description: |
|
# Return the decoded answer records. This can be used for more complex |
|
# queries where the answer isn't supported byb cname/address/name. |
|
proc ::dns::result {token args} { |
|
array set reply [eval [linsert $args 0 Decode $token]] |
|
return $reply(AN) |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Get the status of the request. |
|
# |
|
proc ::dns::status {token} { |
|
upvar #0 $token state |
|
return $state(status) |
|
} |
|
|
|
# Description: |
|
# Get the error message. Empty if no error. |
|
# |
|
proc ::dns::error {token} { |
|
upvar #0 $token state |
|
if {[info exists state(error)]} { |
|
return $state(error) |
|
} |
|
return "" |
|
} |
|
|
|
# Description |
|
# Get the error code. This is 0 for a successful transaction. |
|
# |
|
proc ::dns::errorcode {token} { |
|
upvar #0 $token state |
|
set flags [Flags $token] |
|
set ndx [lsearch -exact $flags errorcode] |
|
incr ndx |
|
return [lindex $flags $ndx] |
|
} |
|
|
|
# Description: |
|
# Reset a connection with optional reason. |
|
# |
|
proc ::dns::reset {token {why reset} {errormsg {}}} { |
|
upvar #0 $token state |
|
set state(status) $why |
|
if {[string length $errormsg] > 0 && ![info exists state(error)]} { |
|
set state(error) $errormsg |
|
} |
|
catch {fileevent $state(sock) readable {}} |
|
Finish $token |
|
} |
|
|
|
# Description: |
|
# Wait for a request to complete and return the status. |
|
# |
|
proc ::dns::wait {token} { |
|
upvar #0 $token state |
|
|
|
if {$state(status) == "connect"} { |
|
vwait [subst $token](status) |
|
} |
|
|
|
return $state(status) |
|
} |
|
|
|
# Description: |
|
# Remove any state associated with this token. |
|
# |
|
proc ::dns::cleanup {token} { |
|
upvar #0 $token state |
|
if {[info exists state]} { |
|
catch {close $state(sock)} |
|
catch {after cancel $state(after)} |
|
unset state |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Dump the raw data of the request and reply packets. |
|
# |
|
proc ::dns::dump {args} { |
|
if {[llength $args] == 1} { |
|
set type -reply |
|
set token [lindex $args 0] |
|
} elseif { [llength $args] == 2 } { |
|
set type [lindex $args 0] |
|
set token [lindex $args 1] |
|
} else { |
|
return -code error "wrong # args:\ |
|
should be \"dump ?option? methodName\"" |
|
} |
|
|
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
set result {} |
|
switch -glob -- $type { |
|
-qu* - |
|
-req* { |
|
set result [DumpMessage $state(request)] |
|
} |
|
-rep* { |
|
set result [DumpMessage $state(reply)] |
|
} |
|
default { |
|
error "unrecognised option: must be one of \ |
|
\"-query\", \"-request\" or \"-reply\"" |
|
} |
|
} |
|
|
|
return $result |
|
} |
|
|
|
# Description: |
|
# Perform a hex dump of binary data. |
|
# |
|
proc ::dns::DumpMessage {data} { |
|
set result {} |
|
binary scan $data c* r |
|
foreach c $r { |
|
append result [format "%02x " [expr {$c & 0xff}]] |
|
} |
|
return $result |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Contruct a DNS query packet. |
|
# |
|
proc ::dns::BuildMessage {token} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
variable types |
|
variable classes |
|
variable options |
|
|
|
if {! [info exists types($state(-type))] } { |
|
return -code error "invalid DNS query type" |
|
} |
|
|
|
if {! [info exists classes($state(-class))] } { |
|
return -code error "invalid DNS query class" |
|
} |
|
|
|
set qdcount 0 |
|
set qsection {} |
|
set nscount 0 |
|
set nsdata {} |
|
|
|
# In theory we can send multiple queries. In practice, named doesn't |
|
# appear to like that much. If it did work we'd do this: |
|
# foreach domain [linsert $options(search) 0 {}] ... |
|
|
|
|
|
# Pack the query: QNAME QTYPE QCLASS |
|
set qsection [PackName $state(query)] |
|
append qsection [binary format SS \ |
|
$types($state(-type))\ |
|
$classes($state(-class))] |
|
incr qdcount |
|
|
|
if {[string length $state(qdata)] > 0} { |
|
set nsdata [eval [linsert $state(qdata) 0 PackRecord]] |
|
incr nscount |
|
} |
|
|
|
switch -exact -- $state(opcode) { |
|
0 { |
|
# QUERY |
|
set state(request) [binary format SSSSSS $state(id) \ |
|
[expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \ |
|
$qdcount 0 $nscount 0] |
|
append state(request) $qsection $nsdata |
|
} |
|
1 { |
|
# IQUERY |
|
set state(request) [binary format SSSSSS $state(id) \ |
|
[expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \ |
|
0 $qdcount 0 0 0] |
|
append state(request) \ |
|
[binary format cSSI 0 \ |
|
$types($state(-type)) $classes($state(-class)) 0] |
|
switch -exact -- $state(-type) { |
|
A { |
|
append state(request) \ |
|
[binary format Sc4 4 [split $state(query) .]] |
|
} |
|
PTR { |
|
append state(request) \ |
|
[binary format Sc4 4 [split $state(query) .]] |
|
} |
|
default { |
|
return -code error "inverse query not supported for this type" |
|
} |
|
} |
|
} |
|
default { |
|
return -code error "operation not supported" |
|
} |
|
} |
|
|
|
return |
|
} |
|
|
|
# Pack a human readable dns name into a DNS resource record format. |
|
proc ::dns::PackName {name} { |
|
set data "" |
|
foreach part [split [string trim $name .] .] { |
|
set len [string length $part] |
|
append data [binary format ca$len $len $part] |
|
} |
|
append data \x00 |
|
return $data |
|
} |
|
|
|
# Pack a character string - byte length prefixed |
|
proc ::dns::PackString {text} { |
|
set len [string length $text] |
|
set data [binary format ca$len $len $text] |
|
return $data |
|
} |
|
|
|
# Pack up a single DNS resource record. See RFC1035: 3.2 for the format |
|
# of each type. |
|
# eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com} |
|
# |
|
proc ::dns::PackRecord {args} { |
|
variable types |
|
variable classes |
|
array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""} |
|
array set rr $args |
|
set data [PackName $rr(name)] |
|
|
|
switch -exact -- $rr(type) { |
|
CNAME - MB - MD - MF - MG - MR - NS - PTR { |
|
set rr(rdata) [PackName $rr(rdata)] |
|
} |
|
HINFO { |
|
array set r {CPU {} OS {}} |
|
array set r $rr(rdata) |
|
set rr(rdata) [PackString $r(CPU)] |
|
append rr(rdata) [PackString $r(OS)] |
|
} |
|
MINFO { |
|
array set r {RMAILBX {} EMAILBX {}} |
|
array set r $rr(rdata) |
|
set rr(rdata) [PackString $r(RMAILBX)] |
|
append rr(rdata) [PackString $r(EMAILBX)] |
|
} |
|
MX { |
|
foreach {pref exch} $rr(rdata) break |
|
set rr(rdata) [binary format S $pref] |
|
append rr(rdata) [PackName $exch] |
|
} |
|
TXT { |
|
set str $rr(rdata) |
|
set len [string length [set str $rr(rdata)]] |
|
set rr(rdata) "" |
|
for {set n 0} {$n < $len} {incr n} { |
|
set s [string range $str $n [incr n 253]] |
|
append rr(rdata) [PackString $s] |
|
} |
|
} |
|
NULL {} |
|
SOA { |
|
array set r {MNAME {} RNAME {} |
|
SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0} |
|
array set r $rr(rdata) |
|
set rr(rdata) [PackName $r(MNAME)] |
|
append rr(rdata) [PackName $r(RNAME)] |
|
append rr(rdata) [binary format IIIII $r(SERIAL) \ |
|
$r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)] |
|
} |
|
} |
|
|
|
# append the root label and the type flag and query class. |
|
append data [binary format SSIS $types($rr(type)) \ |
|
$classes($rr(class)) $rr(ttl) [string length $rr(rdata)]] |
|
append data $rr(rdata) |
|
return $data |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Transmit a DNS request over a tcp connection. |
|
# |
|
proc ::dns::TcpTransmit {token} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
# setup the timeout |
|
if {$state(-timeout) > 0} { |
|
set state(after) [after $state(-timeout) \ |
|
[list [namespace origin reset] \ |
|
$token timeout\ |
|
"operation timed out"]] |
|
} |
|
|
|
# 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 |
|
} |
|
|
|
if {$state(-usetls)} { |
|
tls::import $s -server false -request 1 \ |
|
-cadir $state(-cadir) \ |
|
-cafile $state(-cafile) \ |
|
-ssl2 false -ssl3 false -tls1 true \ |
|
-command [list ::dns::TlsCallback $token] |
|
if {[catch {tls::handshake $s} err]} { |
|
Finish $token $err |
|
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) |
|
|
|
fileevent $s readable [list [namespace current]::TcpEvent $token] |
|
puts -nonewline $s $req |
|
} |
|
|
|
proc ::dns::TlsCallback {token cmd channel args} { |
|
variable log |
|
variable $token |
|
upvar 0 $token state |
|
switch -exact -- $cmd { |
|
info { |
|
foreach {major minor message} $args break |
|
${log}::debug "TLS: $major/$minor $message" |
|
} |
|
verify { |
|
foreach {depth cert status error} $args break |
|
lappend state(certChain) \ |
|
[list depth $depth status $status error $error cert $cert] |
|
return $status |
|
} |
|
error { |
|
return -code error "tls error: $args" |
|
} |
|
default { |
|
return -code error "unexpected message type \"$cmd\" in TLS callback" |
|
} |
|
} |
|
return 1 |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
# Description: |
|
# Transmit a DNS request using UDP datagrams |
|
# |
|
# Note: |
|
# This requires a UDP implementation that can transmit binary data. |
|
# As yet I have been unable to test this myself and the tcludp package |
|
# cannot do this. |
|
# |
|
proc ::dns::UdpTransmit {token} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
# setup the timeout |
|
if {$state(-timeout) > 0} { |
|
set state(after) [after $state(-timeout) \ |
|
[list [namespace origin reset] \ |
|
$token timeout\ |
|
"operation timed out"]] |
|
} |
|
|
|
if {[llength [package provide ceptcl]] > 0} { |
|
# using ceptcl |
|
set state(sock) [cep -type datagram $state(-nameserver) $state(-port)] |
|
fconfigure $state(sock) -blocking 0 |
|
} else { |
|
# using tcludp |
|
set state(sock) [udp_open] |
|
udp_conf $state(sock) $state(-nameserver) $state(-port) |
|
} |
|
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 |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Tidy up after a tcp transaction. |
|
# |
|
proc ::dns::Finish {token {errormsg ""}} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
global errorInfo errorCode |
|
|
|
if {[string length $errormsg] != 0} { |
|
set state(error) $errormsg |
|
set state(status) error |
|
} |
|
catch {close $state(sock)} |
|
catch {after cancel $state(after)} |
|
if {[info exists state(-command)] && $state(-command) != {}} { |
|
if {[catch { |
|
uplevel #0 [linsert $state(-command) end $token] |
|
} err]} { |
|
if {[string length $errormsg] == 0} { |
|
set state(error) [list $err $errorInfo $errorCode] |
|
set state(status) error |
|
} |
|
} |
|
if {[info exists state(-command)]} { |
|
unset state(-command) |
|
} |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Handle end-of-file on a tcp connection. |
|
# |
|
proc ::dns::Eof {token} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
set state(status) eof |
|
Finish $token |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Process a DNS reply packet (protocol independent) |
|
# |
|
proc ::dns::Receive {token} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
binary scan $state(reply) SS id flags |
|
set status [expr {$flags & 0x000F}] |
|
|
|
switch -- $status { |
|
0 { |
|
set state(status) ok |
|
Finish $token |
|
} |
|
1 { Finish $token "Format error - unable to interpret the query." } |
|
2 { Finish $token "Server failure - internal server error." } |
|
3 { Finish $token "Name Error - domain does not exist" } |
|
4 { Finish $token "Not implemented - the query type is not available." } |
|
5 { Finish $token "Refused - your request has been refused by the server." } |
|
default { |
|
Finish $token "unrecognised error code: $err" |
|
} |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# file event handler for tcp socket. Wait for the reply data. |
|
# |
|
proc ::dns::TcpEvent {token} { |
|
variable log |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
set s $state(sock) |
|
|
|
if {[eof $s]} { |
|
Eof $token |
|
return |
|
} |
|
|
|
set status [catch {read $state(sock)} result] |
|
if {$status != 0} { |
|
${log}::debug "Event error: $result" |
|
Finish $token "error reading data: $result" |
|
} elseif { [string length $result] >= 0 } { |
|
${log}::debug "read [string length $result] bytes for $token" |
|
if {[catch { |
|
# 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] |
|
} |
|
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 |
|
set id [expr {$id & 0xFFFF}] |
|
if {$id != [expr {$state(id) & 0xFFFF}]} { |
|
${log}::error "received packed with incorrect id" |
|
} |
|
# bug #1158037 - doing this causes problems > 65535 requests! |
|
#Receive [namespace current]::$id |
|
Receive $token |
|
} else { |
|
${log}::debug "Incomplete tcp read:\ |
|
[string length $state(reply)] should be $state(size)" |
|
} |
|
} err]} { |
|
Finish $token "Event error: $err" |
|
} |
|
} elseif { [eof $state(sock)] } { |
|
Eof $token |
|
} elseif { [fblocked $state(sock)] } { |
|
${log}::debug "Event blocked" |
|
} else { |
|
${log}::critical "Event error: this can't happen!" |
|
Finish $token "Event error: this can't happen!" |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# file event handler for udp sockets. |
|
proc ::dns::UdpEvent {token} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
set s $state(sock) |
|
|
|
set payload [read $state(sock)] |
|
append state(reply) $payload |
|
|
|
binary scan $payload S id |
|
set id [expr {$id & 0xFFFF}] |
|
if {$id != [expr {$state(id) & 0xFFFF}]} { |
|
${log}::error "received packed with incorrect id" |
|
} |
|
# bug #1158037 - doing this causes problems > 65535 requests! |
|
#Receive [namespace current]::$id |
|
Receive $token |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
proc ::dns::Flags {token {varname {}}} { |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
if {$varname != {}} { |
|
upvar $varname flags |
|
} |
|
|
|
array set flags {query 0 opcode 0 authoritative 0 errorcode 0 |
|
truncated 0 recursion_desired 0 recursion_allowed 0} |
|
|
|
binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR |
|
|
|
set flags(response) [expr {($hdr & 0x8000) >> 15}] |
|
set flags(opcode) [expr {($hdr & 0x7800) >> 11}] |
|
set flags(authoritative) [expr {($hdr & 0x0400) >> 10}] |
|
set flags(truncated) [expr {($hdr & 0x0200) >> 9}] |
|
set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}] |
|
set flags(recursion_allowed) [expr {($hdr & 0x0080) >> 7}] |
|
set flags(errorcode) [expr {($hdr & 0x000F)}] |
|
|
|
return [array get flags] |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Description: |
|
# Decode a DNS packet (either query or response). |
|
# |
|
proc ::dns::Decode {token args} { |
|
variable log |
|
# FRINK: nocheck |
|
variable $token |
|
upvar 0 $token state |
|
|
|
array set opts {-rdata 0 -query 0} |
|
while {[string match -* [set option [lindex $args 0]]]} { |
|
switch -exact -- $option { |
|
-rdata { set opts(-rdata) 1 } |
|
-query { set opts(-query) 1 } |
|
default { |
|
return -code error "bad option \"$option\":\ |
|
must be -rdata" |
|
} |
|
} |
|
Pop args |
|
} |
|
|
|
if {$opts(-query)} { |
|
binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data |
|
} else { |
|
binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data |
|
} |
|
|
|
set fResponse [expr {($hdr & 0x8000) >> 15}] |
|
set fOpcode [expr {($hdr & 0x7800) >> 11}] |
|
set fAuthoritative [expr {($hdr & 0x0400) >> 10}] |
|
set fTrunc [expr {($hdr & 0x0200) >> 9}] |
|
set fRecurse [expr {($hdr & 0x0100) >> 8}] |
|
set fCanRecurse [expr {($hdr & 0x0080) >> 7}] |
|
set fRCode [expr {($hdr & 0x000F)}] |
|
set flags "" |
|
|
|
if {$fResponse} {set flags "QR"} else {set flags "Q"} |
|
set opcodes [list QUERY IQUERY STATUS] |
|
lappend flags [lindex $opcodes $fOpcode] |
|
if {$fAuthoritative} {lappend flags "AA"} |
|
if {$fTrunc} {lappend flags "TC"} |
|
if {$fRecurse} {lappend flags "RD"} |
|
if {$fCanRecurse} {lappend flags "RA"} |
|
|
|
set info "ID: $mid\ |
|
Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\ |
|
NQ: $nQD\ |
|
NA: $nAN\ |
|
NS: $nNS\ |
|
AR: $nAR" |
|
${log}::debug $info |
|
|
|
set ndx 12 |
|
set r {} |
|
set QD [ReadQuestion $nQD $state(reply) ndx] |
|
lappend r QD $QD |
|
set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)] |
|
lappend r AN $AN |
|
set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)] |
|
lappend r NS $NS |
|
set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)] |
|
lappend r AR $AR |
|
return $r |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
proc ::dns::Expand {data} { |
|
set r {} |
|
binary scan $data c* d |
|
foreach c $d { |
|
lappend r [expr {$c & 0xFF}] |
|
} |
|
return $r |
|
} |
|
|
|
|
|
# ------------------------------------------------------------------------- |
|
# Description: |
|
# Pop the nth element off a list. Used in options processing. |
|
# |
|
proc ::dns::Pop {varname {nth 0}} { |
|
upvar $varname args |
|
set r [lindex $args $nth] |
|
set args [lreplace $args $nth $nth] |
|
return $r |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
# Description: |
|
# Reverse a list. Code from http://wiki.tcl.tk/tcl/43 |
|
# |
|
proc ::dns::lreverse {lst} { |
|
set res {} |
|
set i [llength $lst] |
|
while {$i} {lappend res [lindex $lst [incr i -1]]} |
|
return $res |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
proc ::dns::KeyOf {arrayname value {default {}}} { |
|
upvar $arrayname array |
|
set lst [array get array] |
|
set ndx [lsearch -exact $lst $value] |
|
if {$ndx != -1} { |
|
incr ndx -1 |
|
set r [lindex $lst $ndx] |
|
} else { |
|
set r $default |
|
} |
|
return $r |
|
} |
|
|
|
|
|
# ------------------------------------------------------------------------- |
|
# Read the question section from a DNS message. This always starts at index |
|
# 12 of a message but may be of variable length. |
|
# |
|
proc ::dns::ReadQuestion {nitems data indexvar} { |
|
variable types |
|
variable classes |
|
upvar $indexvar index |
|
set result {} |
|
|
|
for {set cn 0} {$cn < $nitems} {incr cn} { |
|
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 |
|
binary scan [string range $data $ndx $index] SS qtype qclass |
|
set qtype [expr {$qtype & 0xFFFF}] |
|
set qclass [expr {$qclass & 0xFFFF}] |
|
incr index |
|
lappend r type [KeyOf types $qtype $qtype] \ |
|
class [KeyOf classes $qclass $qclass] |
|
lappend result $r |
|
} |
|
return $result |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Read an answer section from a DNS message. |
|
# |
|
proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} { |
|
variable types |
|
variable classes |
|
upvar $indexvar index |
|
set result {} |
|
|
|
for {set cn 0} {$cn < $nitems} {incr cn} { |
|
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 |
|
|
|
set type [expr {$type & 0xFFFF}] |
|
set type [KeyOf types $type $type] |
|
|
|
set class [expr {$class & 0xFFFF}] |
|
set class [KeyOf classes $class $class] |
|
|
|
set ttl [expr {$ttl & 0xFFFFFFFF}] |
|
set rdlength [expr {$rdlength & 0xFFFF}] |
|
incr index 10 |
|
set rdata [string range $data $index [expr {$index + $rdlength - 1}]] |
|
|
|
if {! $raw} { |
|
switch -- $type { |
|
A { |
|
set rdata [join [Expand $rdata] .] |
|
} |
|
AAAA { |
|
set rdata [ip::contract [ip::ToString $rdata]] |
|
} |
|
NS - CNAME - PTR { |
|
set rdata [ReadName data $index off] |
|
} |
|
MX { |
|
binary scan $rdata S preference |
|
set exchange [ReadName data [expr {$index + 2}] off] |
|
set rdata [list $preference $exchange] |
|
} |
|
SRV { |
|
set x $index |
|
set rdata [list priority [ReadUShort data $x off]] |
|
incr x $off |
|
lappend rdata weight [ReadUShort data $x off] |
|
incr x $off |
|
lappend rdata port [ReadUShort data $x off] |
|
incr x $off |
|
lappend rdata target [ReadName data $x off] |
|
} |
|
NAPTR { |
|
set x $index |
|
set rdata [list order [ReadUShort data $x off]] |
|
incr x $off |
|
lappend rdata preference [ReadUShort data $x off] |
|
incr x $off |
|
lappend rdata flags [ReadString data $x off] |
|
incr x $off |
|
lappend rdata service [ReadString data $x off] |
|
incr x $off |
|
lappend rdata regex [ReadString data $x off] |
|
incr x $off |
|
set domain {} |
|
while {$x < $index + $rdlength} { |
|
lappend domain [ReadString data $x off] |
|
incr x $off |
|
} |
|
lappend rdata replacement [join $domain .] |
|
} |
|
TXT { |
|
set x $index |
|
set rdata "" |
|
while {$x < $index + $rdlength} { |
|
append rdata [ReadString data $x off] |
|
incr x $off |
|
} |
|
} |
|
SOA { |
|
set x $index |
|
set rdata [list MNAME [ReadName data $x off]] |
|
incr x $off |
|
lappend rdata RNAME [ReadName data $x off] |
|
incr x $off |
|
lappend rdata SERIAL [ReadULong data $x off] |
|
incr x $off |
|
lappend rdata REFRESH [ReadLong data $x off] |
|
incr x $off |
|
lappend rdata RETRY [ReadLong data $x off] |
|
incr x $off |
|
lappend rdata EXPIRE [ReadLong data $x off] |
|
incr x $off |
|
lappend rdata MINIMUM [ReadULong data $x off] |
|
incr x $off |
|
} |
|
} |
|
} |
|
|
|
incr index $rdlength |
|
lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata |
|
lappend result $r |
|
} |
|
return $result |
|
} |
|
|
|
|
|
# Read a 32bit integer from a DNS packet. These are compatible with |
|
# the ReadName proc. Additionally - ReadULong takes measures to ensure |
|
# the unsignedness of the value obtained. |
|
# |
|
proc ::dns::ReadLong {datavar index usedvar} { |
|
upvar $datavar data |
|
upvar $usedvar used |
|
set r {} |
|
set used 0 |
|
if {[binary scan $data @${index}I r]} { |
|
set used 4 |
|
} |
|
return $r |
|
} |
|
|
|
proc ::dns::ReadULong {datavar index usedvar} { |
|
upvar $datavar data |
|
upvar $usedvar used |
|
set r {} |
|
set used 0 |
|
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)}] |
|
} |
|
return $r |
|
} |
|
|
|
proc ::dns::ReadUShort {datavar index usedvar} { |
|
upvar $datavar data |
|
upvar $usedvar used |
|
set r {} |
|
set used 0 |
|
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}] |
|
} |
|
return $r |
|
} |
|
|
|
# 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. |
|
# |
|
proc ::dns::ReadName {datavar index usedvar} { |
|
upvar $datavar data |
|
upvar $usedvar used |
|
set startindex $index |
|
|
|
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 |
|
incr index |
|
lappend r [ReadName data $offset junk] |
|
set len 0 |
|
} else { |
|
lappend r [string range $data $index [expr {$index + $len - 1}]] |
|
incr index $len |
|
} |
|
} |
|
} |
|
set used [expr {$index - $startindex}] |
|
return [join $r .] |
|
} |
|
|
|
proc ::dns::ReadString {datavar index usedvar} { |
|
upvar $datavar data |
|
upvar $usedvar used |
|
set startindex $index |
|
|
|
set r {} |
|
|
|
if {[binary scan [string range $data $index end] c len] == 1} { |
|
set len [expr {$len & 0xFF}] |
|
incr index |
|
|
|
if {$len != 0} { |
|
set r [string range $data $index [expr {$index + $len - 1}]] |
|
incr index $len |
|
} |
|
} |
|
set used [expr {$index - $startindex}] |
|
return $r |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
# Support for finding the local nameservers |
|
# |
|
# For unix we can just parse the /etc/resolv.conf if it exists. |
|
# Of course, some unices use /etc/resolver and other things (NIS for instance) |
|
# On Windows, we can examine the Internet Explorer settings from the registry. |
|
# |
|
switch -exact $::tcl_platform(platform) { |
|
windows { |
|
proc ::dns::nameservers {} { |
|
package require registry |
|
set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services} |
|
set param "$base\\Tcpip\\Parameters" |
|
set interfaces "$param\\Interfaces" |
|
set nameservers {} |
|
if {[string equal $::tcl_platform(os) "Windows NT"]} { |
|
AppendRegistryValue $param NameServer nameservers |
|
AppendRegistryValue $param DhcpNameServer nameservers |
|
foreach i [registry keys $interfaces] { |
|
AppendRegistryValue "$interfaces\\$i" NameServer nameservers |
|
AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers |
|
} |
|
} else { |
|
set param "$base\\VxD\\MSTCP" |
|
AppendRegistryValue $param NameServer nameservers |
|
} |
|
return $nameservers |
|
} |
|
proc ::dns::AppendRegistryValue {key val listName} { |
|
upvar $listName lst |
|
if {![catch {registry get $key $val} v]} { |
|
foreach ns [split $v ", "] { |
|
if {[lsearch -exact $lst $ns] == -1} { |
|
lappend lst $ns |
|
} |
|
} |
|
} |
|
} |
|
} |
|
unix { |
|
proc ::dns::nameservers {} { |
|
set nameservers {} |
|
if {[file readable /etc/resolv.conf]} { |
|
set f [open /etc/resolv.conf r] |
|
while {![eof $f]} { |
|
gets $f line |
|
if {[regexp {^\s*nameserver\s+(.*)$} $line -> ns]} { |
|
lappend nameservers $ns |
|
} |
|
} |
|
close $f |
|
} |
|
if {[llength $nameservers] < 1} { |
|
lappend nameservers 127.0.0.1 |
|
} |
|
return $nameservers |
|
} |
|
} |
|
default { |
|
proc ::dns::nameservers {} { |
|
return -code error "command not supported for this platform." |
|
} |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
# Possible support for the DNS URL scheme. |
|
# Ref: http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-04.txt |
|
# eg: dns:target?class=IN;type=A |
|
# dns://nameserver/target?type=A |
|
# |
|
# URI quoting to be accounted for. |
|
# |
|
|
|
catch { |
|
uri::register {dns} { |
|
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] |
|
|
|
variable class [string map {* \\\\*} \ |
|
"class=([join [array names ::dns::classes] {|}])"] |
|
variable type [string map {* \\\\*} \ |
|
"type=([join [array names ::dns::types] {|}])"] |
|
variable classOrType "(?:${class}|${type})" |
|
variable classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?" |
|
|
|
variable query "${host}(${classOrTypeSpec})?" |
|
variable schemepart "(//${hostOrPort}/)?(${query})" |
|
variable url "dns:$schemepart" |
|
} |
|
} |
|
|
|
namespace eval ::uri {} ;# needed for pkg_mkIndex. |
|
|
|
proc ::uri::SplitDns {uri} { |
|
upvar \#0 [namespace current]::dns::schemepart schemepart |
|
upvar \#0 [namespace current]::dns::class classOrType |
|
upvar \#0 [namespace current]::dns::class classRE |
|
upvar \#0 [namespace current]::dns::type typeRE |
|
upvar \#0 [namespace current]::dns::classOrTypeSpec classOrTypeSpec |
|
|
|
array set parts {nameserver {} query {} class {} type {} port {}} |
|
|
|
# validate the uri |
|
if {[regexp -- $dns::schemepart $uri r] == 1} { |
|
|
|
# deal with the optional class and type specifiers |
|
if {[regexp -indices -- "${classOrTypeSpec}$" $uri range]} { |
|
set spec [string range $uri [lindex $range 0] [lindex $range 1]] |
|
set uri [string range $uri 0 [expr {[lindex $range 0] - 2}]] |
|
|
|
if {[regexp -- "$classRE" $spec -> class]} { |
|
set parts(class) $class |
|
} |
|
if {[regexp -- "$typeRE" $spec -> type]} { |
|
set parts(type) $type |
|
} |
|
} |
|
|
|
# Handle the nameserver specification |
|
if {[string match "//*" $uri]} { |
|
set uri [string range $uri 2 end] |
|
array set tmp [GetUPHP uri] |
|
set parts(nameserver) $tmp(host) |
|
set parts(port) $tmp(port) |
|
} |
|
|
|
# what's left is the query domain name. |
|
set parts(query) [string trimleft $uri /] |
|
} |
|
|
|
return [array get parts] |
|
} |
|
|
|
proc ::uri::JoinDns {args} { |
|
array set parts {nameserver {} port {} query {} class {} type {}} |
|
array set parts $args |
|
set query [::uri::urn::quote $parts(query)] |
|
if {$parts(type) != {}} { |
|
append query "?type=$parts(type)" |
|
} |
|
if {$parts(class) != {}} { |
|
if {$parts(type) == {}} { |
|
append query "?class=$parts(class)" |
|
} else { |
|
append query ";class=$parts(class)" |
|
} |
|
} |
|
if {$parts(nameserver) != {}} { |
|
set ns "$parts(nameserver)" |
|
if {$parts(port) != {}} { |
|
append ns ":$parts(port)" |
|
} |
|
set query "//${ns}/${query}" |
|
} |
|
return "dns:$query" |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
|
|
catch {dns::configure -nameserver [lindex [dns::nameservers] 0]} |
|
|
|
package provide dns 1.6 |
|
|
|
# ------------------------------------------------------------------------- |
|
# Local Variables: |
|
# indent-tabs-mode: nil |
|
# End:
|
|
|