view release on metacpan or  search on metacpan

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

    create_iprange_regexp({'127.0.0.1/32' => 1,
                           '209.249.163.0/25' => 'clotho.com',
                           '10.0.0.0/8' => 1,
                           '192.168.0.0/16' => 'LAN'});

If any of the IP ranges are overlapping, the broadest one is used.  If
they are equivalent, then the first one passed is used.  If you have
some data that might be ambiguous, you pass an arrayref instead of a
hashref, but it's better to clean up your data instead!  For example:

    my $re = create_iprange_regexp(['1.1.1.0/31' => 'zero', '1.1.1.1/31' => 'one']);
    print match_ip('1.1.1.1', $re));   # prints 'zero', since both match

WARNING: This function does no checking for validity of IP ranges.  It
happily accepts C<1000.0.0.0/-38> and makes a garbage regexp.
Hopefully a future version will validate the ranges, perhaps via
Net::CIDR or Net::IP.

=cut

sub create_iprange_regexp {   ##no critic (ArgUnpacking)
   return _build_regexp(0, \@_);
}

=item create_iprange_regexp_depthfirst($iprange | $hashref | $arrayref, ...)

Returns a regexp in matches the most specific IP range instead of the
broadest range.  Example:

    my $re = create_iprange_regexp_depthfirst({'192.168.0.0/16' => 'LAN',
                                               '192.168.0.1' => 'router'});
    match_ip('192.168.0.1', $re);

returns 'router' instead of 'LAN'.

=cut

sub create_iprange_regexp_depthfirst {   ##no critic (ArgUnpacking)
   return _build_regexp(1, \@_);
}
sub _build_regexp {
   my ($depthfirst, $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' ? @{$_}
               :                       %{$_}         } @{$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.
   my %tree;

IPRANGE:
   for ( my $i = 0; $i < @map; $i += 2 ) {
      my $range = $map[ $i ];
      my $match = $map[ $i + 1 ];

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

      my $tree = \%tree;
      my @bits = split m//xms, unpack 'B32', pack 'C4', split m/[.]/xms, $ip;

      for my $bit ( @bits[ 0 .. $mask - 1 ] ) {

         # If this case is hit, it means that our IP range is a subset
         # of some other range, and thus ignorable
         next IPRANGE if !$depthfirst && $tree->{code};

         $tree->{$bit} ||= {};    # Turn a leaf into a branch, if needed
         $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->{code} ||= $match;

      # Ignore case where $tree->{0} or $tree->{1} are set (i.e. if
      # the current range encompasses any earlier-processed ranges).
      # Those branches will be ignored in _tree2re()
   }

   # Recurse into the tree making it into a regexp
   my $re = join q{}, '^4', $depthfirst ? _tree2re_depthfirst( \%tree ) : _tree2re( \%tree );

   ## Performance optimization:

   # If we are going to use the pattern repeatedly, it's more
   # effiecient if it's already a regexp instead of a string.
   # Otherwise, it needs to be compiled in each invocation of
   # match_ip().  If the regexp is merely stored and not used then
   # this is wasted effort.

   use re 'eval';    # needed because we're interpolating into a regexp
   $re = qr/$re/xms;

   return $re;
}

=item match_ip($ipaddr, $regexp)

Given a single IP address as a string of the form C<aaa.bbb.ccc.ddd>
and a regular expression string (typically the output of
create_iprange_regexp()), this function returns a specified value
(typically C<1>) if the IP is in one of the ranges, or C<undef> if no
ranges match.

See create_ipranges_regexp() for more details about the return value
of this function.

WARNING: This function does no checking for validity of the IP address.

=cut

sub match_ip {
   my ( $ip, $re ) = @_;

   return if !$ip;
   return if !$re;

   local $LAST_REGEXP_CODE_RESULT = undef;
   use re 'eval';
   ( '4' . unpack 'B32', pack 'C4', split m/[.]/xms, $ip ) =~ m/$re/xms;
   return $LAST_REGEXP_CODE_RESULT;
}

# Helper function.  This recurses to build the regular expression
# string from a tree of IP ranges constructed by
# create_iprange_regexp().

sub _tree2re {
   my ( $tree ) = @_;

   return
       defined $tree->{code}       ? ( "(?{'$tree->{code}'})"            )  # Match
       : $tree->{0} && $tree->{1}  ? ( '(?>0', _tree2re($tree->{0}),
                                         '|1', _tree2re($tree->{1}), ')' )  # Choice
       : $tree->{0}                ? (    '0', _tree2re($tree->{0})      )  # Literal, no choice
       : $tree->{1}                ? (    '1', _tree2re($tree->{1})      )  # Literal, no choice
       : die 'Internal error: failed to create a regexp from the supplied IP ranges'
       ;
}

sub _tree2re_depthfirst {
   my ( $tree ) = @_;

   if (defined $tree->{code}) {
      return '(?>',
         $tree->{0} && $tree->{1}  ? ( '(?>0', _tree2re_depthfirst($tree->{0}),
                                         '|1', _tree2re_depthfirst($tree->{1}), ')|' )
       : $tree->{0}                ? (    '0', _tree2re_depthfirst($tree->{0}), q{|} )
       : $tree->{1}                ? (    '1', _tree2re_depthfirst($tree->{1}), q{|} )
       : (),
       "(?{'$tree->{code}'}))";
   } else {
      return
         $tree->{0} && $tree->{1}  ? ( '(?>0', _tree2re_depthfirst($tree->{0}),
                                         '|1', _tree2re_depthfirst($tree->{1}), ')' )  # Choice
       : $tree->{0}                ? (    '0', _tree2re_depthfirst($tree->{0})      )  # Literal, no choice
       : $tree->{1}                ? (    '1', _tree2re_depthfirst($tree->{1})      )  # Literal, no choice
       : die 'Internal error: failed to create a regexp from the supplied IP ranges'
       ;
   }
}

1;

__END__

=back

=head1 SEE ALSO

There are several other CPAN modules that perform a similar function.
This one is comparable to or faster than the other ones that I've
found and tried.  Here is a synopsis of those others:

=head2 L<Net::IP::Match>

Optimized for speed by taking a "source filter" approach.  That is, it
modifies your source code at run time, kind of like a C preprocessor.
A huge limitation is that the IP ranges must be hard-coded into your
program.