home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Net / CIDR / Lite.pm
Text File  |  2006-11-29  |  16KB  |  595 lines
  1. package Net::CIDR::Lite;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. use Carp qw(confess);
  6.  
  7. $VERSION = '0.15';
  8.  
  9. my %masks;
  10. my @fields = qw(PACK UNPACK NBITS MASKS);
  11.  
  12. # Preloaded methods go here.
  13.  
  14. sub new {
  15.     my $proto = shift;
  16.     my $class = ref($proto) || $proto;
  17.     my $self = bless {}, $class;
  18.     $self->add_any($_) for @_;
  19.     $self;
  20. }
  21.  
  22. sub add_any {
  23.     my $self = shift;
  24.     for (@_) {
  25.         tr|/|| && do { $self->add($_); next };
  26.         tr|-|| && do { $self->add_range($_); next };
  27.         UNIVERSAL::isa($_, 'Net::CIDR::Lite') && do {
  28.             $self->add_cidr($_); next
  29.         };
  30.         $self->add_ip($_), next;
  31.     }
  32.     $self;
  33. }
  34.  
  35. sub add {
  36.     my $self = shift;
  37.     my ($ip, $mask) = split "/", shift;
  38.     $self->_init($ip) || confess "Can't determine ip format" unless %$self;
  39.     confess "Bad mask $mask"
  40.         unless $mask =~ /^\d+$/ and 2 <= $mask and $mask <= $self->{NBITS};
  41.     $mask += 8;
  42.     my $start = $self->{PACK}->($ip) & $self->{MASKS}[$mask]
  43.         or confess "Bad ip address: $ip";
  44.     my $end = $self->_add_bit($start, $mask);
  45.     ++$$self{RANGES}{$start} || delete $$self{RANGES}{$start};
  46.     --$$self{RANGES}{$end}   || delete $$self{RANGES}{$end};
  47.     $self;
  48. }
  49.  
  50. sub clean {
  51.     my $self = shift;
  52.     my $ranges = $$self{RANGES};
  53.     my $total;
  54.     $$self{RANGES} = {
  55.       map { $total ? ($total+=$$ranges{$_})? () : ($_=>-1)
  56.                    : do { $total+=$$ranges{$_}; ($_=>1) }
  57.           } sort keys %$ranges
  58.     };
  59.     $self;
  60. }
  61.  
  62. sub list {
  63.     my $self = shift;
  64.     my $nbits = $$self{NBITS};
  65.     my ($start, $total);
  66.     my @results;
  67.     for my $ip (sort keys %{$$self{RANGES}}) {
  68.         $start = $ip unless $total;
  69.         $total += $$self{RANGES}{$ip};
  70.         unless ($total) {
  71.             while ($start lt $ip) {
  72.                 my ($end, $bits);
  73.                 my $sbit = $nbits-1;
  74.                 # Find the position of the last 1 bit
  75.                 $sbit-- while !vec($start, $sbit^7, 1) and $sbit>0;
  76.                 for my $pos ($sbit+1..$nbits) {
  77.                     $end = $self->_add_bit($start, $pos);
  78.                     $bits = $pos-8, last if $end le $ip;
  79.                 }
  80.                 push @results, $self->{UNPACK}->($start) . "/$bits";
  81.                 $start = $end;
  82.             }
  83.         }
  84.     }
  85.     wantarray ? @results : \@results;
  86. }
  87.  
  88. sub list_range {
  89.     my $self = shift;
  90.     my ($start, $total);
  91.     my @results;
  92.     for my $ip (sort keys %{$$self{RANGES}}) {
  93.         $start = $ip unless $total;
  94.         $total += $$self{RANGES}{$ip};
  95.         unless ($total) {
  96.             $ip = $self->_minus_one($ip);
  97.             push @results,
  98.                 $self->{UNPACK}->($start) . "-" . $self->{UNPACK}->($ip);
  99.         }
  100.     }
  101.     wantarray ? @results : \@results;
  102. }
  103.  
  104. sub _init {
  105.     my $self = shift;
  106.     my $ip = shift;
  107.     my ($nbits, $pack, $unpack);
  108.     if (_pack_ipv4($ip)) {
  109.         $nbits = 40;
  110.         $pack = \&_pack_ipv4;
  111.         $unpack = \&_unpack_ipv4;
  112.     } elsif (_pack_ipv6($ip)) {
  113.         $nbits = 136;
  114.         $pack = \&_pack_ipv6;
  115.         $unpack = \&_unpack_ipv6;
  116.     } else {
  117.         return;
  118.     }
  119.     $$self{PACK}  = $pack;
  120.     $$self{UNPACK}  = $unpack;
  121.     $$self{NBITS} = $nbits;
  122.     $$self{MASKS} = $masks{$nbits} ||= [
  123.       map { pack("B*", substr("1" x $_ . "0" x $nbits, 0, $nbits))
  124.           } 0..$nbits
  125.     ];
  126.     $$self{RANGES} = {};
  127.     $self;
  128. }
  129.  
  130. sub _pack_ipv4 {
  131.     my @nums = split /\./, shift(), -1;
  132.     return unless @nums == 4;
  133.     for (@nums) {
  134.         return unless /^\d{1,3}$/ and $_ <= 255;
  135.     }
  136.     pack("CC*", 0, @nums);
  137. }
  138.  
  139. sub _unpack_ipv4 {
  140.     join(".", unpack("xC*", shift));
  141. }
  142.  
  143. sub _pack_ipv6 {
  144.     my $ip = shift;
  145.     return if $ip =~ /^:/ and $ip !~ s/^::/:/;
  146.     return if $ip =~ /:$/ and $ip !~ s/::$/:/;
  147.     my @nums = split /:/, $ip, -1;
  148.     return unless @nums <= 8;
  149.     my ($empty, $ipv4, $str) = (0,'','');
  150.     for (@nums) {
  151.         return if $ipv4;
  152.         $str .= "0" x (4-length) . $_, next if /^[a-fA-F\d]{1,4}$/;
  153.         do { return if $empty++ }, $str .= "X", next if $_ eq '';
  154.         next if $ipv4 = _pack_ipv4($_);
  155.         return;
  156.     }
  157.     return if $ipv4 and @nums > 6;
  158.     $str =~ s/X/"0" x (($ipv4 ? 25 : 33)-length($str))/e if $empty;
  159.     pack("H*", "00" . $str).$ipv4;
  160. }
  161.  
  162. sub _unpack_ipv6 {
  163.     _compress_ipv6(join(":", unpack("xH*", shift) =~ /..../g)),
  164. }
  165.  
  166. # Replace longest run of null blocks with a double colon
  167. sub _compress_ipv6 {
  168.     my $ip = shift;
  169.     if (my @runs = $ip =~ /((?:(?:^|:)(?:0000))+:?)/g ) {
  170.         my $max = $runs[0];
  171.         for (@runs[1..$#runs]) {
  172.             $max = $_ if length($max) < length;
  173.         }
  174.         $ip =~ s/$max/::/;
  175.     }
  176.     $ip =~ s/:0{1,3}/:/g;
  177.     $ip;
  178. }
  179.  
  180. # Add a single IP address
  181. sub add_ip {
  182.     my $self = shift;
  183.     my $ip = shift;
  184.     $self->_init($ip) || confess "Can't determine ip format" unless %$self;
  185.     my $start = $self->{PACK}->($ip) or confess "Bad ip address: $ip";
  186.     my $end = $self->_add_bit($start, $self->{NBITS});
  187.     ++$$self{RANGES}{$start} || delete $$self{RANGES}{$start};
  188.     --$$self{RANGES}{$end}   || delete $$self{RANGES}{$end};
  189.     $self;
  190. }
  191.  
  192. # Add a hyphenated range of IP addresses
  193. sub add_range {
  194.     my $self = shift;
  195.     local $_ = shift;
  196.     my ($ip_start, $ip_end, $crud) = split /\s*-\s*/;
  197.     confess "Only one hyphen allowed in range" if defined $crud;
  198.     $self->_init($ip_start) || confess "Can't determine ip format"
  199.       unless %$self;
  200.     my $start = $self->{PACK}->($ip_start)
  201.       or confess "Bad ip address: $ip_start";
  202.     my $end = $self->{PACK}->($ip_end)
  203.       or confess "Bad ip address: $ip_end";
  204.     confess "Start IP is greater than end IP" if $start gt $end;
  205.     $end = $self->_add_bit($end, $$self{NBITS});
  206.     ++$$self{RANGES}{$start} || delete $$self{RANGES}{$start};
  207.     --$$self{RANGES}{$end}   || delete $$self{RANGES}{$end};
  208.     $self;
  209. }
  210.  
  211. # Add ranges from another Net::CIDR::Lite object
  212. sub add_cidr {
  213.     my $self = shift;
  214.     my $cidr = shift;
  215.     confess "Not a CIDR object" unless UNIVERSAL::isa($cidr, 'Net::CIDR::Lite');
  216.     unless (%$self) {
  217.         @$self{@fields} = @$cidr{@fields};
  218.     }
  219.     $$self{RANGES}{$_} += $$cidr{RANGES}{$_} for keys %{$$cidr{RANGES}};
  220.     $self;
  221. }
  222.  
  223. # Increment the ip address at the given bit position
  224. # bit position is in range 1 to # of bits in ip
  225. # where 1 is high order bit, # of bits is low order bit
  226. sub _add_bit {
  227.     my $self= shift;
  228.     my $base= shift();
  229.     my $bits= shift()-1;
  230.     while (vec($base, $bits^7, 1)) {
  231.         vec($base, $bits^7, 1) = 0;
  232.         $bits--;
  233.         return $base if  $bits < 0;
  234.     }
  235.     vec($base, $bits^7, 1) = 1;
  236.     return $base;
  237. }
  238.  
  239. # Subtract one from an ip address
  240. sub _minus_one {
  241.   my $self = shift;
  242.   my $nbits = $self->{NBITS};
  243.   my $ip = shift;
  244.   $ip = ~$ip;
  245.   $ip = $self->_add_bit($ip, $nbits);
  246.   $ip = $self->_add_bit($ip, $nbits);
  247.   $self->_add_bit(~$ip, $nbits);
  248. }
  249.  
  250. sub find {
  251.     my $self = shift;
  252.     $self->prep_find unless $self->{FIND};
  253.     return $self->bin_find(@_) unless @{$self->{FIND}} < $self->{PCT};
  254.     my $this_ip = $self->{PACK}->(shift);
  255.     my $ranges = $self->{RANGES};
  256.     my $last = -1;
  257.     for my $ip (@{$self->{FIND}}) {
  258.         last if $this_ip lt $ip;
  259.         $last = $ranges->{$ip};
  260.     }
  261.     $last > 0;
  262. }
  263.  
  264. sub bin_find {
  265.     my $self = shift;
  266.     my $ip = $self->{PACK}->(shift);
  267.     $self->prep_find unless $self->{FIND};
  268.     my $find = $self->{FIND};
  269.     my ($start, $end) = (0, $#$find);
  270.     return unless $ip ge $find->[$start] and $ip lt $find->[$end];
  271.     while ($end - $start > 0) {
  272.         my $mid = int(($start+$end)/2);
  273.         if ($start == $mid) {
  274.             if ($find->[$end] eq $ip) {
  275.                 $start = $end;
  276.             } else { $end = $start }
  277.         } else {
  278.             ($find->[$mid] lt $ip ? $start : $end) = $mid;
  279.         }
  280.     }
  281.     $self->{RANGES}{$find->[$start]} > 0;
  282. }
  283.  
  284. sub prep_find {
  285.     my $self = shift;
  286.     $self->clean;
  287.     $self->{PCT} = shift || 20;
  288.     my $aref = $self->{FIND} = [];
  289.     push @$aref, $_ for sort keys %{$self->{RANGES}};
  290.     $self;
  291. }
  292.  
  293. sub spanner {
  294.     Net::CIDR::Lite::Span->new(@_);
  295. }
  296.  
  297. sub ranges {
  298.     sort keys %{shift->{RANGES}};
  299. }
  300.  
  301. sub packer { shift->{PACK} }
  302. sub unpacker { shift->{UNPACK} }
  303.  
  304. package Net::CIDR::Lite::Span;
  305. use Carp qw(confess);
  306.  
  307. sub new {
  308.     my $proto = shift;
  309.     my $class = ref($proto) || $proto;
  310.     my $self = bless {RANGES=>{}}, $class;
  311.     $self->add(@_);
  312. }
  313.  
  314. sub add {
  315.     my $self = shift;
  316.     my $ranges = $self->{RANGES};
  317.     if (@_ && !$self->{PACK}) {
  318.         $self->{PACK} = $_[0]->packer;
  319.         $self->{UNPACK} = $_[0]->unpacker;
  320.     }
  321.     while (@_) {
  322.         my ($cidr, $label) = (shift, shift);
  323.         $cidr = Net::CIDR::Lite->new($cidr) unless ref($cidr);
  324.         $cidr->clean;
  325.         for my $ip ($cidr->ranges) {
  326.             push @{$ranges->{$ip}}, $label;
  327.         }
  328.     }
  329.     $self;
  330. }
  331.  
  332. sub find {
  333.     my $self = shift;
  334.     my $pack   = $self->{PACK};
  335.     my $unpack = $self->{UNPACK};
  336.     my %results;
  337.     my $in_range;
  338.     $self->prep_find unless $self->{FIND};
  339.     return {} unless @_;
  340.     return $self->bin_find(@_) if @_/@{$self->{FIND}} < $self->{PCT};
  341.     my @ips = sort map { $pack->($_) || confess "Bad IP: $_" } @_;
  342.     my $last;
  343.     for my $ip (@{$self->{FIND}}) {
  344.         if ($ips[0] lt $ip) {
  345.             $results{$unpack->(shift @ips)} = $self->_in_range($last)
  346.               while @ips and $ips[0] lt $ip;
  347.         }
  348.         last unless @ips;
  349.         $last = $ip;
  350.     }
  351.     if (@ips) {
  352.         my $no_range = $self->_in_range({});
  353.         $results{$unpack->(shift @ips)} = $no_range while @ips;
  354.     }
  355.     \%results;
  356. }
  357.  
  358. sub bin_find {
  359.     my $self = shift;
  360.     return {} unless @_;
  361.     $self->prep_find unless $self->{FIND};
  362.     my $pack   = $self->{PACK};
  363.     my $unpack = $self->{UNPACK};
  364.     my $find   = $self->{FIND};
  365.     my %results;
  366.     for my $ip ( map { $pack->($_) || confess "Bad IP: $_" } @_) {
  367.         my ($start, $end) = (0, $#$find);
  368.         $results{$unpack->($ip)} = $self->_in_range, next
  369.           unless $ip ge $find->[$start] and $ip lt $find->[$end];
  370.         while ($start < $end) {
  371.             my $mid = int(($start+$end)/2);
  372.             if ($start == $mid) {
  373.                 if ($find->[$end] eq $ip) {
  374.                     $start = $end;
  375.                 } else { $end = $start }
  376.             } else {
  377.                 ($find->[$mid] lt $ip ? $start : $end) = $mid;
  378.             }
  379.         }
  380.         $results{$unpack->($ip)} = $self->_in_range($find->[$start]);
  381.     }
  382.     \%results;
  383. }
  384.  
  385. sub _in_range {
  386.     my $self = shift;
  387.     my $ip = shift || '';
  388.     my $aref = $self->{PREPPED}{$ip} || [];
  389.     my $key = join "|", sort @$aref;
  390.     $self->{CACHE}{$key} ||= { map { $_ => 1 } @$aref };
  391. }
  392.  
  393. sub prep_find {
  394.     my $self = shift;
  395.     my $pct = shift || 4;
  396.     $self->{PCT} = $pct/100;
  397.     $self->{FIND} = [ sort keys %{$self->{RANGES}} ];
  398.     $self->{PREPPED} = {};
  399.     $self->{CACHE} = {};
  400.     my %cache;
  401.     my %in_range;
  402.     for my $ip (@{$self->{FIND}}) {
  403.         my $keys = $self->{RANGES}{$ip};
  404.         $_ = !$_ for @in_range{@$keys};
  405.         my @keys = grep $in_range{$_}, keys %in_range;
  406.         my $key_str = join "|", @keys;
  407.         $self->{PREPPED}{$ip} = $cache{$key_str} ||= \@keys;
  408.     }
  409.     $self;
  410. }
  411.  
  412. sub clean {
  413.     my $self = shift;
  414.     my $ip = $self->{PACK}->(shift) || return;
  415.     $self->{UNPACK}->($ip);
  416. }
  417.  
  418. 1;
  419. __END__
  420.  
  421. =head1 NAME
  422.  
  423. Net::CIDR::Lite - Perl extension for merging IPv4 or IPv6 CIDR addresses
  424.  
  425. =head1 SYNOPSIS
  426.  
  427.   use Net::CIDR::Lite;
  428.  
  429.   my $cidr = Net::CIDR::Lite->new;
  430.   $cidr->add($cidr_address);
  431.   @cidr_list = $cidr->list;
  432.   @ip_ranges = $cidr->list_range;
  433.  
  434. =head1 DESCRIPTION
  435.  
  436. Faster alternative to Net::CIDR when merging a large number
  437. of CIDR address ranges. Works for IPv4 and IPv6 addresses.
  438.  
  439. =head1 METHODS
  440.  
  441. =item new() 
  442.  
  443.  $cidr = Net::CIDR::Lite->new
  444.  $cidr = Net::CIDR::Lite->new(@args)
  445.  
  446. Creates an object to represent a list of CIDR address ranges.
  447. No particular format is set yet; once an add method is called
  448. with a IPv4 or IPv6 format, only that format may be added for this
  449. cidr object. Any arguments supplied are passed to add_any() (see below).
  450.  
  451. =item add()
  452.  
  453.  $cidr->add($cidr_address)
  454.  
  455. Adds a CIDR address range to the list.
  456.  
  457. =item add_range()
  458.  
  459.  $cidr->add_range($ip_range)
  460.  
  461. Adds a hyphenated IP address range to the list.
  462.  
  463. =item add_cidr()
  464.  
  465.  $cidr1->add_cidr($cidr2)
  466.  
  467. Adds address ranges from one object to another object.
  468.  
  469. =item add_ip()
  470.  
  471.  $cidr->add_ip($ip_address)
  472.  
  473. Adds a single IP address to the list.
  474.  
  475. =item add_any()
  476.  
  477.  $cidr->add_any($cidr_or_range_or_address);
  478.  
  479. Determines format of range or single ip address and calls add(),
  480. add_range(), add_cidr(), or add_ip() as appropriate.
  481.  
  482. =item $cidr->clean()
  483.  
  484.  $cidr->clean;
  485.  
  486. If you are going to call the list method more than once on the
  487. same data, then for optimal performance, you can call this to
  488. purge null nodes in overlapping ranges from the list. Boundary
  489. nodes in contiguous ranges are automatically purged during add().
  490. Only useful when ranges overlap or when contiguous ranges are added
  491. out of order.
  492.  
  493. =item $cidr->list()
  494.  
  495.  @cidr_list = $cidr->list;
  496.  $list_ref  = $cidr->list;
  497.  
  498. Returns a list of the merged CIDR addresses. Returns an array if called
  499. in list context, an array reference if not.
  500.  
  501. =item $cidr->list_range()
  502.  
  503.  @cidr_list = $cidr->list;
  504.  $list_ref  = $cidr->list;
  505.  
  506. Returns a list of the merged addresses, but in hyphenated range
  507. format. Returns an array if called in list context, an array reference
  508. if not.
  509.  
  510. =item $cidr->find()
  511.  
  512.  $found = $cidr->find($ip);
  513.  
  514. Returns true if the ip address is found in the CIDR range. False if not.
  515. Not extremely efficient, is O(n*log(n)) to sort the ranges in the
  516. cidr object O(n) to search through the ranges in the cidr object.
  517. The sort is cached on the first call and used in subsequent calls,
  518. but if more addresses are added to the cidr object, prep_find() must
  519. be called on the cidr object.
  520.  
  521. =item $cidr->prep_find()
  522.  
  523.  $cidr->prep_find($num);
  524.  
  525. Caches the result of sorting the ip addresses. Implicitly called on the first
  526. find call, but must be explicitly called if more addresses are added to
  527. the cidr object. find() will do a binary search if the number of ranges is
  528. greater than or equal to $num (default 20);
  529.  
  530. =item $cidr->spanner()
  531.  
  532.  $spanner = $cidr1->spanner($label1, $cidr2, $label2, ...);
  533.  
  534. Creates a spanner object to find out if multiple ip addresses are within
  535. multiple labeled address ranges. May also be called as (with or without
  536. any arguments):
  537.  
  538.  Net::CIDR::Lite::Span->new($cidr1, $label1, $cidr2, $label2, ...);
  539.  
  540. =item $spanner->add()
  541.  
  542.  $spanner->add($cidr1, $label1, $cidr2, $label2,...);
  543.  
  544. Adds labeled address ranges to the spanner object. The 'address range' may
  545. be a Net::CIDR::Lite object, a single CIDR address range, a single
  546. hyphenated IP address range, or a single IP address.
  547.  
  548. =item $spanner->find()
  549.  
  550.  $href = $spanner->find(@ip_addresses);
  551.  
  552. Look up which range(s) ip addresses are in, and return a lookup table
  553. of the results, with the keys being the ip addresses, and the value an
  554. hash reference of which address ranges the ip address is in.
  555.  
  556. =item $spanner->prep_find()
  557.  
  558.  $spanner->prep_find($num);
  559.  
  560. Called implicitly the first time $spanner->find(..) is called, must be called
  561. again if more cidr objects are added to the spanner object. Will do a
  562. binary search if ratio of the number of ip addresses to the number of ranges
  563. is less than $num percent (default 4).
  564.  
  565. =item $spanner->clean()
  566.  
  567.  $clean_address = $spanner->clean($ip_address);
  568.  
  569. Validates a returns a cleaned up version of an ip address (which is
  570. what you will find as the key in the result from the $spanner->find(..),
  571. not necessarily what the original argument looked like). E.g. removes
  572. unnecessary leading zeros, removes null blocks from IPv6
  573. addresses, etc.
  574.  
  575. =head1 CAVEATS
  576.  
  577. Garbage in/garbage out. This module does do validation, but maybe
  578. not enough to suit your needs.
  579.  
  580. =head1 AUTHOR
  581.  
  582. Douglas Wilson, E<lt>dougw@cpan.orgE<gt>
  583. w/numerous hints and ideas borrowed from Tye McQueen.
  584.  
  585. =head1 COPYRIGHT
  586.  
  587.  This module is free software; you can redistribute it and/or
  588.  modify it under the same terms as Perl itself.
  589.  
  590. =head1 SEE ALSO
  591.  
  592. L<Net::CIDR>.
  593.  
  594. =cut
  595.