DELETED build/kits/app/lib/defer/defer.tcl
Index: build/kits/app/lib/defer/defer.tcl
==================================================================
--- build/kits/app/lib/defer/defer.tcl
+++ /dev/null
@@ -1,96 +0,0 @@
-namespace eval ::defer {
-	namespace export defer
-
-	variable idVar "<defer>\n<trace variable>"
-}
-
-proc ::defer::with {args} {
-	if {[llength $args] == 1} {
-		set varlist [list]
-		set code [lindex $args 0]
-	} elseif {[llength $args] == 2} {
-		set varlist [lindex $args 0]
-		set code [lindex $args 1]
-	} else {
-		return -code error "wrong # args: defer::with ?varlist? script"
-	}
-
-	if {[info level] == 1} {
-		set global true
-	} else {
-		set global false
-	}
-
-	# We can't reliably handle cleanup from the global scope, don't let people
-	# register ineffective handlers for now
-	if {$global} {
-		return -code error "defer may not be used from the global scope"
-	}
-
-	# Generate an ID to un-defer if requested
-	set id [clock clicks]
-	for {set i 0} {$i < 5} {incr i} {
-		append id [expr rand()]
-	}
-
-	# If a list of variable names has been supplied, slurp up their values
-	# and add the appropriate script to set those variables in the lambda
-	## Generate a list of commands to create the variables
-	foreach var $varlist {
-		if {![uplevel 1 [list info exists $var]]} {
-			continue
-		}
-
-		if {[uplevel 1 [list array exists $var]]} {
-			set val [uplevel 1 [list array get $var]]
-			lappend codeSetVars [list unset -nocomplain $var]
-			lappend codeSetVars [list array set $var $val]
-		} else {
-			set val [uplevel 1 [list set $var]]
-			lappend codeSetVars [list set $var $val]
-		}
-	}
-
-	## Format the above commands in the structure of a Tcl command
-	if {[info exists codeSetVars]} {
-		set codeSetVars [join $codeSetVars "; "]
-		set code "${codeSetVars}; ${code}"
-	}
-
-	## Unset the "args" variable, which is just an artifact of the lambda
-	set code "# ${id}\nunset args; ${code}"
-
-	# Register our interest in a variable to monitor for it to disappear
-
-	uplevel 1 [list trace add variable $::defer::idVar unset [list apply [list args $code]]]
-
-	return $id
-}
-
-proc ::defer::defer {args} {
-	set code $args
-	tailcall ::defer::with $code
-}
-
-proc ::defer::autowith {script} {
-	tailcall ::defer::with [uplevel 1 {info vars}] $script
-}
-
-proc ::defer::cancel {args} {
-	set idList $args
-
-	set traces [uplevel 1 [list trace info variable $::defer::idVar]]
-
-	foreach trace $traces {
-		set action [lindex $trace 0]
-		set code   [lindex $trace 1]
-
-		foreach id $idList {
-			if {[string match "*# $id*" $code]} {
-				uplevel 1 [list trace remove variable $::defer::idVar $action $code]
-			}
-		}
-	}
-}
-
-package provide defer 1

DELETED build/kits/app/lib/defer/pkgIndex.tcl
Index: build/kits/app/lib/defer/pkgIndex.tcl
==================================================================
--- build/kits/app/lib/defer/pkgIndex.tcl
+++ /dev/null
@@ -1,1 +0,0 @@
-package ifneeded defer 1 [list source [file join $dir defer.tcl]]

ADDED   vendor/tcl-packages/defer/defer.tcl
Index: vendor/tcl-packages/defer/defer.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/defer/defer.tcl
@@ -0,0 +1,96 @@
+namespace eval ::defer {
+	namespace export defer
+
+	variable idVar "<defer>\n<trace variable>"
+}
+
+proc ::defer::with {args} {
+	if {[llength $args] == 1} {
+		set varlist [list]
+		set code [lindex $args 0]
+	} elseif {[llength $args] == 2} {
+		set varlist [lindex $args 0]
+		set code [lindex $args 1]
+	} else {
+		return -code error "wrong # args: defer::with ?varlist? script"
+	}
+
+	if {[info level] == 1} {
+		set global true
+	} else {
+		set global false
+	}
+
+	# We can't reliably handle cleanup from the global scope, don't let people
+	# register ineffective handlers for now
+	if {$global} {
+		return -code error "defer may not be used from the global scope"
+	}
+
+	# Generate an ID to un-defer if requested
+	set id [clock clicks]
+	for {set i 0} {$i < 5} {incr i} {
+		append id [expr rand()]
+	}
+
+	# If a list of variable names has been supplied, slurp up their values
+	# and add the appropriate script to set those variables in the lambda
+	## Generate a list of commands to create the variables
+	foreach var $varlist {
+		if {![uplevel 1 [list info exists $var]]} {
+			continue
+		}
+
+		if {[uplevel 1 [list array exists $var]]} {
+			set val [uplevel 1 [list array get $var]]
+			lappend codeSetVars [list unset -nocomplain $var]
+			lappend codeSetVars [list array set $var $val]
+		} else {
+			set val [uplevel 1 [list set $var]]
+			lappend codeSetVars [list set $var $val]
+		}
+	}
+
+	## Format the above commands in the structure of a Tcl command
+	if {[info exists codeSetVars]} {
+		set codeSetVars [join $codeSetVars "; "]
+		set code "${codeSetVars}; ${code}"
+	}
+
+	## Unset the "args" variable, which is just an artifact of the lambda
+	set code "# ${id}\nunset args; ${code}"
+
+	# Register our interest in a variable to monitor for it to disappear
+
+	uplevel 1 [list trace add variable $::defer::idVar unset [list apply [list args $code]]]
+
+	return $id
+}
+
+proc ::defer::defer {args} {
+	set code $args
+	tailcall ::defer::with $code
+}
+
+proc ::defer::autowith {script} {
+	tailcall ::defer::with [uplevel 1 {info vars}] $script
+}
+
+proc ::defer::cancel {args} {
+	set idList $args
+
+	set traces [uplevel 1 [list trace info variable $::defer::idVar]]
+
+	foreach trace $traces {
+		set action [lindex $trace 0]
+		set code   [lindex $trace 1]
+
+		foreach id $idList {
+			if {[string match "*# $id*" $code]} {
+				uplevel 1 [list trace remove variable $::defer::idVar $action $code]
+			}
+		}
+	}
+}
+
+package provide defer 1

ADDED   vendor/tcl-packages/defer/pkgIndex.tcl
Index: vendor/tcl-packages/defer/pkgIndex.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/defer/pkgIndex.tcl
@@ -0,0 +1,1 @@
+package ifneeded defer 1 [list source [file join $dir defer.tcl]]

ADDED   vendor/tcl-packages/dns/dns.tcl
Index: vendor/tcl-packages/dns/dns.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/dns.tcl
@@ -0,0 +1,1416 @@
+# 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 reccommends
+# 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
+#
+# 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.2;                # 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
+        }
+        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 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)
+                }
+            }
+            --    { 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
+
+    # 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] }
+            -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(-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
+    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
+    }
+
+    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
+    }
+
+    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]
+}
+
+# -------------------------------------------------------------------------
+# 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 {eval $state(-command) {$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 } {
+        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]
+                    incr x $off
+                }
+                TXT {
+                    set rdata [ReadString data $index $rdlength]
+                }
+                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 length} {
+    upvar $datavar data
+    set startindex $index
+
+    set r {}
+    set max [expr {$index + $length}]
+
+    while {$index < $max} {
+        binary scan [string range $data $index end] c len
+        set len [expr {$len & 0xFF}]
+        incr index
+
+        if {$len != 0} {
+            append r [string range $data $index [expr {$index + $len - 1}]]
+            incr index $len
+        }
+    }
+    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 [GetHostPort 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.3.5
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:

ADDED   vendor/tcl-packages/dns/ip.tcl
Index: vendor/tcl-packages/dns/ip.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/ip.tcl
@@ -0,0 +1,553 @@
+# ip.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Internet address manipulation.
+#
+# RFC 3513: IPv6 addressing.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+# @mdgen EXCLUDE: ipMoreC.tcl
+
+package require Tcl 8.2;                # tcl minimum version
+
+namespace eval ip {
+    namespace export is version normalize equal type contract mask collapse subtract
+    #catch {namespace ensemble create}
+
+    variable IPv4Ranges
+    if {![info exists IPv4Ranges]} {
+        array set IPv4Ranges {
+            0/8        private
+            10/8       private
+            127/8      private
+            172.16/12  private
+            192.168/16 private
+            223/8      reserved
+            224/3      reserved
+        }
+    }
+
+    variable IPv6Ranges
+    if {![info exists IPv6Ranges]} {
+        # RFC 3513: 2.4
+        # RFC 3056: 2
+        array set IPv6Ranges {
+            2002::/16 "6to4 unicast"
+            fe80::/10 "link local"
+            fec0::/10 "site local"
+            ff00::/8  "multicast"
+            ::/128    "unspecified"
+            ::1/128   "localhost"
+        }
+    }
+}
+
+proc ::ip::is {class ip} {
+    foreach {ip mask} [split $ip /] break
+    switch -exact -- $class {
+        ipv4 - IPv4 - 4 {
+            return [IPv4? $ip]
+        }
+        ipv6 - IPv6 - 6 {
+            return [IPv6? $ip]
+        }
+        default {
+            return -code error "bad class \"$class\": must be ipv4 or ipv6"
+        }
+    }
+}
+
+proc ::ip::version {ip} {
+    set version -1
+    if {[string equal $ip {}]} { return $version}
+    foreach {addr mask} [split $ip /] break
+    if {[IPv4? $addr]} {
+        set version 4
+    } elseif {[IPv6? $addr]} {
+        set version 6
+    }
+    return $version
+}
+        
+proc ::ip::equal {lhs rhs} {
+    foreach {LHS LM} [SplitIp $lhs] break
+    foreach {RHS RM} [SplitIp $rhs] break
+    if {[set version [version $LHS]] != [version $RHS]} {
+        return -code error "type mismatch:\
+            cannot compare different address types"
+    }
+    if {$version == 4} {set fmt I} else {set fmt I4}
+    set LHS [Mask$version [Normalize $LHS $version] $LM]
+    set RHS [Mask$version [Normalize $RHS $version] $RM]
+    binary scan $LHS $fmt LLL
+    binary scan $RHS $fmt RRR
+    foreach L $LLL R $RRR {
+        if {$L != $R} {return 0}
+    }
+    return 1
+}
+
+proc ::ip::collapse {prefixlist} {
+    #puts **[llength $prefixlist]||$prefixlist
+
+    # Force mask parts into length notation for the following merge
+    # loop to work.
+    foreach ip $prefixlist {
+        foreach {addr mask} [SplitIp $ip] break
+        set nip $addr/[maskToLength [maskToInt $mask]]
+        #puts "prefix $ip = $nip"
+        lappend tmp $nip
+    }
+    set prefixlist $tmp
+
+    #puts @@[llength $prefixlist]||$prefixlist
+
+    set ret {}
+    set can_normalize_more 1
+    while {$can_normalize_more} {
+        set prefixlist [lsort -dict $prefixlist]
+
+        #puts ||[llength $prefixlist]||$prefixlist
+
+        set can_normalize_more 0
+
+        for {set idx 0} {$idx < [llength $prefixlist]} {incr idx} {
+            set nextidx [expr {$idx + 1}]
+
+            set item     [lindex $prefixlist $idx]
+            set nextitem [lindex $prefixlist $nextidx]
+
+            if {$nextitem eq ""} {
+                lappend ret $item
+                continue
+            }
+
+            set itemmask     [mask $item]
+            set nextitemmask [mask $nextitem]
+
+            set item [prefix $item]
+
+            if {$itemmask ne $nextitemmask} {
+                lappend ret $item/$itemmask
+                continue
+            }
+
+            set adjacentitem [intToString [nextNet $item $itemmask]]/$itemmask
+
+            if {$nextitem ne $adjacentitem} {
+                lappend ret $item/$itemmask
+                continue
+            }
+
+            set upmask [expr {$itemmask - 1}]
+            set upitem "$item/$upmask"
+
+            # Maybe just checking the llength of the result is enough ?
+            if {[reduceToAggregates [list $item $nextitem $upitem]] != [list $upitem]} {
+                lappend ret $item/$itemmask
+                continue
+            }
+
+            set can_normalize_more 1
+
+            incr idx
+            lappend ret $upitem
+        }
+
+	set prefixlist $ret
+        set ret {}
+    }
+
+    return $prefixlist
+}
+
+
+proc ::ip::normalize {ip {Ip4inIp6 0}} {
+    foreach {ip mask} [SplitIp $ip] break
+    set version [version $ip]
+    set s [ToString [Normalize $ip $version] $Ip4inIp6]
+    if {($version == 6 && $mask != 128) || ($version == 4 && $mask != 32)} {
+        append s /$mask
+    }
+    return $s
+}
+
+proc ::ip::contract {ip} {
+    foreach {ip mask} [SplitIp $ip] break
+    set version [version $ip]
+    set s [ToString [Normalize $ip $version]]
+    if {$version == 6} {
+        set r ""
+        foreach o [split $s :] { 
+            append r [format %x: 0x$o] 
+        }
+        set r [string trimright $r :]
+        regsub {(?:^|:)0(?::0)+(?::|$)} $r {::} r
+    } else {
+        set r [string trimright $s .0]
+    }
+    return $r
+}
+
+proc ::ip::subtract {hosts} {
+    set positives {}
+    set negatives {}
+
+    foreach host $hosts {
+        foreach {addr mask} [SplitIp $host] break
+        set host $addr/[maskToLength [maskToInt $mask]]
+
+	if {[string match "-*" $host]} {
+	    set host [string trimleft $host "-"]
+	    lappend negatives $host
+	} else {
+	    lappend positives $host
+	}
+    }
+
+    # Reduce to aggregates if needed
+    if {[llength $positives] > 1} {
+	set positives [reduceToAggregates $positives]
+    }
+
+    if {![llength $positives]} {
+	return {}
+    }
+
+    if {[llength $negatives] > 1} {
+	set negatives [reduceToAggregates $negatives]
+    }
+
+    if {![llength $negatives]} {
+	return $positives
+    }
+
+    # Remove positives that are cancelled out entirely
+    set new_positives {}
+    foreach positive $positives {
+	set found 0
+	foreach negative $negatives {
+            # Do we need the exact check, i.e. ==, or 'eq', or would
+            # checking the length of result == 1 be good enough?
+	    if {[reduceToAggregates [list $positive $negative]] == [list $negative]} {
+		set found 1
+		break
+	    }
+	}
+
+	if {!$found} {
+	    lappend new_positives $positive
+	}
+    }
+    set positives $new_positives
+
+    set retval {}
+    foreach positive $positives {
+	set negatives_found {}
+	foreach negative $negatives {
+	    if {[isOverlap $positive $negative]} {
+		lappend negatives_found $negative
+	    }
+	}
+
+	if {![llength $negatives_found]} {
+	    lappend retval $positive
+	    continue
+	}
+
+	# Convert the larger subnet
+	## Determine smallest subnet involved
+	set maxmask 0
+	foreach subnet [linsert $negatives 0 $positive] {
+	    set mask [mask $subnet]
+	    if {$mask > $maxmask} {
+		set maxmask $mask
+	    }
+	}
+
+	set positive_list [ExpandSubnet $positive $maxmask]
+	set negative_list {}
+	foreach negative $negatives_found {
+	    foreach negative_subnet [ExpandSubnet $negative $maxmask] {
+		lappend negative_list $negative_subnet
+	    }
+	}
+
+	foreach positive_sub $positive_list {
+	    if {[lsearch -exact $negative_list $positive_sub] < 0} {
+		lappend retval $positive_sub
+	    }
+	}
+    }
+
+    return $retval
+}
+
+proc ::ip::ExpandSubnet {subnet newmask} {
+    #set oldmask [maskToLength [maskToInt [mask $subnet]]]
+    set oldmask [mask $subnet]
+    set subnet  [prefix $subnet]
+
+    set numsubnets [expr {round(pow(2, ($newmask - $oldmask)))}]
+
+    set ret {}
+    for {set idx 0} {$idx < $numsubnets} {incr idx} {
+	lappend ret "${subnet}/${newmask}"
+	set subnet [intToString [nextNet $subnet $newmask]]
+    }
+
+    return $ret
+}
+
+# Returns an IP address prefix.
+# For instance: 
+#  prefix 192.168.1.4/16 => 192.168.0.0
+#  prefix fec0::4/16     => fec0:0:0:0:0:0:0:0
+#  prefix fec0::4/ffff:: => fec0:0:0:0:0:0:0:0
+#
+proc ::ip::prefix {ip} {
+    foreach {addr mask} [SplitIp $ip] break
+    set version [version $addr]
+    set addr [Normalize $addr $version]
+    return [ToString [Mask$version $addr $mask]]
+}
+
+# Return the address type. For IPv4 this is one of private, reserved 
+# or normal
+# For IPv6 it is one of site local, link local, multicast, unicast,
+# unspecified or loopback.
+proc ::ip::type {ip} {
+    set version [version $ip]
+    upvar [namespace current]::IPv${version}Ranges types
+    set ip [prefix $ip]
+    foreach prefix [array names types] {
+        set mask [mask $prefix]
+        if {[equal $ip/$mask $prefix]} {
+            return $types($prefix)
+        }
+    }
+    if {$version == 4} {
+        return "normal"
+    } else {
+        return "unicast"
+    }
+}
+
+proc ::ip::mask {ip} {
+    foreach {addr mask} [split $ip /] break
+    return $mask
+}
+
+# -------------------------------------------------------------------------
+
+# Returns true is the argument can be converted into an IPv4 address.
+#
+proc ::ip::IPv4? {ip} {
+    if {[string first : $ip] >= 0} {
+        return 0
+    }
+    if {[catch {Normalize4 $ip}]} {
+        return 0
+    }
+    return 1
+}
+
+proc ::ip::IPv6? {ip} {
+    set octets [split $ip :]
+    if {[llength $octets] < 3 || [llength $octets] > 8} {
+        return 0
+    }
+    set ndx 0
+    foreach octet $octets {
+        incr ndx
+        if {[string length $octet] < 1} continue
+        if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} continue
+        if {$ndx >= [llength $octets] && [IPv4? $octet]} continue
+        if {$ndx == 2 && [lindex $octets 0] == 2002 && [IPv4? $octet]} continue
+        #"Invalid IPv6 address \"$ip\""
+        return 0
+    }
+    if {[regexp {^:[^:]} $ip]} {
+        #"Invalid ipv6 address \"$ip\" (starts with :)"
+        return 0
+    }
+    if {[regexp {[^:]:$} $ip]} {
+        # "Invalid IPv6 address \"$ip\" (ends with :)"
+        return 0
+    }
+    if {[regsub -all :: $ip "|" junk] > 1} {
+        # "Invalid IPv6 address \"$ip\" (more than one :: pattern)"
+        return 0
+    }
+    return 1
+}
+
+proc ::ip::Mask4 {ip {bits {}}} {
+    if {[string length $bits] < 1} { set bits 32 }
+    binary scan $ip I ipx
+    if {[string is integer $bits]} {
+        set mask [expr {(0xFFFFFFFF << (32 - $bits)) & 0xFFFFFFFF}]
+    } else {
+        binary scan [Normalize4 $bits] I mask
+    }
+    return [binary format I [expr {$ipx & $mask}]]
+}
+
+proc ::ip::Mask6 {ip {bits {}}} {
+    if {[string length $bits] < 1} { set bits 128 }
+    if {[string is integer $bits]} {
+        set mask [binary format B128 [string repeat 1 $bits]]
+    } else {
+        binary scan [Normalize6 $bits] I4 mask
+    }
+    binary scan $ip I4 Addr
+    binary scan $mask I4 Mask
+    foreach A $Addr M $Mask {
+        lappend r [expr {$A & $M}]
+    }
+    return [binary format I4 $r]
+}
+
+        
+
+# A network address specification is an IPv4 address with an optional bitmask
+# Split an address specification into a IPv4 address and a network bitmask.
+# This doesn't validate the address portion.
+# If a spec with no mask is provided then the mask will be 32
+# (all bits significant).
+# Masks may be either integer number of significant bits or dotted-quad
+# notation.
+#
+proc ::ip::SplitIp {spec} {
+    set slash [string last / $spec]
+    if {$slash != -1} {
+        incr slash -1
+        set ip [string range $spec 0 $slash]
+        incr slash 2
+        set bits [string range $spec $slash end]
+    } else {
+        set ip $spec
+        if {[string length $ip] > 0 && [version $ip] == 6} {
+            set bits 128
+        } else {
+            set bits 32
+        }
+    }
+    return [list $ip $bits]
+}
+
+# Given an IP string from the user, convert to a normalized internal rep.
+# For IPv4 this is currently a hex string (0xHHHHHHHH).
+# For IPv6 this is a binary string or 16 chars.
+proc ::ip::Normalize {ip {version 0}} {
+    if {$version < 0} {
+        set version [version $ip]
+        if {$version < 0} {
+            return -code error "invalid address \"$ip\":\
+                value must be a valid IPv4 or IPv6 address"
+        }
+    }
+    return [Normalize$version $ip]
+}
+
+proc ::ip::Normalize4 {ip} {
+    set octets [split $ip .]
+    if {[llength $octets] > 4} {
+        return -code error "invalid ip address \"$ip\""
+    } elseif {[llength $octets] < 4} {
+        set octets [lrange [concat $octets 0 0 0] 0 3]
+    }
+    foreach oct $octets {
+        if {$oct < 0 || $oct > 255} {
+            return -code error "invalid ip address"
+        }
+    }
+    return [binary format c4 $octets]
+}
+
+proc ::ip::Normalize6 {ip} {
+    set octets [split $ip :]
+    set ip4embed [string first . $ip]
+    set len [llength $octets]
+    if {$len < 0 || $len > 8} {
+        return -code error "invalid address: this is not an IPv6 address"
+    }
+    set result ""
+    for {set n 0} {$n < $len} {incr n} {
+        set octet [lindex $octets $n]
+        if {$octet == {}} {
+            if {$n == 0 || $n == ($len - 1)} {
+                set octet \0\0
+            } else {
+                set missing [expr {9 - $len}]
+                if {$ip4embed != -1} {incr missing -1}
+                set octet [string repeat \0\0 $missing]
+            }
+        } elseif {[string first . $octet] != -1} {
+            set octet [Normalize4 $octet]
+        } else {
+            set m [expr {4 - [string length $octet]}]
+            if {$m != 0} {
+                set octet [string repeat 0 $m]$octet
+            }
+            set octet [binary format H4 $octet]
+        }
+        append result $octet
+    }
+    if {[string length $result] != 16} {
+        return -code error "invalid address: \"$ip\" is not an IPv6 address"
+    }
+    return $result
+}
+
+
+# This will convert a full ipv4/ipv6 in binary format into a normal
+# expanded string rep.
+proc ::ip::ToString {bin {Ip4inIp6 0}} {
+    set len [string length $bin]
+    set r ""
+    if {$len == 4} {
+        binary scan $bin c4 octets
+        foreach octet $octets {
+            lappend r [expr {$octet & 0xff}]
+        }
+        return [join $r .]
+    } elseif {$len == 16} {
+        if {$Ip4inIp6 == 0} {
+            binary scan $bin H32 hex
+            for {set n 0} {$n < 32} {incr n} {
+                append r [string range $hex $n [incr n 3]]:
+            }
+            return [string trimright $r :]
+        } else {
+            binary scan $bin H24c4 hex octets
+            for {set n 0} {$n < 24} {incr n} {
+                append r [string range $hex $n [incr n 3]]:
+            }
+            foreach octet $octets {
+                append r [expr {$octet & 0xff}].
+            }
+            return [string trimright $r .]
+        }
+    } else {
+        return -code error "invalid binary address:\
+            argument is neither an IPv4 nor an IPv6 address"
+    }
+}
+
+# -------------------------------------------------------------------------
+# Load extended command set.
+
+source [file join [file dirname [info script]] ipMore.tcl]
+
+# -------------------------------------------------------------------------
+
+package provide ip 1.3
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:

ADDED   vendor/tcl-packages/dns/ipMore.tcl
Index: vendor/tcl-packages/dns/ipMore.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/ipMore.tcl
@@ -0,0 +1,1295 @@
+#temporary home until this gets cleaned up for export to tcllib ip module
+# $Id: ipMore.tcl,v 1.4 2006/01/22 00:27:22 andreas_kupries Exp $
+
+
+##Library Header
+#
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+#       ipMore
+#
+# Purpose:
+#       Additional commands for the tcllib ip package.
+#
+# Author:
+#        Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+#       aakhter@cisco.com
+#
+# Usage:
+#       package require ip
+#       (The command are loaded from the regular package).
+#
+# Description:
+#       A detailed description of the functionality provided by the library.
+#      
+# Requirements:
+#
+# Variables:
+#       namespace   ::ip
+#
+# Notes:
+#       1.
+#
+# Keywords:
+#
+#
+# Category: 
+#       
+#
+# End of Header
+
+package require msgcat
+
+# Try to load various C based accelerator packages for two of the
+# commands.
+
+if {[catch {package require ipMorec}]} {
+    catch {package require tcllibc}
+}
+
+if {[llength [info commands ::ip::prefixToNativec]]} {
+    # An accelerator is present, providing the C variants
+    interp alias {} ::ip::prefixToNative  {} ::ip::prefixToNativec
+    interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativec
+} else {
+    # Link API to the Tcl variants, no accelerators are available.
+    interp alias {} ::ip::prefixToNative  {} ::ip::prefixToNativeTcl
+    interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativeTcl
+}
+
+namespace eval ::ip {
+    ::msgcat::mcload [file join [file dirname [info script]] msgs]
+}
+
+if {![llength [info commands lassign]]} {
+    # Either an older tcl version, or tclx not loaded; have to use our
+    # internal lassign from http://wiki.tcl.tk/1530 by Schelte Bron
+
+    proc ::ip::lassign {values args} {
+        uplevel 1 [list foreach $args $values break]
+        lrange $values [llength $args] end
+    }
+}
+if {![llength [info commands lvarpop]]} {
+    # Define an emulation of Tclx's lvarpop if the command
+    # is not present already.
+
+    proc ::ip::lvarpop {upVar {index 0}} {
+	upvar $upVar list;
+	set top [lindex $list $index];
+	set list [concat [lrange $list 0 [expr $index - 1]] \
+		      [lrange $list [expr $index +1] end]];
+	return $top;
+    }
+}
+
+# Some additional aliases for backward compatability. Not
+# documented. The old names are from previous versions while at Cisco.
+#
+#               Old command name -->      Documented command name
+interp alias {} ::ip::ToInteger           {} ::ip::toInteger
+interp alias {} ::ip::ToHex               {} ::ip::toHex
+interp alias {} ::ip::MaskToInt           {} ::ip::maskToInt
+interp alias {} ::ip::MaskToLength        {} ::ip::maskToLength
+interp alias {} ::ip::LengthToMask        {} ::ip::lengthToMask
+interp alias {} ::ip::IpToLayer2Multicast {} ::ip::ipToLayer2Multicast
+interp alias {} ::ip::IpHostFromPrefix    {} ::ip::ipHostFromPrefix
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::prefixToNative
+#
+# Purpose:
+#        convert from dotted from to native (hex) form
+#
+# Synopsis:
+#       prefixToNative <prefix>
+#
+# Arguments:
+#        <prefix>
+#            string in the <ipaddr>/<mask> format
+#
+# Return Values:
+#        <prefix> in native format {<hexip> <hexmask>}
+#
+# Description:
+#       
+# Examples:
+#   % ip::prefixToNative 1.1.1.0/24
+#   0x01010100 0xffffff00
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#   fixed bug in C extension that modified 
+#    calling context variable
+# See Also:
+#
+# End of Header
+
+proc ip::prefixToNativeTcl {prefix} {
+    set plist {}
+    foreach p $prefix {
+	set newPrefix [ip::toHex [ip::prefix $p]]
+	if {[string equal [set mask [ip::mask $p]] ""]} {
+	    set newMask 0xffffffff
+	} else {
+	    set newMask [format "0x%08x" [ip::maskToInt $mask]]
+	}
+	lappend plist [list $newPrefix $newMask]
+    }
+    if {[llength $plist]==1} {return [lindex $plist 0]}
+    return $plist
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::nativeToPrefix
+#
+# Purpose:
+#        convert from native (hex) form to dotted form
+#
+# Synopsis:
+#       nativeToPrefix <nativeList>|<native> [-ipv4]
+#
+# Arguments:
+#        <nativeList> 
+#            list of native form ip addresses native form is:
+#        <native>
+#            tcllist in format {<hexip> <hexmask>}
+#        -ipv4
+#            the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+#        if nativeToPrefix is called with <native> a single (non-listified) address
+#            is returned
+#        if nativeToPrefix is called with a <nativeList> address list, then 
+#            a list of addresses is returned
+#
+#        return form is: <ipaddr>/<mask>
+#
+# Description:
+#       
+# Examples:
+#   % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4
+#   1.1.1.0/24
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nativeToPrefix {nativeList args} {
+    set pList 1
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+
+    # if a single native element is passed eg {0x01010100 0xffffff00}
+    # instead of {{0x01010100 0xffffff00} {0x01010100 0xffffff00}...}
+    # then return a (non-list) single entry
+    if {[llength [lindex $nativeList 0]]==1} {set pList 0; set nativeList [list $nativeList]}
+    foreach native $nativeList {
+	lassign $native ip mask
+	if {[string equal $mask ""]} {set mask 32}
+	set pString ""
+	append pString [ip::ToString [binary format I [expr {$ip}]]]
+	append pString  "/"
+	append pString [ip::maskToLength $mask]
+	lappend rList $pString
+    }
+    # a multi (listified) entry was given
+    # return the listified entry
+    if {$pList} { return $rList }
+    return $pString
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::intToString
+#
+# Purpose:
+#        convert from an integer/hex to dotted form
+#
+# Synopsis:
+#       intToString <integer/hex> [-ipv4]
+#
+# Arguments:
+#        <integer>
+#            ip address in integer form
+#        -ipv4
+#            the provided integer addresses is ipv4 (default)
+#
+# Return Values:
+#        ip address in dotted form
+#
+# Description:
+#       
+# Examples:
+#       ip::intToString 4294967295
+#       255.255.255.255
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::intToString {int args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    return [ip::ToString [binary format I [expr {$int}]]]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::toInteger
+#
+# Purpose:
+#        convert dotted form ip to integer
+#
+# Synopsis:
+#       toInteger <ipaddr>
+#
+# Arguments:
+#        <ipaddr>
+#            decimal dotted form ip address
+#
+# Return Values:
+#        integer form of <ipaddr>
+#
+# Description:
+#       
+# Examples:
+#   % ::ip::toInteger 1.1.1.0
+#   16843008
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toInteger {ip} {
+    binary scan [ip::Normalize4 $ip] I out
+    return [format %lu [expr {$out & 0xffffffff}]]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::toHex
+#
+# Purpose:
+#        convert dotted form ip to hex
+#
+# Synopsis:
+#       toHex <ipaddr>
+#
+# Arguments:
+#        <ipaddr>
+#            decimal dotted from ip address
+#
+# Return Values:
+#        hex form of <ipaddr>
+#
+# Description:
+#       
+# Examples:
+#   % ::ip::toHex 1.1.1.0
+#   0x01010100
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toHex {ip} {
+    binary scan [ip::Normalize4 $ip] H8 out
+    return "0x$out"
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::maskToInt
+#
+# Purpose:
+#        convert mask to integer
+#
+# Synopsis:
+#       maskToInt <mask>
+#
+# Arguments:
+#        <mask>
+#            mask in either dotted form or mask length form (255.255.255.0 or 24)
+#
+# Return Values:
+#        integer form of mask
+#
+# Description:
+#       
+# Examples:
+#   ::ip::maskToInt 24
+#   4294967040
+#
+#   
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToInt {mask} {
+    if {[string is integer -strict $mask]} {
+        set maskInt [expr {(0xFFFFFFFF << (32 - $mask))}]
+    } else {
+        binary scan [Normalize4 $mask] I maskInt
+    }
+    set maskInt [expr {$maskInt & 0xFFFFFFFF}]
+    return [format %u $maskInt]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::broadcastAddress
+#
+# Purpose:
+#        return broadcast address given prefix
+#
+# Synopsis:
+#       broadcastAddress <prefix> [-ipv4]
+#
+# Arguments:
+#        <prefix>
+#            route in the form of <ipaddr>/<mask> or native form {<hexip> <hexmask>}
+#        -ipv4
+#            the provided native format addresses are in ipv4 format (default)
+#            note: broadcast addresses are not valid in ipv6
+#            
+#
+# Return Values:
+#        ipaddress of broadcast
+#
+# Description:
+#       
+# Examples:
+#   ::ip::broadcastAddress 1.1.1.0/24
+#   1.1.1.255
+#   
+#   ::ip::broadcastAddress {0x01010100 0xffffff00}
+#   0x010101ff
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::broadcastAddress {prefix args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    if {[llength $prefix] == 2} {
+	lassign $prefix net mask
+    } else {
+	set net [maskToInt [ip::prefix $prefix]]
+	set mask [maskToInt [ip::mask $prefix]]
+    }
+    set ba [expr {$net  | ((~$mask)&0xffffffff)}]
+    
+    if {[llength $prefix]==2} {
+	return [format "0x%08x" $ba]
+    }
+    return [ToString [binary format I $ba]]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::maskToLength
+#
+# Purpose:
+#        converts dotted or integer form of mask to length
+#
+# Synopsis:
+#       maskToLength <dottedMask>|<integerMask>|<hexMask> [-ipv4]
+#
+# Arguments:
+#        <dottedMask>
+#        <integerMask>
+#        <hexMask>
+#            mask to convert to prefix length format (eg /24)
+#         -ipv4
+#            the provided integer/hex format masks are ipv4 (default)
+#
+# Return Values:
+#        prefix length
+#
+# Description:
+#       
+# Examples:
+#   ::ip::maskToLength 0xffffff00 -ipv4
+#   24
+#
+#   % ::ip::maskToLength 255.255.255.0
+#   24
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToLength {mask args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    #pick the fastest method for either format
+    if {[string is integer -strict $mask]} {
+	binary scan [binary format I [expr {$mask}]] B32 maskB
+	if {[regexp -all {^1+} $maskB ones]} {
+	    return [string length $ones]
+	} else {
+	    return 0
+	}
+    } else {
+	regexp {\/(.+)} $mask dumb mask
+	set prefix 0
+	foreach ipByte [split $mask {.}] {
+	    switch $ipByte {
+		255 {incr prefix 8; continue}
+		254 {incr prefix 7}
+		252 {incr prefix 6}
+		248 {incr prefix 5}
+		240 {incr prefix 4}
+		224 {incr prefix 3}
+		192 {incr prefix 2}
+		128 {incr prefix 1}
+		0   {}
+		default { 
+		    return -code error [msgcat::mc "not an ip mask: %s" $mask]
+		}
+	    }
+	    break
+	}
+	return $prefix
+    }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::lengthToMask
+#
+# Purpose:
+#        converts mask length to dotted mask form
+#
+# Synopsis:
+#       lengthToMask <maskLength> [-ipv4]
+#
+# Arguments:
+#        <maskLength>
+#            mask length   
+#        -ipv4
+#            the provided mask length is ipv4 (default)  
+#
+# Return Values:
+#        mask in dotted form
+#
+# Description:
+#       
+# Examples:
+#   ::ip::lengthToMask 24
+#   255.255.255.0
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::lengthToMask {masklen args} {
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    # the fastest method is just to look
+    # thru an array
+    return $::ip::maskLenToDotted($masklen)
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::nextNet
+#
+# Purpose:
+#        returns next an ipaddress in same position in next network
+#
+# Synopsis:
+#       nextNet <ipaddr> <mask> [<count>] [-ipv4]
+#
+# Arguments:
+#        <ipaddress>
+#            in hex/integer/dotted format
+#        <mask>
+#            mask in hex/integer/dotted/maskLen format
+#        <count>
+#            number of nets to skip over (default is 1)
+#        -ipv4
+#            the provided hex/integer addresses are in ipv4 format (default)
+#
+# Return Values:
+#        ipaddress in same position in next network in hex
+#
+# Description:
+#       
+# Examples:
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nextNet {prefix mask args} {
+    set count 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		set count [lindex $args 0]
+		set args [lrange $args 1 end]
+	    }
+	}
+    }
+    if {![string is integer -strict $prefix]} { 
+	set prefix [toInteger $prefix]
+    }
+    if {![string is integer -strict $mask] || ($mask < 33 && $mask > 0)} {
+	set mask [maskToInt $mask]
+    }    
+    set prefix [expr {$prefix + ((($mask ^ 0xFFffFFff) + 1) * $count) }]
+    return [format "0x%08x" $prefix]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::isOverlap
+#
+# Purpose:
+#        checks to see if prefixes overlap
+#
+# Synopsis:
+#       isOverlap <prefix> <prefix1> <prefix2>...
+#
+# Arguments:
+#        <prefix>
+#            in form <ipaddr>/<mask> prefix to compare <prefixN> against
+#        <prefixN>
+#            in form <ipaddr>/<mask> prefixes to compare against
+#
+# Return Values:
+#        1 if there is an overlap
+#
+# Description:
+#       
+# Examples:
+#        % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32
+#        0
+#
+#        ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32
+#        1
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlap {ip args} {
+    lassign [SplitIp $ip] ip1 mask1
+    set ip1int [toInteger $ip1]
+    set mask1int [maskToInt $mask1]
+
+    set overLap 0
+    foreach prefix $args {
+	lassign [SplitIp $prefix] ip2 mask2
+	set ip2int [toInteger $ip2]
+	set mask2int [maskToInt $mask2]
+	set mask1mask2 [expr {$mask1int & $mask2int}]
+	if {[expr {$ip1int & $mask1mask2}] ==  [expr {$ip2int & $mask1mask2}]} {
+	    set overLap 1
+	    break
+	}
+    }
+    return $overLap
+}
+
+
+#optimized overlap, that accepts native format
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::isOverlapNative
+#
+# Purpose:
+#        checks to see if prefixes overlap (optimized native form)
+#
+# Synopsis:
+#       isOverlap <hexipaddr> <hexmask> {{<hexipaddr1> <hexmask1>} {<hexipaddr2> <hexmask2>...}
+#
+# Arguments:
+#        -all
+#            return all overlaps rather than the first one
+#        -inline
+#            rather than returning index values, return the actual overlap prefixes
+#        <hexipaddr>
+#            ipaddress in hex/integer form
+#        <hexMask>
+#            mask in hex/integer form
+#        -ipv4
+#            the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+#        non-zero if there is an overlap, value is element # in list with overlap
+#
+# Description:
+#        isOverlapNative is available both as a C extension and in a native tcl form
+#        if the extension is loaded (tried automatically), isOverlapNative will be
+#        linked to isOverlapNativeC. If an extension is not loaded, then isOverlapNative
+#        will be linked to the native tcl proc: ipOverlapNativeTcl.
+#
+# Examples:
+#        % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+#        0
+#
+#        %::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}
+#        2
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlapNativeTcl {args} {
+    set all 0
+    set inline 0
+    set notOverlap 0
+    set ipv4 1
+    foreach sw [lrange $args 0 end-3] {
+	switch -exact -- $sw {
+	    -all {
+		set all 1
+		set allList [list]
+	    }
+	    -inline {set inline 1}
+	    -ipv4 {}
+	}
+    }
+    set args [lassign [lrange $args end-2 end] ip1int mask1int prefixList]
+    if {$inline} { 
+	set overLap [list]
+    } else {
+	set overLap 0
+    }
+    set count 0
+    foreach prefix $prefixList {
+	incr count
+	lassign $prefix ip2int mask2int
+	set mask1mask2 [expr {$mask1int & $mask2int}]
+	if {[expr {$ip1int & $mask1mask2}] ==  [expr {$ip2int & $mask1mask2}]} {
+	    if {$inline} {
+		set overLap [list $prefix]
+	    } else {
+		set overLap $count
+	    }
+	    if {$all} {
+		if {$inline} {
+		    lappend allList $prefix
+		} else {
+		    lappend allList $count
+		}
+	    } else {
+		break
+	    }
+	}
+    }
+    if {$all} {return $allList}
+    return $overLap
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::ipToLayer2Multicast
+#
+# Purpose:
+#        converts ipv4 address to a layer 2 multicast address
+#
+# Synopsis:
+#       ipToLayer2Multicast <ipaddr>
+#
+# Arguments:
+#        <ipaddr>
+#            ipaddress in dotted form
+#
+# Return Values:
+#        mac address in xx.xx.xx.xx.xx.xx form
+#
+# Description:
+#
+# Examples:
+#        % ::ip::ipToLayer2Multicast 224.0.0.2
+#        01.00.5e.00.00.02
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipToLayer2Multicast { ipaddr } {
+    regexp "\[0-9\]+\.(\[0-9\]+)\.(\[0-9\]+)\.(\[0-9\]+)" $ipaddr junk ip2 ip3 ip4
+    #remove MSB of 2nd octet of IP address for mcast L2 addr
+    set mac2 [expr {$ip2 & 127}]
+    return [format "01.00.5e.%02x.%02x.%02x" $mac2 $ip3 $ip4]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::ipHostFromPrefix
+#
+# Purpose:
+#        gives back a host address from a prefix
+#
+# Synopsis:
+#       ::ip::ipHostFromPrefix <prefix> [-exclude <list of prefixes>]
+#
+# Arguments:
+#        <prefix>
+#            prefix is <ipaddr>/<masklen>
+#        -exclude <list of prefixes>
+#            list if ipprefixes that host should not be in
+# Return Values:
+#        ip address 
+#
+# Description:
+#
+# Examples:
+# %::ip::ipHostFromPrefix  1.1.1.5/24
+# 1.1.1.1
+#
+# %::ip::ipHostFromPrefix  1.1.1.1/32
+# 1.1.1.1
+#
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipHostFromPrefix { prefix args } {
+    set mask [mask $prefix]
+    set ipaddr [prefix $prefix]
+    if {[llength $args]} {
+	array set opts $args
+    } else {
+	if {$mask==32} {
+	    return $ipaddr
+	} else {
+	    return [intToString [expr {[toHex $ipaddr] + 1} ]]
+	}
+    }
+    set format {-ipv4}
+    # if we got here, then options were set
+    if {[info exists opts(-exclude)]} {
+	#basic algo is:
+	# 1. throw away prefixes that are less specific that $prefix
+	# 2. of remaining pfx, throw away prefixes that do not overlap
+	# 3. run reducetoAggregates on specific nets
+	# 4. 
+	
+	# 1. convert to hex format
+	set currHex [prefixToNative $prefix ]
+	set exclHex [prefixToNative $opts(-exclude) ]
+	# sort the prefixes by their mask, include the $prefix as a marker
+	#  so we know from where to throw away prefixes
+	set sortedPfx [lsort -integer -index 1 [concat [list $currHex]  $exclHex]]
+	# throw away prefixes that are less specific than $prefix
+	set specPfx [lrange $sortedPfx [expr {[lsearch -exact $sortedPfx $currHex] +1} ] end]
+	
+	#2. throw away non-overlapping prefixes
+	set specPfx [isOverlapNative -all -inline \
+			 [lindex $currHex 0 ] \
+			 [lindex $currHex 1 ] \
+			 $specPfx ]
+	#3. run reduce aggregates 
+	set specPfx [reduceToAggregates $specPfx]
+
+	#4 now have to pick an address that overlaps with $currHex but not with
+	#   $specPfx
+	# 4.1 find the largest prefix w/ most specific mask and go to the next net
+	
+
+	# current ats tcl does not allow this in one command, so 
+	#  for now just going to grab the last prefix (list is already sorted)
+	set sPfx [lindex $specPfx end]
+	set startPfx $sPfx
+	# add currHex to specPfx
+	set oChkPfx [concat $specPfx [list $currHex]]
+
+
+	set notcomplete 1
+	set overflow 0
+	while {$notcomplete} {
+	    #::ipMore::log::debug "doing nextnet on $sPfx"
+	    set nextNet [nextNet [lindex $sPfx 0] [lindex $sPfx 1]]
+	    #::ipMore::log::debug "trying $nextNet"
+	    if {$overflow && ($nextNet > $startPfx)} {
+		#we've gone thru the entire net and didn't find anything.
+		return -code error [msgcat::mc "ip host could not be found in %s" $prefix]
+		break
+	    }
+	    set oPfx [isOverlapNative -all -inline \
+			  $nextNet -1 \
+			  $oChkPfx
+		     ]
+	    switch -exact [llength $oPfx] {
+		0 {
+		    # no overlap at all. meaning we have gone beyond the bounds of
+		    # $currHex. need to overlap and try again
+		    #::ipMore::log::debug {ipHostFromPrefix: overlap done}
+		    set overflow 1
+		}
+		1 {
+		    #we've found what we're looking for. pick this address and exit
+		    return [intToString $nextNet]
+		}
+		default {
+		    # 2 or more overlaps, need to increment again
+		    set sPfx [lindex $oPfx 0]
+		}
+	    }
+	}
+    }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::reduceToAggregates
+#
+# Purpose:
+#        finds nets that overlap and filters out the more specifc nets
+#
+# Synopsis:
+#       ::ip::reduceToAggregates <prefixList>
+#
+# Arguments:
+#        <prefixList>
+#            prefixList a list in the from of
+#            is <ipaddr>/<masklen> or native format
+#
+# Return Values:
+#        non-overlapping ip prefixes
+#
+# Description:
+#
+# Examples:
+#
+#  % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8  2.1.1.0/24 1.1.1.1/32 }
+#  1.0.0.0/8 2.1.1.0/24
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::reduceToAggregates { prefixList } {
+    #find out format of $prefixeList
+    set dotConv 0
+    if {[llength [lindex $prefixList 0]]==1} {
+	#format is dotted form convert all prefixes to native form
+	set prefixList [ip::prefixToNative $prefixList]
+	set dotConv 1
+    }
+    
+    set nonOverLapping $prefixList
+    while {1==1} {
+	set overlapFound 0
+	set remaining $nonOverLapping
+	set nonOverLapping {}
+	while {[llength $remaining]} {
+	    set current [lvarpop remaining]
+	    set overLap [ip::isOverlapNative [lindex $current 0] [lindex $current 1] $remaining]
+	    if {$overLap} {
+		#there was a overlap find out which prefix has a the smaller mask, and keep that one
+		if {[lindex $current 1] > [lindex [lindex $remaining [expr {$overLap -1}]] 1]} {
+		    #current has more restrictive mask, throw that prefix away
+		    # keep other prefix
+		    lappend nonOverLapping [lindex $remaining [expr {$overLap -1}]]
+		} else {
+		    lappend nonOverLapping $current
+		}
+		lvarpop remaining [expr {$overLap -1}]
+		set overlapFound 1
+	    } else {
+		#no overlap, keep all prefixes, don't touch the stuff in 
+		# remaining, it is needed for other overlap checking
+		lappend nonOverLapping $current
+	    }
+	}
+	if {$overlapFound==0} {break}
+    }
+    if {$dotConv} {return [nativeToPrefix $nonOverLapping]}
+    return $nonOverLapping
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::longestPrefixMatch
+#
+# Purpose:
+#        given host IP finds longest prefix match from set of prefixes
+#
+# Synopsis:
+#       ::ip::longestPrefixMatch <ipaddr> <prefixList> [-ipv4]
+#
+# Arguments:
+#        <prefixList>
+#            is list of <ipaddr> in native or dotted form
+#        <ipaddr>
+#            ip address in <ipprefix> format, dotted form, or integer form
+#        -ipv4
+#            the provided integer format addresses are in ipv4 format (default)
+#
+# Return Values:
+#        <ipprefix> that is the most specific match to <ipaddr>
+#
+# Description:
+#
+# Examples:
+#        % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8  2.1.1.0/24 1.1.1.0/28 }
+#        1.1.1.0/28
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::longestPrefixMatch { ipaddr prefixList args} {
+    set ipv4 1
+    while {[llength $args]} {
+	switch -- [lindex $args 0] {
+	    -ipv4 {set args [lrange $args 1 end]}
+	    default {
+		return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+	    }
+	}
+    }
+    #find out format of prefixes
+    set dotConv 0
+    if {[llength [lindex $prefixList 0]]==1} {
+	#format is dotted form convert all prefixes to native form
+	set prefixList [ip::prefixToNative $prefixList]
+	set dotConv 1
+    }
+    #sort so that most specific prefix is in the front
+    if {[llength [lindex [lindex $prefixList 0] 1]]} {
+	set prefixList [lsort -decreasing -integer -index 1 $prefixList]
+    } else {
+	set prefixList [list $prefixList]
+    }
+    if {![string is integer -strict $ipaddr]} {
+	set ipaddr [prefixToNative $ipaddr]
+    }
+    set best [ip::isOverlapNative -inline \
+		  [lindex $ipaddr 0] [lindex $ipaddr 1] $prefixList]
+    if {$dotConv && [llength $best]} {
+	return [nativeToPrefix $best]
+    }
+    return $best
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+#       ::ip::cmpDotIP
+#
+# Purpose:
+#        helper function for dotted ip address for use in lsort
+#
+# Synopsis:
+#       ::ip::cmpDotIP <ipaddr1> <ipaddr2>
+#
+# Arguments:
+#        <ipaddr1> <ipaddr2>
+#            prefix is in dotted ip address format
+#
+# Return Values:
+#        -1 if ipaddr1 is less that ipaddr2
+#         1 if ipaddr1 is more that ipaddr2
+#         0 if ipaddr1 and ipaddr2 are equal
+#
+# Description:
+#
+# Examples:
+#        % lsort -command ip::cmpDotIP {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3}
+#        1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0
+#
+# Sample Input:
+#        
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+#            ip address in <ipprefix> format, dotted form, or integer form
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+    # 8.3+
+    proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+	# convert dotted to list of integers
+	set ipaddr1 [split $ipaddr1 .]
+	set ipaddr2 [split $ipaddr2 .]
+	foreach a $ipaddr1 b $ipaddr2 {
+	    #ipMore::log::debug "$ipInt1 $ipInt2"
+	    if { $a < $b}  {
+		return -1
+	    } elseif {$a >$b} {
+		return 1
+	    }
+	}
+	return 0
+    }
+} else {
+    # 8.4+
+    proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+	# convert dotted to decimal
+	set ipInt1 [::ip::toHex $ipaddr1]
+	set ipInt2 [::ip::toHex $ipaddr2]
+	#ipMore::log::debug "$ipInt1 $ipInt2"
+	if { $ipInt1 < $ipInt2}  {
+	    return -1
+	} elseif {$ipInt1 >$ipInt2 } {
+	    return 1
+	} else {
+	    return 0
+	}
+    }
+}
+
+# Populate the array "maskLenToDotted" for fast lookups of mask to
+# dotted form.
+
+namespace eval ::ip {
+    variable maskLenToDotted
+    variable x
+
+    for {set x 0} {$x <33} {incr x} {
+	set maskLenToDotted($x) [intToString [maskToInt $x]]
+    }
+    unset x
+}
+
+##Procedure Header
+# Copyright (c) 2015 Martin Heinrich <martin.heinrich@frequentis.com>
+#
+# Name:
+#       ::ip::distance
+#
+# Purpose:
+#        Calculate integer distance between two IPv4 addresses (dotted form or int)
+#
+# Synopsis:
+#       distance <ipaddr1> <ipaddr2>
+#
+# Arguments:
+#        <ipaddr1>
+#        <ipaddr2>
+#            ip address
+#
+# Return Values:
+#        integer distance (addr2 - addr1)
+#
+# Description:
+#       
+# Examples:
+#   % ::ip::distance 1.1.1.0 1.1.1.5
+#   5
+#
+# Sample Input:
+#
+# Sample Output:
+
+proc ::ip::distance {ip1 ip2} {
+    # use package ip for normalization
+    # XXX does not support ipv6
+    expr {[toInteger $ip2]-[toInteger $ip1]}
+}
+
+##Procedure Header
+# Copyright (c) 2015 Martin Heinrich <martin.heinrich@frequentis.com>
+#
+# Name:
+#       ::ip::nextIp
+#
+# Purpose:
+#        Increment the given IPv4 address by an offset.
+#        Complement to 'distance'.
+#
+# Synopsis:
+#       nextIp <ipaddr> ?<offset>?
+#
+# Arguments:
+#        <ipaddr>
+#            ip address
+#
+#        <offset>
+#            The integer to increment the address by.
+#            Default is 1.
+#
+# Return Values:
+#        The increment ip address.
+#
+# Description:
+#       
+# Examples:
+#   % ::ip::nextIp 1.1.1.0 5 
+#   1.1.1.5
+#
+# Sample Input:
+#
+# Sample Output:
+
+proc ::ip::nextIp {ip {offset 1}} {
+    set int [toInteger $ip]
+    incr int $offset
+    set prot {}
+    # TODO if ipv4 then set prot -ipv4, but
+    # XXX intToString has -ipv4, but never returns ipv6
+    intToString $int ;# 8.5-ism, avoid: {*}$prot
+}

ADDED   vendor/tcl-packages/dns/ipMoreC.tcl
Index: vendor/tcl-packages/dns/ipMoreC.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/ipMoreC.tcl
@@ -0,0 +1,242 @@
+# Skip this for window and a specific version of Solaris
+# 
+# This could do with an explanation -- why are we avoiding these platforms
+# and perhaps using critcl's platform::platform command might be better?
+#
+if {[string equal $::tcl_platform(platform) windows] ||
+    ([string equal $::tcl_platform(os)      SunOS] &&
+     [string equal $::tcl_platform(osVersion) 5.6])
+} {
+    # avoid warnings about nothing to compile
+    critcl::ccode {
+        /* nothing to do */
+    }
+    return
+}
+
+package require critcl;
+
+namespace eval ::ip {
+
+critcl::ccode {
+#include <stdlib.h>
+#include <stdio.h>
+#include <tcl.h>
+#include <inttypes.h>
+#include <arpa/inet.h>
+#include <string.h>
+#include <sys/socket.h>
+}
+
+critcl::ccommand prefixToNativec {clientData interp objc objv} { 
+    int elemLen, maskLen, ipLen, mask;
+	int rval,convertListc,i;
+	Tcl_Obj **convertListv;
+	Tcl_Obj *listPtr,*returnPtr, *addrList;
+	char *stringIP, *slashPos, *stringMask;
+	char v4HEX[11];
+	
+	uint32_t inaddr;
+	listPtr = NULL;
+
+	/* printf ("\n in prefixToNativeC"); */
+	/* printf ("\n objc = %d",objc); */
+
+	if (objc != 2) {
+		Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
+		return TCL_ERROR;
+	}
+
+
+	if (Tcl_ListObjGetElements (interp, objv[1], 
+								&convertListc, &convertListv) != TCL_OK) {
+		return TCL_ERROR;
+	}
+	returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+	for (i = 0; i < convertListc; i++) {
+		/*  need to create a duplicate here because when we modify */
+		/*  the stringIP it'll mess up the original in the calling */
+		/*  context */
+		addrList = Tcl_DuplicateObj(convertListv[i]);
+		stringIP = Tcl_GetStringFromObj(addrList, &elemLen);
+		listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+		/* printf ("\n  ### %s ### string \n", stringIP); */
+		/*  split the ip address and mask */
+		slashPos = strchr(stringIP, (int) '/');
+		if (slashPos == NULL) {
+			/*  straight ip address without mask */
+			mask = 0xffffffff;
+			ipLen = strlen(stringIP);
+		} else {
+			/* ipaddress has the mask, handle the mask and seperate out the  */
+			/*  ip address */
+			/* printf ("\n ** %d ",(uintptr_t)slashPos); */
+			stringMask = slashPos +1;
+			maskLen =strlen(stringMask);
+			/* put mask in hex form */
+			if (maskLen < 3) {
+				mask = atoi(stringMask);
+				mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF;
+			} else {
+				/* mask is in dotted form */
+				if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) {
+					Tcl_AddErrorInfo(interp, "\n    bad format encountered in mask conversion");
+					return TCL_ERROR;	
+				}
+				mask = htonl(mask);
+			}
+			ipLen = (uintptr_t)slashPos  - (uintptr_t)stringIP;
+			/* divide the string into ip and mask portion */
+			*slashPos = '\0';
+			/* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */
+		}
+		if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) {
+			Tcl_AddErrorInfo(interp, 
+							 "\n    bad format encountered in ip conversion");
+			return TCL_ERROR;
+		};
+		inaddr = htonl(inaddr);
+		/* apply the mask the to the ip portion, just to make sure  */
+		/*  what we return is cleaned up */
+		inaddr = inaddr & mask;
+		sprintf(v4HEX,"0x%08X",inaddr);
+		/* printf ("\n\n ### %s",v4HEX); */
+		Tcl_ListObjAppendElement(interp, listPtr,
+								 Tcl_NewStringObj(v4HEX,-1));
+		sprintf(v4HEX,"0x%08X",mask);
+		Tcl_ListObjAppendElement(interp, listPtr,
+								 Tcl_NewStringObj(v4HEX,-1));
+		Tcl_ListObjAppendElement(interp, returnPtr, listPtr);
+		Tcl_DecrRefCount(addrList);
+	}
+	
+	if (convertListc==1) {
+		Tcl_SetObjResult(interp,listPtr);
+	} else {
+		Tcl_SetObjResult(interp,returnPtr);
+	}
+	
+	return TCL_OK;
+}
+
+critcl::ccommand isOverlapNativec {clientData interp objc objv} {
+        int i; 
+        unsigned int ipaddr,ipMask, mask1mask2;
+        unsigned int ipaddr2,ipMask2;
+        int compareListc,comparePrefixMaskc;
+        int allSet,inlineSet,index;
+        Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr;
+        Tcl_Obj *result;
+    static CONST char *options[] = {
+                "-all",     "-inline", "-ipv4", NULL
+    };
+    enum options {
+		OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
+    };
+
+        allSet = 0;
+        inlineSet = 0;
+        listPtr = NULL;
+
+        /* printf ("\n objc = %d",objc); */
+        if (objc < 3) {
+                Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
+                return TCL_ERROR;
+        }
+        for (i = 1; i < objc-3; i++) {
+           if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
+                   != TCL_OK) {
+                   return TCL_ERROR;
+           }
+           switch (index) {
+           case OVERLAP_ALL:
+                   allSet = 1;
+                   /* printf ("\n all selected"); */
+                   break;
+           case OVERLAP_INLINE:
+                   inlineSet = 1;
+                   /* printf ("\n inline selected"); */
+                   break;
+		   case OVERLAP_IPV4:
+			   break;
+           }
+        }
+        /* options are parsed */
+
+        /* create return obj */
+        result = Tcl_GetObjResult (interp);
+
+        /* set ipaddr and ipmask */
+        Tcl_GetIntFromObj(interp,objv[objc-3],(int*)&ipaddr);
+        Tcl_GetIntFromObj(interp,objv[objc-2],(int*)&ipMask);
+
+        /* split the 3rd argument into <ipaddr> <mask> pairs */
+        if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) {
+                return TCL_ERROR;
+        }
+/*       printf("comparing %x/%x \n",ipaddr,ipMask); */
+
+        if (allSet || inlineSet) {
+                listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+        }
+
+        for (i = 0; i < compareListc; i++) {
+					    /* split the ipaddr2 and ipmask2  */
+                if (Tcl_ListObjGetElements (interp, 
+					    compareListv[i], 
+					    &comparePrefixMaskc, 
+					    &comparePrefixMaskv) != TCL_OK) {
+		    return TCL_ERROR;
+                }
+                if (comparePrefixMaskc != 2) {
+		    Tcl_AddErrorInfo(interp,"need format {{<ipaddr> <mask>} {<ipad..}}");
+                        return TCL_ERROR;
+                }
+                Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],(int*)&ipaddr2);
+                Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],(int*)&ipMask2);
+/*               printf(" with %x/%x \n",ipaddr2,ipMask2); */
+                mask1mask2 = ipMask & ipMask2;
+/*               printf("  mask1mask2 %x \n",mask1mask2); */
+/*               printf("  ipaddr & mask1mask2  %x\n",ipaddr & mask1mask2); */
+/*               printf("  ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
+                if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
+		    if (allSet) {
+			if (inlineSet) {
+			    Tcl_ListObjAppendElement(interp, listPtr,
+						     compareListv[i]);
+			} else {
+			    /* printf("\n appending %d",i+1); */
+			    Tcl_ListObjAppendElement(interp, listPtr,
+						     Tcl_NewIntObj(i+1));
+			};
+		    } else {
+			if (inlineSet) {
+			    Tcl_ListObjAppendElement(interp, listPtr,
+						     compareListv[i]);
+			    Tcl_SetObjResult(interp,listPtr);
+			} else {
+			    Tcl_SetIntObj (result, i+1);
+			}
+			return TCL_OK;
+		    };
+                };
+					};
+
+        if (allSet || inlineSet) {
+                Tcl_SetObjResult(interp, listPtr);
+                return TCL_OK;
+        } else {
+                Tcl_SetIntObj (result, 0);
+                return TCL_OK;
+        }
+        return TCL_OK;
+
+
+
+}
+
+
+}
+
+# @sak notprovided ipMorec
+package provide ipMorec 1.0

ADDED   vendor/tcl-packages/dns/msgs/en.msg
Index: vendor/tcl-packages/dns/msgs/en.msg
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/msgs/en.msg
@@ -0,0 +1,8 @@
+# -*- tcl -*-
+package require    msgcat
+namespace import ::msgcat::*
+
+mcset en "option %s not supported"          "option %s not supported"	   
+mcset en "option %s not supported"	    "option %s not supported"	   
+mcset en "not an ip mask: %s"		    "not an ip mask: %s"		   
+mcset en "ip host could not be found in %s" "ip host could not be found in %s"

ADDED   vendor/tcl-packages/dns/pkgIndex.tcl
Index: vendor/tcl-packages/dns/pkgIndex.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/pkgIndex.tcl
@@ -0,0 +1,9 @@
+# pkgIndex.tcl -
+#
+# $Id: pkgIndex.tcl,v 1.21 2010/08/16 17:35:18 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded dns    1.3.5 [list source [file join $dir dns.tcl]]
+package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]]
+package ifneeded ip     1.3   [list source [file join $dir ip.tcl]]
+package ifneeded spf    1.1.1 [list source [file join $dir spf.tcl]]

ADDED   vendor/tcl-packages/dns/resolv.tcl
Index: vendor/tcl-packages/dns/resolv.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/resolv.tcl
@@ -0,0 +1,249 @@
+# resolv.tcl - Copyright (c) 2002 Emmanuel Frecon <emmanuel@sics.se>
+#
+# Original Author --  Emmanuel Frecon - emmanuel@sics.se
+# Modified by Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#  A super module on top of the dns module for host name resolution.
+#  There are two services provided on top of the regular Tcl library:
+#  Firstly, this module attempts to automatically discover the default
+#  DNS server that is setup on the machine that it is run on.  This
+#  server will be used in all further host resolutions.  Secondly, this
+#  module offers a rudimentary cache.  The cache is rudimentary since it
+#  has no expiration on host name resolutions, but this is probably
+#  enough for short lived applications.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require dns 1.0;                # tcllib 1.3
+
+namespace eval ::resolv {
+    namespace export resolve init ignore hostname
+
+    variable R
+    if {![info exists R]} {
+        array set R {
+            initdone   0
+            dns        ""
+            dnsdefault ""
+            ourhost    ""
+            search     {}
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# Command Name     --  ignore
+# Original Author  --  Emmanuel Frecon - emmanuel@sics.se
+#
+# Remove a host name resolution from the cache, if present, so that the
+# next resolution will query the DNS server again.
+#
+# Arguments:
+#    hostname	- Name of host to remove from the cache.
+#
+proc ::resolv::ignore { hostname } {
+    variable Cache
+    catch {unset Cache($hostname)}
+    return
+}
+
+# -------------------------------------------------------------------------
+# Command Name     --  init
+# Original Author  --  Emmanuel Frecon - emmanuel@sics.se
+#
+# Initialise this module with a known host name.  This host (not mandatory)
+# will become the default if the library was not able to find a DNS server.
+# This command can be called several times, its effect is double: actively
+# looking for the default DNS server setup on the running machine; and
+# emptying the host name resolution cache.
+#
+# Arguments:
+#    defaultdns	- Default DNS server
+#
+proc ::resolv::init { {defaultdns ""} {search {}}} {
+    variable R
+    variable Cache
+
+    # Clean the resolver cache
+    catch {unset Cache}
+
+    # Record the default DNS server and search list.
+    set R(dnsdefault) $defaultdns
+    set R(search) $search
+
+    # Now do some intelligent lookup.  We do this on the current
+    # hostname to get a chance to get back some (full) information on
+    # ourselves.  A previous version was using 127.0.0.1, not sure
+    # what is best.
+    set res [catch [list exec nslookup [info hostname]] lkup]
+    if { $res == 0 } {
+	set l [split $lkup]
+	set nl ""
+	foreach e $l {
+	    if { [string length $e] > 0 } {
+		lappend nl $e
+	    }
+	}
+
+        # Now, a lot of mixture to arrange so that hostname points at the
+        # DNS server that we should use for any further request.  This
+        # code is complex, but was actually tested behind a firewall
+        # during the SITI Winter Conference 2003.  There, strangly,
+        # nslookup returned an error but a DNS server was actually setup
+        # correctly...
+        set hostname ""
+	set len [llength $nl]
+	for { set i 0 } { $i < $len } { incr i } {
+	    set e [lindex $nl $i]
+	    if { [string match -nocase "*server*" $e] } {
+		set hostname [lindex $nl [expr {$i + 1}]]
+                if { [string match -nocase "UnKnown" $hostname] } {
+                    set hostname ""
+                }
+		break
+	    }
+	}
+
+	if { $hostname != "" } {
+	    set R(dns) $hostname
+	} else {
+            for { set i 0 } { $i < $len } { incr i } {
+                set e [lindex $nl $i]
+                if { [string match -nocase "*address*" $e] } {
+                    set hostname [lindex $nl [expr {$i + 1}]]
+                    break
+                }
+            }
+            if { $hostname != "" } {
+                set R(dns) $hostname
+            }
+	}
+    }
+
+    if {$R(dns) == ""} {
+        set R(dns) $R(dnsdefault)
+    }
+
+
+    # Start again to find our full name
+    set ourhost ""
+    if {$res == 0} {
+        set dot [string first "." [info hostname]]
+        if { $dot < 0 } {
+            for { set i 0 } { $i < $len } { incr i } {
+                set e [lindex $nl $i]
+                if { [string match -nocase "*name*" $e] } {
+                    set ourhost [lindex $nl [expr {$i + 1}]]
+                    break
+                }
+            }
+            if { $ourhost == "" } {
+                if { ! [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+                    set dot [string first "." $hostname]
+                    set ourhost [format "%s%s" [info hostname] \
+                                     [string range $hostname $dot end]]
+                }
+            }
+        } else {
+            set ourhost [info hostname]
+        }
+    }
+
+    if {$ourhost == ""} {
+        set R(ourhost) [info hostname]
+    } else {
+        set R(ourhost) $ourhost
+    }
+
+
+    set R(initdone) 1
+
+    return $R(dns)
+}
+
+# -------------------------------------------------------------------------
+# Command Name     --  resolve
+# Original Author  --  Emmanuel Frecon - emmanuel@sics.se
+#
+# Resolve a host name to an IP address.  This is a wrapping procedure around
+# the basic services of the dns library.
+#
+# Arguments:
+#    hostname	- Name of host
+#
+proc ::resolv::resolve { hostname } {
+    variable R
+    variable Cache
+
+    # Initialise if not already done. Auto initialisation cannot take
+    # any known DNS server (known to the caller)
+    if { ! $R(initdone) } { init }
+
+    # Check whether this is not simply a raw IP address. What about
+    # IPv6 ??
+    # - We don't have sockets in Tcl for IPv6 protocols - [PT]
+    #
+    if { [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+	return $hostname
+    }
+
+    # Look for hostname in the cache, if found return.
+    if { [array names ::resolv::Cache $hostname] != "" } {
+	return $::resolv::Cache($hostname)
+    }
+
+    # Scream if we don't have any DNS server setup, since we cannot do
+    # anything in that case.
+    if { $R(dns) == "" } {
+	return -code error "No dns server provided"
+    }
+
+    set R(retries) 0
+    set ip [Resolve $hostname]
+
+    # And store the result of resolution in our cache for further use.
+    set Cache($hostname) $ip
+
+    return $ip
+}
+
+# Description:
+#  Attempt to resolve hostname via DNS. If the name cannot be resolved then
+#  iterate through the search list appending each domain in turn until we
+#  get one that succeeds.
+#
+proc ::resolv::Resolve {hostname} {
+    variable R
+    set t [::dns::resolve $hostname -server $R(dns)]
+    ::dns::wait $t;                       # wait with event processing
+    set status [dns::status $t]
+    if {$status == "ok"} {
+        set ip [lindex [::dns::address $t] 0]
+        ::dns::cleanup $t
+    } elseif {$status == "error"
+              && [::dns::errorcode $t] == 3 
+              && $R(retries) < [llength $R(search)]} {
+        ::dns::cleanup $t
+        set suffix [lindex $R(search) $R(retries)]
+        incr R(retries)
+        set new [lindex [split $hostname .] 0].[string trim $suffix .]
+        set ip [Resolve $new]
+    } else {
+        set err [dns::error $t]
+        ::dns::cleanup $t
+        return -code error "dns error: $err"
+    }
+    return $ip
+}
+
+# -------------------------------------------------------------------------
+
+package provide resolv 1.0.3
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:

ADDED   vendor/tcl-packages/dns/spf.tcl
Index: vendor/tcl-packages/dns/spf.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/dns/spf.tcl
@@ -0,0 +1,528 @@
+# spf.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#                         Sender Policy Framework
+#
+#    http://www.ietf.org/internet-drafts/draft-ietf-marid-protocol-00.txt
+#    http://spf.pobox.com/
+#
+# Some domains using SPF:
+#   pobox.org       - mx, a, ptr
+#   oxford.ac.uk    - include
+#   gnu.org         - ip4
+#   aol.com         - ip4, ptr
+#   sourceforge.net - mx, a
+#   altavista.com   - exists,  multiple TXT replies.
+#   oreilly.com     - mx, ptr, include
+#   motleyfool.com  - include (looping includes)
+#
+# -------------------------------------------------------------------------
+# 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.2;                # tcl minimum version
+package require dns;                    # tcllib 1.3
+package require logger;                 # tcllib 1.3
+package require ip;                     # tcllib 1.7
+package require struct::list;           # tcllib 1.7
+package require uri::urn;               # tcllib 1.3
+
+namespace eval spf {
+    namespace export spf
+
+    variable uid
+    if {![info exists uid]} {set uid 0}
+
+    variable log
+    if {![info exists log]} { 
+        set log [logger::init spf]
+        ${log}::setlevel warn
+        proc ${log}::stdoutcmd {level text} {
+            variable service
+            puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
+                $service $level\] $text"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# ip     : ip address of the connecting host
+# domain : the domain to match
+# sender : full sender email address
+#
+proc ::spf::spf {ip domain sender} {
+    variable log
+
+    # 3.3: Initial processing
+    # If the sender address has no local part, set it to postmaster
+    set addr [split $sender @]
+    if {[set len [llength $addr]] == 0} {
+        return -code error -errorcode permanent "invalid sender address"
+    } elseif {$len == 1} {
+        set sender "postmaster@$sender"
+    }
+
+    # 3.4: Record lookup
+    set spf [SPF $domain]
+    if {[string equal $spf none]} {
+        return $spf
+    }
+
+    return [Spf $ip $domain $sender $spf]
+}
+
+proc ::spf::Spf {ip domain sender spf} {
+    variable log
+
+    # 3.4.1: Matching Version
+    if {![regexp {^v=spf(\d)\s+} $spf -> version]} {
+        return none
+    }
+
+    ${log}::debug "$spf"
+
+    if {$version != 1} {
+        return -code error -errorcode permanent \
+            "version mismatch: we only understand SPF 1\
+            this domain has provided version \"$version\""
+    }
+
+    set result ?
+    set seen_domains $domain
+    set explanation {denied}
+
+    set directives [lrange [split $spf { }] 1 end]
+    foreach directive $directives {
+        set prefix [string range $directive 0 0]
+        if {[string equal $prefix "+"] || [string equal $prefix "-"]
+            || [string equal $prefix "?"] || [string equal $prefix "~"]} {
+            set directive [string range $directive 1 end]
+        } else {
+            set prefix "+"
+        }
+
+        set cmd [string tolower [lindex [split $directive {:/=}] 0]]
+        set param [string range $directive [string length $cmd] end]
+
+        if {[info command ::spf::_$cmd] == {}} {
+            # 6.1 Unrecognised directives terminate processing
+            #     but unknown modifiers are ignored.
+            if {[string match "=*" $param]} {
+                continue
+            } else {
+                set result unknown
+                break
+            }
+        } else {
+            set r [catch {::spf::_$cmd $ip $domain $sender $param} res]
+            if {$r} {
+                if {$r == 2} {return $res};# deal with return -code return
+                if {[string equal $res "none"] 
+                    || [string equal $res "error"]
+                    || [string equal $res "unknown"]} {
+                    return $res
+                }
+                return -code error "error in \"$cmd\": $res"
+            }            
+            if {$res} { set result $prefix }
+        }
+        
+        ${log}::debug "$prefix $cmd\($param) -> $result"
+        if {[string equal $result "+"]} break
+    }
+    
+    return $result
+}
+
+proc ::spf::loglevel {level} {
+    variable log
+    ${log}::setlevel $level
+}
+
+# get a guaranteed unique and non-present token id.
+proc ::spf::create_token {} {
+    variable uid
+    set id [incr uid]
+    while {[info exists [set token [namespace current]::$id]]} {
+        set id [incr uid]
+    }
+    return $token
+}
+
+# -------------------------------------------------------------------------
+#
+#                      SPF MECHANISM HANDLERS
+#
+# -------------------------------------------------------------------------
+
+# 4.1:	The "all" mechanism is a test that always matches.  It is used as the
+#	rightmost mechanism in an SPF record to provide an explicit default
+#
+proc ::spf::_all {ip domain sender param} {
+    return 1
+}
+
+# 4.2:	The "include" mechanism triggers a recursive SPF query.
+#	The domain-spec is expanded as per section 8.
+proc ::spf::_include {ip domain sender param} {
+    variable log
+    upvar seen_domains Seen
+
+    if {![string equal [string range $param 0 0] ":"]} {
+        return -code error "dubious parameters for \"include\""
+    }
+    set r ?
+    set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+    if {[lsearch $Seen $new_domain] == -1} {
+        lappend Seen $new_domain
+        set spf [SPF $new_domain]
+        if {[string equal $spf none]} {
+            return $spf
+        } 
+        set r [Spf $ip $new_domain $sender $spf]
+    }
+    return [string equal $r "+"]
+}
+
+# 4.4:	This mechanism matches if <ip> is one of the target's
+#	IP addresses.
+#	e.g: a:smtp.example.com a:mail.%{d} a
+#
+proc ::spf::_a {ip domain sender param} {
+    variable log
+    foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+    if {[string length $testdomain] < 1} {
+        set testdomain $domain
+    } else {
+        set testdomain [Expand $testdomain $ip $domain $sender]
+    }
+    ${log}::debug "  fetching A for $testdomain"
+    set dips [A $testdomain];           # get the IPs for the testdomain
+    foreach dip $dips {
+        ${log}::debug "  compare: ${ip}/${bits} with ${dip}/${bits}"
+        if {[ip::equal $ip/$bits $dip/$bits]} {
+            return 1
+        }
+    }
+    return 0
+}
+
+# 4.5: This mechanism matches if the <sending-host> is one of the MX hosts
+#      for a domain name.
+#
+proc ::spf::_mx {ip domain sender param} {
+    variable log
+    foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+    if {[string length $testdomain] < 1} {
+        set testdomain $domain
+    } else {
+        set testdomain [Expand $testdomain $ip $domain $sender]
+    }
+    ${log}::debug "  fetching MX for $testdomain"
+    set mxs [MX $testdomain]
+
+    foreach mx $mxs {
+        set mx [lindex $mx 1]
+        set mxips [A $mx]
+        foreach mxip $mxips {
+            ${log}::debug "  compare: ${ip}/${bits} with ${mxip}/${bits}"
+            if {[ip::equal $ip/$bits $mxip/$bits]} {
+                return 1
+            }
+        }
+    }
+    return 0
+}
+
+# 4.6: This mechanism tests if the <sending-host>'s name is within a
+#      particular domain.
+#
+proc ::spf::_ptr {ip domain sender param} {
+    variable log
+    set validnames {}
+    if {[catch { set names [PTR $ip] } msg]} {
+        ${log}::debug "  \"$ip\" $msg"
+        return 0
+    }
+    foreach name $names {
+        set addrs [A $name]
+        foreach addr $addrs {
+            if {[ip::equal $ip $addr]} {
+                lappend validnames $name
+                continue
+            }
+        }
+    }
+
+    ${log}::debug "  validnames: $validnames"
+    set testdomain [Expand [string trimleft $param :] $ip $domain $sender]
+    if {$testdomain == {}} {
+        set testdomain $domain
+    }
+    foreach name $validnames {
+        if {[string match "*$testdomain" $name]} {
+            return 1
+        }
+    }
+
+    return 0
+}
+
+# 4.7: These mechanisms test if the <sending-host> falls into a given IP
+#      network.
+#
+proc ::spf::_ip4 {ip domain sender param} {
+    variable log
+    foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+    ${log}::debug "  compare ${ip}/${bits} to ${network}/${bits}"
+    if {[ip::equal $ip/$bits $network/$bits]} {
+        return 1
+    }
+    return 0
+}
+
+# 4.6: These mechanisms test if the <sending-host> falls into a given IP
+#      network.
+#
+proc ::spf::_ip6 {ip domain sender param} {
+    variable log
+    foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+    ${log}::debug "  compare ${ip}/${bits} to ${network}/${bits}"
+    if {[ip::equal $ip/$bits $network/$bits]} {
+        return 1
+    }
+    return 0
+}
+
+# 4.7: This mechanism is used to construct an arbitrary host name that is
+#      used for a DNS A record query.  It allows for complicated schemes
+#      involving arbitrary parts of the mail envelope to determine what is
+#      legal.
+#
+proc ::spf::_exists {ip domain sender param} {
+    variable log
+    set testdomain [Expand [string range $param 1 end] $ip $domain $sender]
+    ${log}::debug "   checking existence of '$testdomain'"
+    if {[catch {A $testdomain}]} {
+        return 0
+    }
+    return 1
+}
+
+# 5.1: Redirected query
+#
+proc ::spf::_redirect {ip domain sender param} {
+    variable log
+    set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+    ${log}::debug ">> redirect to '$new_domain'"
+    set spf [SPF $new_domain]
+    if {![string equal $spf none]} {
+        set spf [Spf $ip $new_domain $sender $spf]
+    }
+    ${log}::debug "<< redirect returning '$spf'"
+    return -code return $spf
+}
+
+# 5.2: Explanation
+#
+proc ::spf::_exp {ip domain sender param} {
+    variable log
+    set new_domain [string range $param 1 end]
+    set exp [TXT $new_domain]
+    set exp [Expand $exp $ip $domain $sender]
+    ${log}::debug "exp expanded to \"$exp\""
+    # FIX ME: need to store this somehow.
+}
+
+# 5.3: Sender accreditation
+#
+proc ::spf::_accredit {ip domain sender param} {
+    variable log
+    set accredit [Expand [string range $param 1 end] $ip $domain $sender]
+    ${log}::debug "  accreditation '$accredit'"
+    # We are not using this at the moment.
+    return 0
+}
+
+
+# 7: Macro expansion
+#
+proc ::spf::Expand {txt ip domain sender} {
+    variable log
+    set re {%\{[[:alpha:]](?:\d+)?r?[\+\-\.,/_=]*\}}
+    set txt [string map {\[ \\\[ \] \\\]} $txt]
+    regsub -all $re $txt {[ExpandMacro & $ip $domain $sender]} cmd
+    set cmd [string map {%% % %_ \  %- %20} $cmd]
+    return [subst -novariables $cmd]
+}
+
+proc ::spf::ExpandMacro {macro ip domain sender} {
+    variable log
+    set re {%\{([[:alpha:]])(\d+)?(r)?([\+\-\.,/_=]*)\}}
+    set C {} ; set T {} ; set R {}; set D {}
+    set r [regexp $re $macro -> C T R D]
+    if {$R == {}} {set R 0} else {set R 1}
+    set res $macro
+    if {$r} {
+        set enc [string is upper $C]
+        switch -exact -- [string tolower $C] {
+            s { set res $sender }
+            l {
+                set addr [split $sender @]
+                if {[llength $addr] < 2} {
+                    set res postmaster
+                } else {
+                    set res [lindex $addr 0]
+                }
+            }
+            o {
+                set addr [split $sender @]
+                if {[llength $addr] < 2} {
+                    set res $sender
+                } else {
+                    set res [lindex $addr 1]
+                }
+            }
+            h - d { set res $domain }
+            i { 
+                set res [ip::normalize $ip]
+                if {[ip::is ipv6 $res]} {
+                    # Convert 0000:0001 to 0.1
+                    set t {}
+                    binary scan [ip::Normalize $ip 6] c* octets
+                    foreach octet $octets {
+                        set hi [expr {($octet & 0xF0) >> 4}]
+                        set lo [expr {$octet & 0x0F}]
+                        lappend t [format %x $hi] [format %x $lo]
+                    }
+                    set res [join $t .]
+                }
+            }
+            v { 
+                if {[ip::is ipv6 $ip]} {
+                    set res ip6
+                } else {
+                    set res "in-addr"
+                }
+            }
+            c { 
+                set res [ip::normalize $ip]
+                if {[ip::is ipv6 $res]} {
+                    set res [ip::contract $res]
+                }
+            }
+            r { 
+                set s [socket -server {} -myaddr [info host] 0]
+                set res [lindex [fconfigure $s -sockname] 1]
+                close $s
+            }
+            t { set res [clock seconds] }
+        }
+        if {$T != {} || $R || $D != {}} {
+            if {$D == {}} {set D .}
+            set res [split $res $D]
+            if {$R} {
+                set res [struct::list::Lreverse $res]
+            }
+            if {$T != {}} {
+                incr T -1
+                set res [join [lrange $res end-$T end] $D]
+            }
+            set res [join $res .]
+        }
+        if {$enc} {
+            # URI encode the result.
+            set res [uri::urn::quote $res]
+        }
+    }
+    return $res
+}
+
+# -------------------------------------------------------------------------
+#
+# DNS helper procedures.
+#
+# -------------------------------------------------------------------------
+
+proc ::spf::Resolve {domain type resultproc} {
+    if {[info command $resultproc] == {}} {
+        return -code error "invalid arg: \"$resultproc\" must be a command"
+    }
+    set tok [dns::resolve $domain -type $type]
+    dns::wait $tok
+    set errorcode NONE
+    if {[string equal [dns::status $tok] "ok"]} {
+        set result [$resultproc $tok]
+        set code   ok
+    } else {
+        set result    [dns::error $tok]
+        set errorcode [dns::errorcode $tok]
+        set code      error
+    }
+    dns::cleanup $tok
+    return -code $code -errorcode $errorcode $result
+}
+
+# 3.4: Record lookup
+proc ::spf::SPF {domain} {
+    set txt ""
+    if {[catch {Resolve $domain SPF ::dns::result} spf]} {
+        set code $::errorCode
+        ${log}::debug "error fetching SPF record: $r"
+        switch -exact -- $code {
+            3 { return -code return [list - "Domain Does Not Exist"] }
+            2 { return -code error -errorcode temporary $spf }
+        }
+        set txt none
+    } else {
+        foreach res $spf {
+            set ndx [lsearch $res rdata]
+            incr ndx
+            if {$ndx != 0} {
+                append txt [string range [lindex $res $ndx] 1 end]
+            }
+        }
+    }
+    return $txt
+}
+
+proc ::spf::TXT {domain} {
+    set r [Resolve $domain TXT ::dns::result]
+    set txt ""
+    foreach res $r {
+        set ndx [lsearch $res rdata]
+        incr ndx
+        if {$ndx != 0} {
+            append txt [string range [lindex $res $ndx] 1 end]
+        }
+    }
+    return $txt
+}
+
+proc ::spf::A {name} {
+    return [Resolve $name A ::dns::address]
+}
+
+
+proc ::spf::AAAA {name} {
+    return [Resolve $name AAAA ::dns::address]
+}
+
+proc ::spf::PTR {addr} {
+    return [Resolve $addr A ::dns::name]
+}
+
+proc ::spf::MX {domain} {
+    set r [Resolve $domain MX ::dns::name]
+    return [lsort -index 0 $r]
+}
+
+    
+# -------------------------------------------------------------------------
+
+package provide spf 1.1.1
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   indent-tabs-mode: nil
+# End:

ADDED   vendor/tcl-packages/json/json.tcl
Index: vendor/tcl-packages/json/json.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/json/json.tcl
@@ -0,0 +1,282 @@
+# json.tcl --
+#
+#	JSON parser for Tcl. Management code, Tcl/C detection and selection.
+#
+# Copyright (c) 2013 by Andreas Kupries
+
+# @mdgen EXCLUDE: jsonc.tcl
+
+package require Tcl 8.4
+namespace eval ::json {}
+
+# ### ### ### ######### ######### #########
+## Management of json implementations.
+
+# ::json::LoadAccelerator --
+#
+#	Loads a named implementation, if possible.
+#
+# Arguments:
+#	key	Name of the implementation to load.
+#
+# Results:
+#	A boolean flag. True if the implementation
+#	was successfully loaded; and False otherwise.
+
+proc ::json::LoadAccelerator {key} {
+    variable accel
+    set r 0
+    switch -exact -- $key {
+	critcl {
+	    # Critcl implementation of json requires Tcl 8.4.
+	    if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
+	    if {[catch {package require tcllibc}]} {return 0}
+	    # Check for the jsonc 1.1.1 API we are fixing later.
+	    set r [llength [info commands ::json::many_json2dict_critcl]]
+	}
+	tcl {
+	    variable selfdir
+	    source [file join $selfdir json_tcl.tcl]
+	    set r 1
+	}
+        default {
+            return -code error "invalid accelerator/impl. package $key:\
+                must be one of [join [KnownImplementations] {, }]"
+        }
+    }
+    set accel($key) $r
+    return $r
+}
+
+# ::json::SwitchTo --
+#
+#	Activates a loaded named implementation.
+#
+# Arguments:
+#	key	Name of the implementation to activate.
+#
+# Results:
+#	None.
+
+proc ::json::SwitchTo {key} {
+    variable accel
+    variable loaded
+    variable apicmds
+
+    if {[string equal $key $loaded]} {
+	# No change, nothing to do.
+	return
+    } elseif {![string equal $key ""]} {
+	# Validate the target implementation of the switch.
+
+	if {![info exists accel($key)]} {
+	    return -code error "Unable to activate unknown implementation \"$key\""
+	} elseif {![info exists accel($key)] || !$accel($key)} {
+	    return -code error "Unable to activate missing implementation \"$key\""
+	}
+    }
+
+    # Deactivate the previous implementation, if there was any.
+
+    if {![string equal $loaded ""]} {
+	foreach c $apicmds {
+	    rename ::json::${c} ::json::${c}_$loaded
+	}
+    }
+
+    # Activate the new implementation, if there is any.
+
+    if {![string equal $key ""]} {
+	foreach c $apicmds {
+	    rename ::json::${c}_$key ::json::${c}
+	}
+    }
+
+    # Remember the active implementation, for deactivation by future
+    # switches.
+
+    set loaded $key
+    return
+}
+
+# ::json::Implementations --
+#
+#	Determines which implementations are
+#	present, i.e. loaded.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys.
+
+proc ::json::Implementations {} {
+    variable accel
+    set res {}
+    foreach n [array names accel] {
+	if {!$accel($n)} continue
+	lappend res $n
+    }
+    return $res
+}
+
+# ::json::KnownImplementations --
+#
+#	Determines which implementations are known
+#	as possible implementations.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys. In the order
+#	of preference, most prefered first.
+
+proc ::json::KnownImplementations {} {
+    return {critcl tcl}
+}
+
+proc ::json::Names {} {
+    return {
+	critcl {tcllibc based}
+	tcl    {pure Tcl}
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Data structures.
+
+namespace eval ::json {
+    variable  selfdir [file dirname [info script]]
+    variable  accel
+    array set accel   {tcl 0 critcl 0}
+    variable  loaded  {}
+
+    variable apicmds {
+	json2dict
+	many-json2dict
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Wrapper fix for the jsonc package to match APIs.
+
+proc ::json::many-json2dict_critcl {args} {
+    eval [linsert $args 0 ::json::many_json2dict_critcl]
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Choose an implementation,
+## most prefered first. Loads only one of the
+## possible implementations. And activates it.
+
+namespace eval ::json {
+    variable e
+    foreach e [KnownImplementations] {
+	if {[LoadAccelerator $e]} {
+	    SwitchTo $e
+	    break
+	}
+    }
+    unset e
+}
+
+# ### ### ### ######### ######### #########
+## Tcl implementation of validation, shared for Tcl and C implementation.
+##
+## The regexp based validation is consistently faster than json-c.
+## Suspected reasons: Tcl REs are mainly in C as well, and json-c has
+## overhead in constructing its own data structures. While irrelevant
+## to validation json-c still builds them, it has no mode doing pure
+## syntax checking.
+
+namespace eval ::json {
+    # Regular expression for tokenizing a JSON text (cf. http://json.org/)
+
+    # tokens consisting of a single character
+    variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
+    variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
+
+    # quoted string tokens
+    variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" "." }
+    variable escapedCharRE "\\\\(?:[join $escapableREs |])"
+    variable unescapedCharRE {[^\\\"]}
+    variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
+
+    # as above, for validation
+    variable escapableREsv { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
+    variable escapedCharREv "\\\\(?:[join $escapableREsv |])"
+    variable stringREv "\"(?:$escapedCharREv|$unescapedCharRE)*\""
+
+    # (unquoted) words
+    variable wordTokens { "true" "false" "null" }
+    variable wordTokenRE [join $wordTokens "|"]
+
+    # number tokens
+    # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
+    # would slow down tokenizing by a factor of up to 3!
+    variable positiveRE {[1-9][[:digit:]]*}
+    variable cardinalRE "-?(?:$positiveRE|0)"
+    variable fractionRE {[.][[:digit:]]+}
+    variable exponentialRE {[eE][+-]?[[:digit:]]+}
+    variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
+
+    # JSON token, and validation
+    variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE"
+    variable tokenREv "$singleCharTokenRE|$stringREv|$wordTokenRE|$numberRE"
+
+
+    # 0..n white space characters
+    set whiteSpaceRE {[[:space:]]*}
+
+    # Regular expression for validating a JSON text
+    variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenREv))*${whiteSpaceRE}$"
+}
+
+
+# Validate JSON text
+# @param jsonText JSON text
+# @return 1 iff $jsonText conforms to the JSON grammar
+#           (@see http://json.org/)
+proc ::json::validate {jsonText} {
+    variable validJsonRE
+
+    return [regexp -- $validJsonRE $jsonText]
+}
+
+# ### ### ### ######### ######### #########
+## These three procedures shared between Tcl and Critcl implementations.
+## See also package "json::write".
+
+proc ::json::dict2json {dictVal} {
+    # XXX: Currently this API isn't symmetrical, as to create proper
+    # XXX: JSON text requires type knowledge of the input data
+    set json ""
+    set prefix ""
+
+    foreach {key val} $dictVal {
+	# key must always be a string, val may be a number, string or
+	# bare word (true|false|null)
+	if {0 && ![string is double -strict $val]
+	    && ![regexp {^(?:true|false|null)$} $val]} {
+	    set val "\"$val\""
+	}
+    	append json "$prefix\"$key\": $val" \n
+	set prefix ,
+    }
+
+    return "\{${json}\}"
+}
+
+proc ::json::list2json {listVal} {
+    return "\[[join $listVal ,]\]"
+}
+
+proc ::json::string2json {str} {
+    return "\"$str\""
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide json 1.3.3

ADDED   vendor/tcl-packages/json/json_tcl.tcl
Index: vendor/tcl-packages/json/json_tcl.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/json/json_tcl.tcl
@@ -0,0 +1,290 @@
+#
+#   JSON parser for Tcl.
+#
+#   See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
+#
+#   Total rework of the code published with version number 1.0 by
+#   Thomas Maeder, Glue Software Engineering AG
+#
+#   $Id: json.tcl,v 1.7 2011/11/10 21:05:58 andreas_kupries Exp $
+#
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+    package require dict
+}
+
+# Parse JSON text into a dict
+# @param jsonText JSON text
+# @return dict (or list) containing the object represented by $jsonText
+proc ::json::json2dict_tcl {jsonText} {
+    variable tokenRE
+
+    set tokens [regexp -all -inline -- $tokenRE $jsonText]
+    set nrTokens [llength $tokens]
+    set tokenCursor 0
+
+#puts T:\t[join $tokens \nT:\t]
+    return [parseValue $tokens $nrTokens tokenCursor]
+}
+
+# Parse multiple JSON entities in a string into a list of dictionaries
+# @param jsonText JSON text to parse
+# @param max      Max number of entities to extract.
+# @return list of (dict (or list) containing the objects) represented by $jsonText
+proc ::json::many-json2dict_tcl {jsonText {max -1}} {
+    variable tokenRE
+
+    if {$max == 0} {
+	return -code error -errorCode {JSON BAD-LIMIT ZERO} \
+	    "Bad limit 0 of json entities to extract."
+    }
+
+    set tokens [regexp -all -inline -- $tokenRE $jsonText]
+    set nrTokens [llength $tokens]
+    set tokenCursor 0
+
+    set result {}
+    set found 0
+    set n $max
+    while {$n != 0} {
+	if {$tokenCursor >= $nrTokens} break
+	lappend result [parseValue $tokens $nrTokens tokenCursor]
+	incr found
+	if {$n > 0} {incr n -1}
+    }
+
+    if {$n > 0} {
+	return -code error -errorCode {JSON BAD-LIMIT TOO LARGE} \
+	    "Bad limit $max of json entities to extract, found only $found."
+    }
+
+    return $result
+}
+
+# Throw an exception signaling an unexpected token
+proc ::json::unexpected {tokenCursor token expected} {
+    return -code error -errorcode [list JSON UNEXPECTED $tokenCursor $expected] \
+	"unexpected token \"$token\" at position $tokenCursor; expecting $expected"
+}
+
+# Get rid of the quotes surrounding a string token and substitute the
+# real characters for escape sequences within it
+# @param token
+# @return unquoted unescaped value of the string contained in $token
+proc ::json::unquoteUnescapeString {tokenCursor token} {
+    variable stringREv
+    set unquoted [string range $token 1 end-1]
+
+    if {![regexp $stringREv $token]} {
+	unexpected $tokenCursor $token STRING
+    }
+
+    set res [subst -nocommands -novariables $unquoted]
+    return $res
+}
+
+# Parse an object member
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+#                        holding current position in $tokens
+# @param objectDictName name (in caller's context) of dict
+#                       representing the JSON object of which to
+#                       parse the next member
+proc ::json::parseObjectMember {tokens nrTokens tokenCursorName objectDictName} {
+    upvar $tokenCursorName tokenCursor
+    upvar $objectDictName objectDict
+
+    set token [lindex $tokens $tokenCursor]
+    set tc $tokenCursor
+    incr tokenCursor
+
+    set leadingChar [string index $token 0]
+    if {$leadingChar eq "\""} {
+        set memberName [unquoteUnescapeString $tc $token]
+
+        if {$tokenCursor == $nrTokens} {
+            unexpected $tokenCursor "END" "\":\""
+        } else {
+            set token [lindex $tokens $tokenCursor]
+            incr tokenCursor
+
+            if {$token eq ":"} {
+                set memberValue [parseValue $tokens $nrTokens tokenCursor]
+                dict set objectDict $memberName $memberValue
+            } else {
+                unexpected $tokenCursor $token "\":\""
+            }
+        }
+    } else {
+        unexpected $tokenCursor $token "STRING"
+    }
+}
+
+# Parse the members of an object
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+#                        holding current position in $tokens
+# @param objectDictName name (in caller's context) of dict
+#                       representing the JSON object of which to
+#                       parse the next member
+proc ::json::parseObjectMembers {tokens nrTokens tokenCursorName objectDictName} {
+    upvar $tokenCursorName tokenCursor
+    upvar $objectDictName objectDict
+
+    while true {
+        parseObjectMember $tokens $nrTokens tokenCursor objectDict
+
+        set token [lindex $tokens $tokenCursor]
+        incr tokenCursor
+
+        switch -exact $token {
+            "," {
+                # continue
+            }
+            "\}" {
+                break
+            }
+            default {
+                unexpected $tokenCursor $token "\",\"|\"\}\""
+            }
+        }
+    }
+}
+
+# Parse an object
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+#                        holding current position in $tokens
+# @return parsed object (Tcl dict)
+proc ::json::parseObject {tokens nrTokens tokenCursorName} {
+    upvar $tokenCursorName tokenCursor
+
+    if {$tokenCursor == $nrTokens} {
+        unexpected $tokenCursor "END" "OBJECT"
+    } else {
+        set result [dict create]
+
+        set token [lindex $tokens $tokenCursor]
+
+        if {$token eq "\}"} {
+            # empty object
+            incr tokenCursor
+        } else {
+            parseObjectMembers $tokens $nrTokens tokenCursor result
+        }
+
+        return $result
+    }
+}
+
+# Parse the elements of an array
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+#                        holding current position in $tokens
+# @param resultName name (in caller's context) of the list
+#                   representing the JSON array
+proc ::json::parseArrayElements {tokens nrTokens tokenCursorName resultName} {
+    upvar $tokenCursorName tokenCursor
+    upvar $resultName result
+
+    while true {
+        lappend result [parseValue $tokens $nrTokens tokenCursor]
+
+        if {$tokenCursor == $nrTokens} {
+            unexpected $tokenCursor "END" "\",\"|\"\]\""
+        } else {
+            set token [lindex $tokens $tokenCursor]
+            incr tokenCursor
+
+            switch -exact $token {
+                "," {
+                    # continue
+                }
+                "\]" {
+                    break
+                }
+                default {
+                    unexpected $tokenCursor $token "\",\"|\"\]\""
+                }
+            }
+        }
+    }
+}
+
+# Parse an array
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+#                        holding current position in $tokens
+# @return parsed array (Tcl list)
+proc ::json::parseArray {tokens nrTokens tokenCursorName} {
+    upvar $tokenCursorName tokenCursor
+
+    if {$tokenCursor == $nrTokens} {
+        unexpected $tokenCursor "END" "ARRAY"
+    } else {
+        set result {}
+
+        set token [lindex $tokens $tokenCursor]
+
+        set leadingChar [string index $token 0]
+        if {$leadingChar eq "\]"} {
+            # empty array
+            incr tokenCursor
+        } else {
+            parseArrayElements $tokens $nrTokens tokenCursor result
+        }
+
+        return $result
+    }
+}
+
+# Parse a value
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+#                        holding current position in $tokens
+# @return parsed value (dict, list, string, number)
+proc ::json::parseValue {tokens nrTokens tokenCursorName} {
+    upvar $tokenCursorName tokenCursor
+
+    if {$tokenCursor == $nrTokens} {
+        unexpected $tokenCursor "END" "VALUE"
+    } else {
+        set token [lindex $tokens $tokenCursor]
+	set tc $tokenCursor
+        incr tokenCursor
+
+        set leadingChar [string index $token 0]
+        switch -exact -- $leadingChar {
+            "\{" {
+                return [parseObject $tokens $nrTokens tokenCursor]
+            }
+            "\[" {
+                return [parseArray $tokens $nrTokens tokenCursor]
+            }
+            "\"" {
+                # quoted string
+                return [unquoteUnescapeString $tc $token]
+            }
+            "t" -
+            "f" -
+            "n" {
+                # bare word: true, false, null (return as is)
+                return $token
+            }
+            default {
+                # number?
+                if {[string is double -strict $token]} {
+                    return $token
+                } else {
+                    unexpected $tokenCursor $token "VALUE"
+                }
+            }
+        }
+    }
+}

ADDED   vendor/tcl-packages/json/json_write.tcl
Index: vendor/tcl-packages/json/json_write.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/json/json_write.tcl
@@ -0,0 +1,200 @@
+# json_write.tcl --
+#
+#	Commands for the generation of JSON (Java Script Object Notation).
+#
+# Copyright (c) 2009-2011 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: json_write.tcl,v 1.2 2011/08/24 20:09:44 andreas_kupries Exp $
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+
+namespace eval ::json::write {
+    namespace export \
+	string array object indented aligned
+
+    namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::json::write::indented {{bool {}}} {
+    variable indented
+
+    if {[llength [info level 0]] > 2} {
+	return -code error {wrong # args: should be "json::write indented ?bool?"}
+    } elseif {[llength [info level 0]] == 2} {
+	if {![::string is boolean -strict $bool]} {
+	    return -code error "Expected boolean, got \"$bool\""
+	}
+	set indented $bool
+	if {!$indented} {
+	    variable aligned 0
+	}
+    }
+
+    return $indented
+}
+
+proc ::json::write::aligned {{bool {}}} {
+    variable aligned
+
+    if {[llength [info level 0]] > 2} {
+	return -code error {wrong # args: should be "json::write aligned ?bool?"}
+    } elseif {[llength [info level 0]] == 2} {
+	if {![::string is boolean -strict $bool]} {
+	    return -code error "Expected boolean, got \"$bool\""
+	}
+	set aligned $bool
+	if {$aligned} {
+	    variable indented 1
+	}
+    }
+
+    return $aligned
+}
+
+proc ::json::write::string {s} {
+    variable quotes
+    return "\"[::string map $quotes $s]\""
+}
+
+proc ::json::write::array {args} {
+    # always compact form.
+    return "\[[join $args ,]\]"
+}
+
+proc ::json::write::object {args} {
+    # The dict in args maps string keys to json-formatted data. I.e.
+    # we have to quote the keys, but not the values, as the latter are
+    # already in the proper format.
+
+    variable aligned
+    variable indented
+
+    if {[llength $args] %2 == 1} {
+	return -code error {wrong # args, expected an even number of arguments}
+    }
+
+    set dict {}
+    foreach {k v} $args {
+	lappend dict [string $k] $v
+    }
+
+    if {$aligned} {
+	set max [MaxKeyLength $dict]
+    }
+
+    if {$indented} {
+	set content {}
+	foreach {k v} $dict {
+	    if {$aligned} {
+		set k [AlignLeft $max $k]
+	    }
+	    if {[::string match *\n* $v]} {
+		# multi-line value
+		lappend content "    $k : [Indent $v {    } 1]"
+	    } else {
+		# single line value.
+		lappend content "    $k : $v"
+	    }
+	}
+	if {[llength $content]} {
+	    return "\{\n[join $content ,\n]\n\}"
+	} else {
+	    return "\{\}"
+	}
+    } else {
+	# ultra compact form.
+	set tmp {}
+	foreach {k v} $dict {
+	    lappend tmp "$k:$v"
+	}
+	return "\{[join $tmp ,]\}"
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Internals.
+
+proc ::json::write::Indent {text prefix skip} {
+    set pfx ""
+    set result {}
+    foreach line [split $text \n] {
+	if {!$skip} { set pfx $prefix } else { incr skip -1 }
+	lappend result ${pfx}$line
+    }
+    return [join $result \n]
+}
+
+proc ::json::write::MaxKeyLength {dict} {
+    # Find the max length of the keys in the dictionary.
+
+    set lengths 0 ; # This will be the max if the dict is empty, and
+		    # prevents the mathfunc from throwing errors for
+		    # that case.
+
+    foreach str [dict keys $dict] {
+	lappend lengths [::string length $str]
+    }
+
+    return [tcl::mathfunc::max {*}$lengths]
+}
+
+proc ::json::write::AlignLeft {fieldlen str} {
+    return [format %-${fieldlen}s $str]
+    #return $str[::string repeat { } [expr {$fieldlen - [::string length $str]}]]
+}
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::json::write {
+    # Configuration of the layout to write.
+
+    # indented = boolean. objects are indented.
+    # aligned  = boolean. object keys are aligned vertically.
+
+    # aligned  => indented.
+
+    # Combinations of the format specific entries
+    # I A |
+    # - - + ---------------------
+    # 0 0 | Ultracompact (no whitespace, single line)
+    # 1 0 | Indented
+    # 0 1 | Not possible, per the implications above.
+    # 1 1 | Indented + vertically aligned keys
+    # - - + ---------------------
+
+    variable indented 1
+    variable aligned  1
+
+    variable quotes \
+	[list "\"" "\\\"" \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t \
+	     \x00 \\u0000 \x01 \\u0001 \x02 \\u0002 \x03 \\u0003 \
+	     \x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007 \
+	     \x0b \\u000b \x0e \\u000e \x0f \\u000f \x10 \\u0010 \
+	     \x11 \\u0011 \x12 \\u0012 \x13 \\u0013 \x14 \\u0014 \
+	     \x15 \\u0015 \x16 \\u0016 \x17 \\u0017 \x18 \\u0018 \
+	     \x19 \\u0019 \x1a \\u001a \x1b \\u001b \x1c \\u001c \
+	     \x1d \\u001d \x1e \\u001e \x1f \\u001f \x7f \\u007f \
+	     \x80 \\u0080 \x81 \\u0081 \x82 \\u0082 \x83 \\u0083 \
+	     \x84 \\u0084 \x85 \\u0085 \x86 \\u0086 \x87 \\u0087 \
+	     \x88 \\u0088 \x89 \\u0089 \x8a \\u008a \x8b \\u008b \
+	     \x8c \\u008c \x8d \\u008d \x8e \\u008e \x8f \\u008f \
+	     \x90 \\u0090 \x91 \\u0091 \x92 \\u0092 \x93 \\u0093 \
+	     \x94 \\u0094 \x95 \\u0095 \x96 \\u0096 \x97 \\u0097 \
+	     \x98 \\u0098 \x99 \\u0099 \x9a \\u009a \x9b \\u009b \
+	     \x9c \\u009c \x9d \\u009d \x9e \\u009e \x9f \\u009f ]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide json::write 1.0.3
+return

ADDED   vendor/tcl-packages/json/jsonc.tcl
Index: vendor/tcl-packages/json/jsonc.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/json/jsonc.tcl
@@ -0,0 +1,171 @@
+# jsonc.tcl --
+#
+#       Implementation of a JSON parser in C.
+#	Binding to a yacc/bison parser by Mikhail.
+#
+# Copyright (c) 2013 - critcl wrapper - Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Copyright (c) 2013 - C binding      - mi+tcl.tk-2013@aldan.algebra.com
+
+package require critcl
+# @sak notprovided jsonc
+package provide jsonc 1.1.1
+package require Tcl 8.4
+
+#critcl::cheaders -g
+#critcl::debug memory symbols
+critcl::cheaders -Ic c/*.h
+critcl::csources c/*.c
+
+# # ## ### Import base declarations, forwards ### ## # #
+
+critcl::ccode {
+    #include <json_y.h>
+}
+
+# # ## ### Main Conversion ### ## # #
+
+namespace eval ::json {
+    critcl::ccommand json2dict_critcl {dummy I objc objv} {
+	struct context context = { NULL };
+
+	if (objc != 2) {
+	    Tcl_WrongNumArgs(I, 1, objv, "json");
+	    return TCL_ERROR;
+	}
+
+	context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
+	context.I      = I;
+	context.has_error = 0;
+	context.result = TCL_ERROR;
+
+	jsonparse (&context);
+	return context.result;
+    }
+
+    # Issue with critcl 2 used here. Cannot use '-', incomplete distinction of C and Tcl names.
+    # The json.tcl file making use of this code has a wrapper fixing the issue.
+    critcl::ccommand many_json2dict_critcl {dummy I objc objv} {
+	struct context context = { NULL };
+
+	int                      max;
+	int                      found;
+
+	Tcl_Obj* result = Tcl_NewListObj (0, NULL);
+
+	if ((objc < 2) || (objc > 3)) {
+	    Tcl_WrongNumArgs(I, 1, objv, "jsonText ?max?");
+	    return TCL_ERROR;
+	}
+
+	if (objc == 3) {
+	    if (Tcl_GetIntFromObj(I, objv[2], &max) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if (max <= 0) {
+		Tcl_AppendResult (I, "Bad limit ",
+				  Tcl_GetString (objv[2]),
+				  " of json entities to extract.",
+				  NULL);
+		Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", NULL);
+		return TCL_ERROR;
+	    }
+
+	} else {
+	    max = -1;
+	}
+
+	context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
+	context.I      = I;
+	context.has_error = 0;
+	found  = 0;
+
+	/* Iterate over the input until
+	 * - we have gotten all requested values.
+	 * - we have run out of input
+	 * - we have run into an error
+	 */
+
+	while ((max < 0) || max) {
+	    context.result = TCL_ERROR;
+	    jsonparse (&context);
+
+	    /* parse error, abort */
+	    if (context.result != TCL_OK) {
+		Tcl_DecrRefCount (result);
+		return TCL_ERROR;
+	    }
+
+	    /* Proper value extracted, extend result */
+	    found ++;
+	    Tcl_ListObjAppendElement(I, result,
+				     Tcl_GetObjResult (I));
+
+	    /* Count down on the number of still missing
+	     * values, if not asking for all (-1)
+	     */
+	    if (max > 0) max --;
+
+	    /* Jump over trailing whitespace for proper end-detection */
+	    jsonskip (&context);
+
+	    /* Abort if we have consumed all input */
+	    if (!context.remaining) break;
+
+	    /* Clear scratch pad before continuing */
+	    context.obj = NULL;
+	}
+
+	/* While all parses were ok we reached end of
+	 * input without getting all requested values,
+	 * this is an error
+	 */
+	if (max > 0) {
+	    char buf [30];
+	    sprintf (buf, "%d", found);
+            Tcl_ResetResult (I);
+	    Tcl_AppendResult (I, "Bad limit ",
+			      Tcl_GetString (objv[2]),
+			      " of json entities to extract, found only ",
+			      buf,
+			      ".",
+			      NULL);
+	    Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", "TOO", "LARGE", NULL);
+	    Tcl_DecrRefCount (result);
+	    return TCL_ERROR;
+	}
+
+	/* We are good and done */
+	Tcl_SetObjResult(I, result);
+	return TCL_OK;
+    }
+
+    if 0 {critcl::ccommand validate_critcl {dummy I objc objv} {
+	struct context context = { NULL };
+
+	if (objc != 2) {
+	    Tcl_WrongNumArgs(I, 1, objv, "jsonText");
+	    return TCL_ERROR;
+	}
+
+	context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
+	context.I      = I;
+	context.result = TCL_ERROR;
+
+	/* Iterate over the input until we have run
+	 * out of text, or encountered an error. We
+	 * use only the lexer here, and told it to not
+	* create superfluous token values.
+	 */
+
+	while (context.remaining) {
+	    if (jsonlex (&context) == -1) {
+		Tcl_SetObjResult(I, Tcl_NewBooleanObj (0));
+		return TCL_OK;
+	    }
+	}
+
+	/* We are good and done */
+	Tcl_SetObjResult(I, Tcl_NewBooleanObj (1));
+	return TCL_OK;
+    }}
+}

ADDED   vendor/tcl-packages/json/pkgIndex.tcl
Index: vendor/tcl-packages/json/pkgIndex.tcl
==================================================================
--- /dev/null
+++ vendor/tcl-packages/json/pkgIndex.tcl
@@ -0,0 +1,7 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded json 1.3.3 [list source [file join $dir json.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded json::write 1.0.3 [list source [file join $dir json_write.tcl]]