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

package ifneeded defer 1 [list source [file join $dir defer.tcl]]

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

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

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

# 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

# -*- 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"

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

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

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

# 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

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

# 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

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

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