File Coverage

blib/lib/JCM/Net/Patricia.pm

Criterion	Covered	Total	%
statement	174	229	75.9
branch	64	174	36.7
condition	13	65	20.0
subroutine	37	47	78.7
pod	7	9	77.7
total	295	524	56.3

#  JCM::Net::Patricia - Patricia Trie perl module for fast IP address lookups
#  Copyright (C) 2000-2005  Dave Plonka
#  Copyright (C) 2009       Dave Plonka & Philip Prindeville
#  Parts Copyright(C) 2016  Joelle Maslak
#  Parts Copyright(C) 2021  Joelle Maslak
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
#  MA  02110-1301, USA.

# Joelle Maslak
# Dave Plonka
# Philip Prindeville
# Anton Berezin

package JCM::Net::Patricia;

use strict;
use warnings;

require 5.008;

use version;
use Carp;
use vars qw($VERSION @ISA @EXPORT);
use Socket qw(AF_INET AF_INET6);

BEGIN {
  require Exporter;
  require DynaLoader;
  @ISA = qw(Exporter DynaLoader);
  @EXPORT = qw(AF_INET AF_INET6);
}

'$Revision: 1.05 $' =~ m/(\d+)\.(\d+)((_\d+)|)/ && ( $VERSION = "$1.$2$3");

bootstrap JCM::Net::Patricia $VERSION;

sub new {
  my ($class, $type) = @_;

  $type ||= AF_INET;

  if ($type == AF_INET) {
    return bless _new(32), 'JCM::Net::Patricia::AF_INET';
  }

  if ($type == AF_INET6) {
    if (JCM::Net::Patricia::have_ipv6()) {
      return bless _new(128), 'JCM::Net::Patricia::AF_INET6';
    } else {
      croak('IPv6 is not available on this platform');
    }
  }

  croak "new: unimplemented type";
}

##
## Compat functions
##

sub _ip_bits {
  my ($self, $str) = @_;
  my $bits;

  if (ref ($self) eq 'JCM::Net::Patricia::AF_INET6') {
	$bits = ($str =~ s|/(\d+)$||) ? $1 : 128;
  } else {
	$bits = ($str =~ s|/(\d+)$||) ? $1 : 32;
  }
  ($str,$bits);
}

sub add_string {
  croak "add_string: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self,$str,$data) = @_;
  $data = $str unless @_ > 2;
  $self->add($self->_ip_bits($str),$data);
}

sub match_string {
  croak "match_string: wrong number of args" if (@_ != 2);
  my ($self,$str) = @_;
  $self->match($self->_ip_bits($str))
}

sub matching_prefix_string {
  croak "matching_prefix_string: wrong number of args" if (@_ != 2);
  my ($self,$str) = @_;
  $self->matching_prefix($self->_ip_bits($str))
}

sub match_exact_string {
  croak "match_exact_string: wrong number of args" if (@_ != 2);
  my ($self,$str) = @_;
  $self->exact($self->_ip_bits($str))
}

sub match_exact_integer {
  shift->exact_integer(@_)
}

sub remove_string {
  croak "remove_string: wrong number of args" if (@_ != 2);
  my ($self,$str) = @_;
  $self->remove($self->_ip_bits($str))
}

BEGIN {
  eval {
    my $class = 'Net::CIDR::Lite';
    eval "require $class";
  };
  last if (@_);

  sub add_cidr {
    croak "add_cidr: wrong number of args" if (@_ != 3);
    my ($self, $range, $data) = @_;
    my $cidr = Net::CIDR::Lite->new();
    $cidr->add_range($range);

    my @list = ();
    for ($cidr->list()) {
      push(@list, $_) if ($self->add_string($_, $data));
    }
    @list;
  }

  sub remove_cidr {
    croak "remove_cidr: wrong number of args" if (@_ != 2);
    my ($self, $range) = @_;
    my $cidr = Net::CIDR::Lite->new();
    $cidr->add_range($range);

    my @list = ();
    for ($cidr->list()) {
      push(@list, $_) if ($self->remove_string($_));
    }
    @list;
  }
}

##
## AF_INET
##

package JCM::Net::Patricia::AF_INET;

use Carp;
use Socket qw(AF_INET inet_aton inet_ntoa);
use vars qw(@ISA @EXPORT);

BEGIN {
  require Exporter;
  require DynaLoader;
  @ISA = qw(Exporter DynaLoader JCM::Net::Patricia);
  @EXPORT = qw(AF_INET);
}

sub add {
  croak "add: wrong number of args" if (@_ < 2 || @_ > 4);
  my ($self, $ip, $bits, $data) = @_;
  croak("invalid key") if ( scalar(split( /[\/.]/, $ip )) != 4);
  croak("invalid key") if ( grep { /^0[0-9]/ } split( /[\/.]/, $ip ) );
  $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 4);
  my $packed = inet_aton($ip);
  croak("invalid key") unless (defined $packed);
  $bits = 32 if (@_ < 3);
  $self->SUPER::_add(AF_INET, $packed, $bits, $data);
}

sub add_integer {
  croak "add_integer: wrong number of args" if (@_ < 2 || @_ > 4);
  my ($self, $num, $bits, $data) = @_;
  my $packed = pack("N", $num);
  my $ip = inet_ntoa($packed);
  croak("invalid address") unless (defined $ip);
  $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 4);
  $bits = 32 if (@_ < 3);
  $self->SUPER::_add(AF_INET, $packed, $bits, $data);
}

sub match_integer {
  croak "match_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 32 if (@_ < 3);
  $self->SUPER::_match(AF_INET, pack("N",$num), $bits);
}

sub matching_prefix_integer {
  croak "matching_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 32 if (@_ < 3);
  $self->SUPER::_matching_prefix(AF_INET, pack("N",$num), $bits);
}

sub exact_integer {
  croak "exact_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 32 if (@_ < 3);
  $self->SUPER::_exact(AF_INET, pack("N",$num), $bits);
}

sub match {
  croak "match: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  croak("invalid key") if ( scalar(split( /[\/.]/, $ip )) != 4);
  croak("invalid key") if ( grep { /^0[0-9]/ } split( /[\/.]/, $ip ) );
  my $packed = inet_aton($ip);
  croak("invalid key") unless (defined $packed);
  $bits = 32 if (@_ < 3);
  $self->SUPER::_match(AF_INET, $packed, $bits);
}

sub matching_prefix {
  croak "matching_prefix: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  croak("invalid key") if ( scalar(split( /[\/.]/, $ip )) != 4);
  croak("invalid key") if ( grep { /^0[0-9]/ } split( /[\/.]/, $ip ) );
  my $packed = inet_aton($ip);
  croak("invalid key") unless (defined $packed);
  $bits = 32 if (@_ < 3);
  $self->SUPER::_matching_prefix(AF_INET, $packed, $bits);
}

sub exact {
  croak "exact: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  croak("invalid key") if ( scalar(split( /[\/.]/, $ip )) != 4);
  croak("invalid key") if ( grep { /^0[0-9]/ } split( /[\/.]/, $ip ) );
  my $packed = inet_aton($ip);
  croak("invalid key") unless (defined $packed);
  $bits = 32 if (@_ < 3);
  $self->SUPER::_exact(AF_INET, $packed, $bits);
}

sub remove {
  croak "remove: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  croak("invalid key") if ( scalar(split( /[\/.]/, $ip )) != 4);
  croak("invalid key") if ( grep { /^0[0-9]/ } split( /[\/.]/, $ip ) );
  my $packed = inet_aton($ip);
  croak("invalid key") unless (defined $packed);
  $bits = 32 if (@_ < 3);
  $self->SUPER::_remove(AF_INET, $packed, $bits);
}

sub remove_integer {
  croak "remote_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 32 if (@_ < 3);
  $self->SUPER::_remove(AF_INET, pack("N",$num), $bits);
}

##
## AF_INET6
##

package JCM::Net::Patricia::AF_INET6;

use Carp;
use Socket qw(AF_INET6);
use Socket6 qw(inet_pton inet_ntop);
use vars qw(@ISA @EXPORT);

BEGIN {
  require Exporter;
  require DynaLoader;
  @ISA = qw(Exporter DynaLoader JCM::Net::Patricia);
  @EXPORT = qw(AF_INET6);
}

sub add {
  croak "add: wrong number of args" if (@_ < 2 || @_ > 4);
  my ($self, $ip, $bits, $data) = @_;
  $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 3);
  my $packed = inet_pton(AF_INET6, $ip);
  croak("invalid key") unless (defined $packed);
  $bits = 128 if (@_ < 4);
  $self->SUPER::_add(AF_INET6, $packed, $bits, $data);
}

sub add_integer {
  croak "add_integer: wrong number of args" if (@_ < 2 || @_ > 4);
  my ($self, $num, $bits, $data) = @_;
  my $packed = pack("N", $num);
  my $ip = inet_ntop(AF_INET6, $packed);
  croak("invalid address") unless (defined $ip);
  $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 3);
  $bits = 128 if (@_ < 4);
  $self->SUPER::_add(AF_INET6, $packed, $bits, $data);
}

sub match_integer {
  croak "match_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 128 if (@_ < 3);
  $self->SUPER::_match(AF_INET6, pack("N",$num), $bits);
}

sub matching_prefix_integer {
  croak "matching_prefix_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 128 if (@_ < 3);
  $self->SUPER::_matching_prefix(AF_INET6, pack("N",$num), $bits);
}

sub exact_integer {
  croak "exact_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 128 if (@_ < 3);
  $self->SUPER::_exact(AF_INET6, pack("N",$num), $bits);
}

sub match {
  croak "match: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  my $packed = inet_pton(AF_INET6, $ip);
  croak("invalid key") unless (defined $packed);
  $bits = 128 if (@_ < 3);
  $self->SUPER::_match(AF_INET6, $packed, $bits);
}

sub matching_prefix {
  croak "matching_prefix: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  my $packed = inet_pton(AF_INET6, $ip);
  croak("invalid key") unless (defined $packed);
  $bits = 128 if (@_ < 3);
  $self->SUPER::_matching_prefix(AF_INET6, $packed, $bits);
}

sub exact {
  croak "exact: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  my $packed = inet_pton(AF_INET6, $ip);
  croak("invalid key") unless (defined $packed);
  $bits = 128 if (@_ < 3);
  $self->SUPER::_exact(AF_INET6, $packed, $bits);
}

sub remove {
  croak "remove: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $ip, $bits) = @_;
  my $packed = inet_pton(AF_INET6, $ip);
  croak("invalid key") unless (defined $packed);
  $bits = 128 if (@_ < 3);
  $self->SUPER::_remove(AF_INET6, $packed, $bits);
}

sub remove_integer {
  croak "remote_integer: wrong number of args" if (@_ < 2 || @_ > 3);
  my ($self, $num, $bits) = @_;
  $bits = 128 if (@_ < 3);
  $self->SUPER::_remove(AF_INET6, pack("N",$num), $bits);
}

1;
__END__