tcllib 1.17-dfsg-1 / usr / share / tcltk / tcllib1.17 / dns / ip.tcl

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