File Coverage

blib/lib/Net/IP/Identifier/Net.pm

Criterion	Covered	Total	%
statement	42	105	40.0
branch	8	34	23.5
condition	0	23	0.0
subroutine	11	18	61.1
pod	3	10	30.0
total	64	190	33.6

#===============================================================================
#      PODNAME:  Net::IP::Identifier::Net
#     ABSTRACT:  subclass Net::IP to add some functionality
#
#       AUTHOR:  Reid Augustin (REID)
#        EMAIL:  [e-mail]
#      CREATED:  Sun Jul 20 17:48:21 PDT 2014
#===============================================================================

use 5.002;
use strict;
use warnings;

package Net::IP::Identifier::Net;
use parent 'Net::IP';

use Math::BigInt;
use Carp;

our $VERSION = '0.106'; # VERSION

use overload (
    '""' => 'print',
);

# Accept any of:
#   Net::IP::Identifier::Net object or class
#   Net::IP                  object
sub new {
    my ($class, $net) = @_;

    croak "Must have exactly one argument to 'new'\n" if (@_ != 2);
    if (ref $net) {
        return $net if (ref $net eq __PACKAGE__); # already correct

        # it's an object, but wrong kind
        my $src_str;
        $src_str = $net->src_str if ($net->can('src_str'));
        bless $net, $class;   # rebless to this package
        # make sure we have a source string
        $net->src_str($src_str || $net->print);
        return $net;
    }
    my $self = $class->SUPER::new($net);
    bless $self, $class;    # rebless to this package
    $self->src_str($net);   # set the source string

    return $self;
}

sub src_str {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{src_str} = $new;
    }
    return $self->{src_str};
}

# print an int as a dotted decimal quad
sub int_to_ip {
    my ($self, $ip, $version) = @_;

    $version ||= $self->version || 4;
    my @parts;
    if ($version eq '6') {
        while ($ip or @parts < 8) {
            unshift @parts, $ip & 0xffff;
            $ip >>= 16;
        }
        my $addr = join(':', map { sprintf "%x", $_ } @parts);
        return Net::IP::ip_compress_address($addr, 6);
    }

    # else IPv4
    while ($ip or @parts < 4) {
        unshift @parts, $ip & 0xff;
        $ip >>= 8;
    }
    return join('.', @parts);
}

# split a range at the binary changeover point
sub split_range {
    my ($self, $idx, $low, $high) = @_;

    no warnings 'recursion';    # IPv6 requires at least 128 levels

if (0) {
 printf "idx $idx, low %s, high %s\n",
  $self->int_to_ip($low),
  $self->int_to_ip($high);
}

    if ($high <= $low) {
        return Net::IP::Identifier::Net->new($self->int_to_ip($low));
    }
    my $mask = Math::BigInt->new(2);
    $mask->bpow($idx);
    $mask--;
    while ($idx and ($high ^ $low) <= $mask) {  # find first mask where different bit is outside it
        $mask->brsft(1);
        $idx--;
    }
    $mask->blsft(1);    # undo one shift
    $mask += 1;
    $idx++;
    if (($mask & $low) ==  0 and
        ($mask & $high) == $mask) {
        $low = $self->int_to_ip($low);
        $high = $self->int_to_ip($high);
        return Net::IP::Identifier::Net->new("$low - $high");
    }

    croak sprintf "ran out of indexes: 0x%x-0x%x\n", $low, $high if($idx <= 0);

    # need to split
    my $new_split;
    do {
        $new_split = ($low & ~$mask);
        $mask >>= 1;
        $new_split += $mask + 1;
        $idx--;
    } while ($new_split > $high and $idx >= 0);

    my @low = $self->split_range($idx, $low, $new_split - 1);
    my @high = $self->split_range($idx, $new_split, $high);

    return(@low, @high);
}

# method to convert range into cidrs
sub range_to_cidrs {
    my ($self) = @_;

    return $self if ($self->prefixlen); # don't need to split

    return $self->split_range(
        $self->masklen - 1,
        $self->intip,
        $self->last_int);
}

my $zero_v4 = '0' x 32;
my $zero_v6 = '0' x 128;
# return the XOR of the first and last IP addresses
sub differ {
    my ($self) = @_;

    # xor with zero mask also to ensure proper upper bits
    return $self->binip ^ $self->last_bin ^ ($self->version == 6 ? $zero_v6 : $zero_v4);
}

# return the inverse of the prefixlen, the length of the 1s in the mask
#   always returns a value, unlike prefixlen.  If not on an even binary
#   boundary, the masklen represents a big enough CIDR that the range fits
#   in it
sub masklen {
    my ($self) = @_;

    my $len = $self->version == 6 ? 128 : 32;
    my $differ = $self->differ;
    my $idx = index($differ, '1');
    return 0 if $idx < 0;
    return $len - $idx;
}

# return the masked portion of the IP (upper part)
sub masked_ip {
    my ($self) = @_;

    my $len = $self->version == 6 ? 128 : 32;
    return substr($self->binip, 0, $len - $self->masklen);
}

# override print: bare IP (without prefixlen) for single IPs or network
# with prefixlength if CIDR, or as range if not single and not CIDR
sub print {
    my ($self) = @_;

    return $self->ip if ($self->ip eq $self->last_ip);
    if (defined $self->prefixlen) {
        if ($self->version eq 6) {
            return $self->SUPER::print;
        }
        return $self->ip . '/' . $self->prefixlen;
    }
    return $self->ip . '-' . $self->last_ip;
}

# return ->ip, but compress if IPv6
sub compressed_ip {
    my ($self) = @_;

    return Net::IP::ip_compress_address($self->ip, $self->version);
}

1;

__END__