File Coverage

blib/lib/Net/IP/Identifier.pm

Criterion	Covered	Total	%
statement	136	176	77.2
branch	48	76	63.1
condition	11	33	33.3
subroutine	22	24	91.6
pod	5	8	62.5
total	222	317	70.0

#!/usr/bin/perl
#===============================================================================
#      PODNAME:  Net::IP::Identifier
#     ABSTRACT:  Identify IPs that fall within collections of network blocks
#
#       AUTHOR:  Reid Augustin (REID)
#        EMAIL:  [e-mail]
#      CREATED:  Mon Oct  6 10:20:33 PDT 2014
#===============================================================================

use 5.002;
use strict;
use warnings;

{
    package Local::Payload;
    use Moo;

    has entity => (
        is => 'rw',
        isa => sub { die "Not a Net::IP::Identifier::Plugin\n"
                        if (not $_[0]->does('Net::IP::Identifier_Role')); },
    );
    has ip => (
        is => 'rw',
        isa => sub { die "Not a Net::IP::Identifier::Net\n"
                        if (not $_[0]->isa('Net::IP::Identifier::Net')); },
    );
}


package Net::IP::Identifier;
use Getopt::Long qw(:config pass_through);
use File::Spec;
use Net::IP::Identifier::Net;
use Net::IP::Identifier::Binode;
use Net::IP::Identifier::Regex;
use Carp;
use Moo;
use namespace::clean;
use Module::Pluggable;

our $VERSION = '0.111'; # VERSION

has joiners => (
    is => 'rw',
    default => sub { [ ':', '.' ] },
);
has cidr => (
    is => 'rw',
);
has parents => (
    is => 'rw',
);
has overlaps => (
    is => 'rw',
);
has re => ( # regular expressions for IP addresses
    is => 'lazy',
    default => sub { Net::IP::Identifier::Regex->new },
);

my $imports;

my (undef, undef, $myName) = File::Spec->splitpath($0);

my $help_msg = <

$myName [ options ] IP [ IP... ]

If IP belongs to a known entity (a Net::IP::Identifier::Plugin),
print the entity.

IP may be dotted decimal format: N.N.N.N, range format: N.N.N.N - N.N.N.N,
CIDR format: N.N.N.N/W, or a filename from which IPs will be extracted.  If
no IP or filename is found on the command line, STDIN is opened.

Options (may be abbreviated):
    parents   => prepend Net::IP::Identifier objects of parent entities
    cidr      => append Net::IP::Identifier::Net objects to entities
    filename  => read from file(s) instead of command line args
    overlaps  => show overlapping netblocks during binary tree construction
    help      => this message

EO_HELP
;

__PACKAGE__->run unless caller;     # modulino

sub run {
    my ($class) = @_;

    my %opts;
    my $overlaps;
    my $filename;
    my $help;

    exit 0 if (not
        GetOptions(
            'parents'    => \$opts{parents},
            'cidr'       => \$opts{cidr},
            'overlaps'   => \$overlaps,
            'filename=s' => \$filename,
            'help'       => \$help,
        )
    );

    if ($help) {
        print $help_msg;
        exit;
    }

    my $identifier = __PACKAGE__->new(%opts);

    unshift @ARGV, $filename if ($filename);
    if (not @ARGV) {
        $identifier->parse_fh(\*STDIN);
    }

    while (@ARGV) {
        my $arg = shift @ARGV;
        if (-f $arg) {
            open my $fh, '<', $arg;
            croak "Can't open $arg for reading\n" if not $fh;
            $identifier->parse_fh($fh);
            close $fh;
            next
        }
        elsif ($ARGV[0]        and  # accept N.N.N.N - N.N.N.N for network blocks too
               $ARGV[0] eq '-' and
               $ARGV[1]) {
            $arg .= shift(@ARGV) . shift(@ARGV);
        }

        print $identifier->identify($arg) || $arg, "\n";
    }

    if ($overlaps) {
        for my $return (@{$identifier->tree_overlaps}) {
            my @r = map { $identifier->join($_->payload->entity, $_->payload->ip); } @{$return};
            warn join(' => ', @r), "\n";
        }
    }
}

sub import {
    my ($class, @imports) = @_;

    $imports = \@imports if (@imports);   # save import list in class variable
}

sub parse_fh {
    my ($self, $fh) = @_;

    my $ip_any = $self->re->IP_any;
    while(<$fh>) {
        my (@ips) = m/($ip_any)/;
        for my $ip (@ips) {
            print $self->identify($ip) || $ip, "\n";
        }
    }
}

sub load_entities {
    my ($self, @plugins) = @_;

    my $plugins = ref $plugins[0] eq 'ARRAY'    # accept array or ref
        ? $plugins[0]       # a ref was passed in
        : \@plugins;        # convert array to ref
    delete $self->{parent_of};
    delete $self->{entities};
    for my $plugin (@{$plugins}) {
#print "requiring $plugin\n";
        if (not $plugin =~ m/::/) {
            $plugin = __PACKAGE__ . "::Plugin::$plugin";
        }
        eval "CORE::require $plugin";   ## no critic # attempt to read in the plugin
        warn $@ if $@;
        my $p = $plugin && $plugin->new;
        next if not $p;
        if (not $p->does('Net::IP::Identifier_Role')) {
            print "$plugin doesn't satisfy the Net::IP::Identifier_Role - skipping\n";
            next;
        }
        push @{$self->{entities}}, $p;
        for my $child ($p->children) {
            $self->{parent_of}{$child} = $p;
        }
    }
    if (     @$plugins and
        (not   $self->{entities} or
            not @{$self->{entities}})) {
        croak "No plugins installed\n";
    }
    delete $self->{ip_tree};
}

sub entities {
    my ($self, @plugins) = @_;

    if (@_ > 1) {
        undef $imports;         # override imports with @plugins
#print "load args: ", join(' ', @plugins), "\n";
        $self->load_entities(@plugins);
    }

    if (not   $self->{entities} or
        not @{$self->{entities}}) {
        # if no plugins yet loaded, check import list
        # no import list? load everything we can find
        if ($imports) {
#print "load imports ", join(' ', @{$imports}), "\n";
            $self->load_entities($imports);
            undef $imports;     # only the first time
        }
        else {
#print "load imports ", join(' ', $self->plugins), "\n";
            $self->load_entities([ $self->plugins ]);
        }

        if (not   $self->{entities} or
            not @{$self->{entities}}) {
            croak "No entity Plugins found\n";
        }
    }

    return wantarray
        ? @{$self->{entities}}
        : $self->{entities};
}

sub ip_tree {
    my ($self, $version) = @_;

    croak "ip_tree(\$version) error: no version\n" if not $version;

    if (not $self->{ip_tree}) {
        my $root_v6 = Net::IP::Identifier::Binode->new;
        # Place the IPv4 block in the IPv6 tree (IPv4 mapped IPv6)
        my $root_v4 = $root_v6->construct(Net::IP::Identifier::Net->new('::ffff:0:0/96')->masked_ip);

        for my $entity ($self->entities) {
            for my $ip ($entity->ips) {
                my @ips = ($ip);
                if (not defined $ip->prefixlen) {
                    @ips = $ip->range_to_cidrs;
                }
                for my $ip (@ips) {
                    my $root = ($ip->version == 6) ? $root_v6 : $root_v4;
                    $root->construct($ip->masked_ip)->payload(
                        Local::Payload->new(
                            entity => $entity,
                            ip => $ip,
                        ),
                    );
                }
            }
        }
        $self->{ip_tree}{6} = $root_v6;
        $self->{ip_tree}{4} = $root_v4;
    }
    return $self->{ip_tree}{$version};
}

sub identify {
    my ($self, $ip) = @_;

    $ip = Net::IP::Identifier::Net->new($ip);
    my @ips = ($ip);
    if (not defined $ip->prefixlen) {
        @ips = $ip->range_to_cidrs;
    }

    my @return;
    for my $ip (@ips) {
        $self->ip_tree($ip->version)->follow($ip->masked_ip, sub {
                push @return, $_[0] if ($_[0]->payload);
                return 0;  # always continue
            },
        );
    }
    if (not @return) {
        return; # not found.
    }

    if (not $self->parents) {
        @return = ($return[-1]);    # just the last child
    }

    @return = map { $_->payload } @return;   # remove the Binode layer

    if (wantarray) {
        return $self->cidr
        ? map { $_->entity, $_->ip } @return
        : @return;
    }

    if ($self->cidr) {
        my @e = map { $self->join($_->entity, $_->ip) } @return;
        return join ' => ', @e;
    }
    my $r = join (' => ', map {
        $_->entity->name
        } @return);
    return $r;
}

sub join {
    my ($self, @parts) = @_;

    my $joiners = $self->joiners;
    my $joiner = $joiners->[0];   # assume IPv4
    if (grep { $_->can('version') and $_->version eq '6' } @parts) {
        $joiner = $joiners->[1];  # use the IPv6 string
    }
    $joiner = ':' if (not defined $joiner);    # if all else fails...
    return join $joiner, @parts;
}

sub tree_overlaps {
    my ($self) = @_;

    my @overlaps;   # collect overlaps here.  each overlap is an array
                    # starting with the parent, followed by children.

    $self->ip_tree(6)->traverse_width_first(
        sub {
            my ($node, $level) = @_;

            my @overlap;    # a single overlap array, parent then children
            if ($node->payload and
                ($node->zero or $node->one)) {
                $node->traverse_width_first(
                    sub {
                        if ($_[0]->payload) {
                            push @overlap, $_[0];
                        }
                        return 0;   # always continue
                    }
                );
            }
            push @overlaps, \@overlap if (@overlap > 1);
            return @overlap > 1;    # stop if we found overlap
        },
    );

    return wantarray
    ? @overlaps
    : \@overlaps;
}

1;

__END__