1# ip.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# Internet address manipulation. 4# 5# RFC 3513: IPv6 addressing. 6# 7# ------------------------------------------------------------------------- 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# ------------------------------------------------------------------------- 11# 12# $Id: ip.tcl,v 1.14 2010/08/16 17:35:18 andreas_kupries Exp $ 13 14# @mdgen EXCLUDE: ipMoreC.tcl 15 16package require Tcl 8.2; # tcl minimum version 17 18namespace eval ip { 19 variable version 1.2 20 variable rcsid {$Id: ip.tcl,v 1.14 2010/08/16 17:35:18 andreas_kupries Exp $} 21 22 namespace export is version normalize equal type contract mask collapse subtract 23 #catch {namespace ensemble create} 24 25 variable IPv4Ranges 26 if {![info exists IPv4Ranges]} { 27 array set IPv4Ranges { 28 0/8 private 29 10/8 private 30 127/8 private 31 172.16/12 private 32 192.168/16 private 33 223/8 reserved 34 224/3 reserved 35 } 36 } 37 38 variable IPv6Ranges 39 if {![info exists IPv6Ranges]} { 40 # RFC 3513: 2.4 41 # RFC 3056: 2 42 array set IPv6Ranges { 43 2002::/16 "6to4 unicast" 44 fe80::/10 "link local" 45 fec0::/10 "site local" 46 ff00::/8 "multicast" 47 ::/128 "unspecified" 48 ::1/128 "localhost" 49 } 50 } 51} 52 53proc ::ip::is {class ip} { 54 foreach {ip mask} [split $ip /] break 55 switch -exact -- $class { 56 ipv4 - IPv4 - 4 { 57 return [IPv4? $ip] 58 } 59 ipv6 - IPv6 - 6 { 60 return [IPv6? $ip] 61 } 62 default { 63 return -code error "bad class \"$class\": must be ipv4 or ipv6" 64 } 65 } 66} 67 68proc ::ip::version {ip} { 69 set version -1 70 foreach {addr mask} [split $ip /] break 71 if {[IPv4? $addr]} { 72 set version 4 73 } elseif {[IPv6? $addr]} { 74 set version 6 75 } 76 return $version 77} 78 79proc ::ip::equal {lhs rhs} { 80 foreach {LHS LM} [SplitIp $lhs] break 81 foreach {RHS RM} [SplitIp $rhs] break 82 if {[set version [version $LHS]] != [version $RHS]} { 83 return -code error "type mismatch:\ 84 cannot compare different address types" 85 } 86 if {$version == 4} {set fmt I} else {set fmt I4} 87 set LHS [Mask$version [Normalize $LHS $version] $LM] 88 set RHS [Mask$version [Normalize $RHS $version] $RM] 89 binary scan $LHS $fmt LLL 90 binary scan $RHS $fmt RRR 91 foreach L $LLL R $RRR { 92 if {$L != $R} {return 0} 93 } 94 return 1 95} 96 97proc ::ip::collapse {prefixlist} { 98 #puts **[llength $prefixlist]||$prefixlist 99 100 # Force mask parts into length notation for the following merge 101 # loop to work. 102 foreach ip $prefixlist { 103 foreach {addr mask} [SplitIp $ip] break 104 set nip $addr/[maskToLength [maskToInt $mask]] 105 #puts "prefix $ip = $nip" 106 lappend tmp $nip 107 } 108 set prefixlist $tmp 109 110 #puts @@[llength $prefixlist]||$prefixlist 111 112 set ret {} 113 set can_normalize_more 1 114 while {$can_normalize_more} { 115 set prefixlist [lsort -dict $prefixlist] 116 117 #puts ||[llength $prefixlist]||$prefixlist 118 119 set can_normalize_more 0 120 121 for {set idx 0} {$idx < [llength $prefixlist]} {incr idx} { 122 set nextidx [expr {$idx + 1}] 123 124 set item [lindex $prefixlist $idx] 125 set nextitem [lindex $prefixlist $nextidx] 126 127 if {$nextitem eq ""} { 128 lappend ret $item 129 continue 130 } 131 132 set itemmask [mask $item] 133 set nextitemmask [mask $nextitem] 134 135 set item [prefix $item] 136 137 if {$itemmask ne $nextitemmask} { 138 lappend ret $item/$itemmask 139 continue 140 } 141 142 set adjacentitem [intToString [nextNet $item $itemmask]]/$itemmask 143 144 if {$nextitem ne $adjacentitem} { 145 lappend ret $item/$itemmask 146 continue 147 } 148 149 set upmask [expr {$itemmask - 1}] 150 set upitem "$item/$upmask" 151 152 # Maybe just checking the llength of the result is enough ? 153 if {[reduceToAggregates [list $item $nextitem $upitem]] != [list $upitem]} { 154 lappend ret $item/$itemmask 155 continue 156 } 157 158 set can_normalize_more 1 159 160 incr idx 161 lappend ret $upitem 162 } 163 164 set prefixlist $ret 165 set ret {} 166 } 167 168 return $prefixlist 169} 170 171 172proc ::ip::normalize {ip {Ip4inIp6 0}} { 173 foreach {ip mask} [SplitIp $ip] break 174 set version [version $ip] 175 set s [ToString [Normalize $ip $version] $Ip4inIp6] 176 if {($version == 6 && $mask != 128) || ($version == 4 && $mask != 32)} { 177 append s /$mask 178 } 179 return $s 180} 181 182proc ::ip::contract {ip} { 183 foreach {ip mask} [SplitIp $ip] break 184 set version [version $ip] 185 set s [ToString [Normalize $ip $version]] 186 if {$version == 6} { 187 set r "" 188 foreach o [split $s :] { 189 append r [format %x: 0x$o] 190 } 191 set r [string trimright $r :] 192 regsub {(?:^|:)0(?::0)+(?::|$)} $r {::} r 193 } else { 194 set r [string trimright $s .0] 195 } 196 return $r 197} 198 199proc ::ip::subtract {hosts} { 200 set positives {} 201 set negatives {} 202 203 foreach host $hosts { 204 foreach {addr mask} [SplitIp $host] break 205 set host $addr/[maskToLength [maskToInt $mask]] 206 207 if {[string match "-*" $host]} { 208 set host [string trimleft $host "-"] 209 lappend negatives $host 210 } else { 211 lappend positives $host 212 } 213 } 214 215 # Reduce to aggregates if needed 216 if {[llength $positives] > 1} { 217 set positives [reduceToAggregates $positives] 218 } 219 220 if {![llength $positives]} { 221 return {} 222 } 223 224 if {[llength $negatives] > 1} { 225 set negatives [reduceToAggregates $negatives] 226 } 227 228 if {![llength $negatives]} { 229 return $positives 230 } 231 232 # Remove positives that are cancelled out entirely 233 set new_positives {} 234 foreach positive $positives { 235 set found 0 236 foreach negative $negatives { 237 # Do we need the exact check, i.e. ==, or 'eq', or would 238 # checking the length of result == 1 be good enough? 239 if {[reduceToAggregates [list $positive $negative]] == [list $negative]} { 240 set found 1 241 break 242 } 243 } 244 245 if {!$found} { 246 lappend new_positives $positive 247 } 248 } 249 set positives $new_positives 250 251 set retval {} 252 foreach positive $positives { 253 set negatives_found {} 254 foreach negative $negatives { 255 if {[isOverlap $positive $negative]} { 256 lappend negatives_found $negative 257 } 258 } 259 260 if {![llength $negatives_found]} { 261 lappend retval $positive 262 continue 263 } 264 265 # Convert the larger subnet 266 ## Determine smallest subnet involved 267 set maxmask 0 268 foreach subnet [linsert $negatives 0 $positive] { 269 set mask [mask $subnet] 270 if {$mask > $maxmask} { 271 set maxmask $mask 272 } 273 } 274 275 set positive_list [ExpandSubnet $positive $maxmask] 276 set negative_list {} 277 foreach negative $negatives_found { 278 foreach negative_subnet [ExpandSubnet $negative $maxmask] { 279 lappend negative_list $negative_subnet 280 } 281 } 282 283 foreach positive_sub $positive_list { 284 if {[lsearch -exact $negative_list $positive_sub] < 0} { 285 lappend retval $positive_sub 286 } 287 } 288 } 289 290 return $retval 291} 292 293proc ::ip::ExpandSubnet {subnet newmask} { 294 #set oldmask [maskToLength [maskToInt [mask $subnet]]] 295 set oldmask [mask $subnet] 296 set subnet [prefix $subnet] 297 298 set numsubnets [expr {round(pow(2, ($newmask - $oldmask)))}] 299 300 set ret {} 301 for {set idx 0} {$idx < $numsubnets} {incr idx} { 302 lappend ret "${subnet}/${newmask}" 303 set subnet [intToString [nextNet $subnet $newmask]] 304 } 305 306 return $ret 307} 308 309# Returns an IP address prefix. 310# For instance: 311# prefix 192.168.1.4/16 => 192.168.0.0 312# prefix fec0::4/16 => fec0:0:0:0:0:0:0:0 313# prefix fec0::4/ffff:: => fec0:0:0:0:0:0:0:0 314# 315proc ::ip::prefix {ip} { 316 foreach {addr mask} [SplitIp $ip] break 317 set version [version $addr] 318 set addr [Normalize $addr $version] 319 return [ToString [Mask$version $addr $mask]] 320} 321 322# Return the address type. For IPv4 this is one of private, reserved 323# or normal 324# For IPv6 it is one of site local, link local, multicast, unicast, 325# unspecified or loopback. 326proc ::ip::type {ip} { 327 set version [version $ip] 328 upvar [namespace current]::IPv${version}Ranges types 329 set ip [prefix $ip] 330 foreach prefix [array names types] { 331 set mask [mask $prefix] 332 if {[equal $ip/$mask $prefix]} { 333 return $types($prefix) 334 } 335 } 336 if {$version == 4} { 337 return "normal" 338 } else { 339 return "unicast" 340 } 341} 342 343proc ::ip::mask {ip} { 344 foreach {addr mask} [split $ip /] break 345 return $mask 346} 347 348# ------------------------------------------------------------------------- 349 350# Returns true is the argument can be converted into an IPv4 address. 351# 352proc ::ip::IPv4? {ip} { 353 if {[string first : $ip] >= 0} { 354 return 0 355 } 356 if {[catch {Normalize4 $ip}]} { 357 return 0 358 } 359 return 1 360} 361 362proc ::ip::IPv6? {ip} { 363 set octets [split $ip :] 364 if {[llength $octets] < 3 || [llength $octets] > 8} { 365 return 0 366 } 367 set ndx 0 368 foreach octet $octets { 369 incr ndx 370 if {[string length $octet] < 1} continue 371 if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} continue 372 if {$ndx >= [llength $octets] && [IPv4? $octet]} continue 373 if {$ndx == 2 && [lindex $octets 0] == 2002 && [IPv4? $octet]} continue 374 #"Invalid IPv6 address \"$ip\"" 375 return 0 376 } 377 if {[regexp {^:[^:]} $ip]} { 378 #"Invalid ipv6 address \"$ip\" (starts with :)" 379 return 0 380 } 381 if {[regexp {[^:]:$} $ip]} { 382 # "Invalid IPv6 address \"$ip\" (ends with :)" 383 return 0 384 } 385 if {[regsub -all :: $ip "|" junk] > 1} { 386 # "Invalid IPv6 address \"$ip\" (more than one :: pattern)" 387 return 0 388 } 389 return 1 390} 391 392proc ::ip::Mask4 {ip {bits {}}} { 393 if {[string length $bits] < 1} { set bits 32 } 394 binary scan $ip I ipx 395 if {[string is integer $bits]} { 396 set mask [expr {(0xFFFFFFFF << (32 - $bits)) & 0xFFFFFFFF}] 397 } else { 398 binary scan [Normalize4 $bits] I mask 399 } 400 return [binary format I [expr {$ipx & $mask}]] 401} 402 403proc ::ip::Mask6 {ip {bits {}}} { 404 if {[string length $bits] < 1} { set bits 128 } 405 if {[string is integer $bits]} { 406 set mask [binary format B128 [string repeat 1 $bits]] 407 } else { 408 binary scan [Normalize6 $bits] I4 mask 409 } 410 binary scan $ip I4 Addr 411 binary scan $mask I4 Mask 412 foreach A $Addr M $Mask { 413 lappend r [expr {$A & $M}] 414 } 415 return [binary format I4 $r] 416} 417 418 419 420# A network address specification is an IPv4 address with an optional bitmask 421# Split an address specification into a IPv4 address and a network bitmask. 422# This doesn't validate the address portion. 423# If a spec with no mask is provided then the mask will be 32 424# (all bits significant). 425# Masks may be either integer number of significant bits or dotted-quad 426# notation. 427# 428proc ::ip::SplitIp {spec} { 429 set slash [string last / $spec] 430 if {$slash != -1} { 431 incr slash -1 432 set ip [string range $spec 0 $slash] 433 incr slash 2 434 set bits [string range $spec $slash end] 435 } else { 436 set ip $spec 437 if {[string length $ip] > 0 && [version $ip] == 6} { 438 set bits 128 439 } else { 440 set bits 32 441 } 442 } 443 return [list $ip $bits] 444} 445 446# Given an IP string from the user, convert to a normalized internal rep. 447# For IPv4 this is currently a hex string (0xHHHHHHHH). 448# For IPv6 this is a binary string or 16 chars. 449proc ::ip::Normalize {ip {version 0}} { 450 if {$version < 0} { 451 set version [version $ip] 452 if {$version < 0} { 453 return -code error "invalid address \"$ip\":\ 454 value must be a valid IPv4 or IPv6 address" 455 } 456 } 457 return [Normalize$version $ip] 458} 459 460proc ::ip::Normalize4 {ip} { 461 set octets [split $ip .] 462 if {[llength $octets] > 4} { 463 return -code error "invalid ip address \"$ip\"" 464 } elseif {[llength $octets] < 4} { 465 set octets [lrange [concat $octets 0 0 0] 0 3] 466 } 467 foreach oct $octets { 468 if {$oct < 0 || $oct > 255} { 469 return -code error "invalid ip address" 470 } 471 } 472 return [binary format c4 $octets] 473} 474 475proc ::ip::Normalize6 {ip} { 476 set octets [split $ip :] 477 set ip4embed [string first . $ip] 478 set len [llength $octets] 479 if {$len < 0 || $len > 8} { 480 return -code error "invalid address: this is not an IPv6 address" 481 } 482 set result "" 483 for {set n 0} {$n < $len} {incr n} { 484 set octet [lindex $octets $n] 485 if {$octet == {}} { 486 if {$n == 0 || $n == ($len - 1)} { 487 set octet \0\0 488 } else { 489 set missing [expr {9 - $len}] 490 if {$ip4embed != -1} {incr missing -1} 491 set octet [string repeat \0\0 $missing] 492 } 493 } elseif {[string first . $octet] != -1} { 494 set octet [Normalize4 $octet] 495 } else { 496 set m [expr {4 - [string length $octet]}] 497 if {$m != 0} { 498 set octet [string repeat 0 $m]$octet 499 } 500 set octet [binary format H4 $octet] 501 } 502 append result $octet 503 } 504 if {[string length $result] != 16} { 505 return -code error "invalid address: \"$ip\" is not an IPv6 address" 506 } 507 return $result 508} 509 510 511# This will convert a full ipv4/ipv6 in binary format into a normal 512# expanded string rep. 513proc ::ip::ToString {bin {Ip4inIp6 0}} { 514 set len [string length $bin] 515 set r "" 516 if {$len == 4} { 517 binary scan $bin c4 octets 518 foreach octet $octets { 519 lappend r [expr {$octet & 0xff}] 520 } 521 return [join $r .] 522 } elseif {$len == 16} { 523 if {$Ip4inIp6 == 0} { 524 binary scan $bin H32 hex 525 for {set n 0} {$n < 32} {incr n} { 526 append r [string range $hex $n [incr n 3]]: 527 } 528 return [string trimright $r :] 529 } else { 530 binary scan $bin H24c4 hex octets 531 for {set n 0} {$n < 24} {incr n} { 532 append r [string range $hex $n [incr n 3]]: 533 } 534 foreach octet $octets { 535 append r [expr {$octet & 0xff}]. 536 } 537 return [string trimright $r .] 538 } 539 } else { 540 return -code error "invalid binary address:\ 541 argument is neither an IPv4 nor an IPv6 address" 542 } 543} 544 545# ------------------------------------------------------------------------- 546# Load extended command set. 547 548source [file join [file dirname [info script]] ipMore.tcl] 549 550# ------------------------------------------------------------------------- 551 552package provide ip $::ip::version 553 554# ------------------------------------------------------------------------- 555# Local Variables: 556# indent-tabs-mode: nil 557# End: 558