view release on metacpan or  search on metacpan

lib/Net/IP/Match/Bin/Perl.pm  view on Meta::CPAN

package Net::IP::Match::Bin::Perl;

require Exporter;

use vars qw (@ISA @EXPORT $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw( match_ip );

$VERSION = '0.01';

our @BITS = (
    0x80000000, 0x40000000, 0x20000000, 0x10000000, 0x08000000, 0x04000000,
    0x02000000, 0x01000000, 0x00800000, 0x00400000, 0x00200000, 0x00100000,
    0x00080000, 0x00040000, 0x00020000, 0x00010000, 0x00008000, 0x00004000,
    0x00002000, 0x00001000, 0x00000800, 0x00000400, 0x00000200, 0x00000100,
    0x00000080, 0x00000040, 0x00000020, 0x00000010, 0x00000008, 0x00000004,
    0x00000002, 0x00000001,
    );

sub new {
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = {};
    bless $self => $class;

    my $tree = [];
    $self->{Tree} = $tree;
    return $self;
}

sub add {
    my $self = shift;
    my @ipranges = @_;

   # If an argument is a hash or array ref, flatten it
   # If an argument is a scalar, make it a key and give it a value of 1
   my @map
       = map {   ! ref $_            ? ( $_ => -1 )
               :   ref $_ eq 'ARRAY' ? map { $_ => -1 } @{$_}
               :                       %{$_}         } @ipranges;

   # The tree is a temporary construct.  It has three possible
   # properties: 0, 1, and code.  The code is the return value for a
   # match.

   for ( my $i = 0; $i < @map; $i += 2 ) {
      my $range = $map[ $i ];
      my $match = $map[ $i + 1 ];
      if ($match eq "-1") {
	  $match = "$range";
      }

      my ( $ip, $mask ) = split m/\//xms, $range;
      if (! defined $mask) {
         $mask = 32;          ## no critic(MagicNumbers)
      }

      my $tree = $self->{Tree}; # root

      my $addr = unpack 'N', pack 'C4', split /[.]/, $ip;
      for (my $i = 0; $i < $mask; $i++) {
	  my $bit = $addr & $BITS[$i] ? 1 : 0;
	  unless (defined $tree->[$bit]) {
	      $tree->[$bit] ||= [];
	  }
	  $tree = $tree->[$bit];   # Follow one branch
      }

      # Our $tree is now a leaf node of @$tree.  Set its value
      # If the code is already set, it's a non-fatal error (redundant data)
      $tree->[2] ||= $match;
   }
   return $self;
}

sub match_ip {
    my $self = shift;
    my $ip;

    if (! ref $self) {
	$ip = $self;
	$self = Net::IP::Match::Bin::Perl->new();
    } else {
	$ip = shift;