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