File Coverage

blib/lib/Net/Works/Network.pm

Criterion	Covered	Total	%
statement	169	172	98.2
branch	46	52	88.4
condition	23	30	76.6
subroutine	36	38	94.7
pod	11	14	78.5
total	285	306	93.1

package Net::Works::Network;

use strict;
use warnings;

our $VERSION = '0.22';

use Carp qw( confess );
use List::AllUtils qw( any );
use Math::Int128 qw( uint128 );
use Net::Works::Address;
use Net::Works::Types qw( IPInt PrefixLength NetWorksAddress Str );
use Net::Works::Util
    qw( _integer_address_to_string _string_address_to_integer );
use Scalar::Util qw( blessed );
use Socket 1.99 qw( inet_pton AF_INET AF_INET6 );

use integer;

# Using this currently breaks overloading - see
# https://rt.cpan.org/Ticket/Display.html?id=50938
#
#use namespace::autoclean;

use overload (
    q{""} => '_overloaded_as_string',
    '<=>' => '_compare_overload',
    'cmp' => '_compare_overload',
);

use Moo;

with 'Net::Works::Role::IP';

has first => (
    is       => 'ro',
    isa      => NetWorksAddress,
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_first',
);

has last => (
    is       => 'ro',
    isa      => NetWorksAddress,
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_last',
);

has prefix_length => (
    is       => 'ro',
    isa      => PrefixLength,
    required => 1,
);

has _address_string => (
    is       => 'ro',
    isa      => Str,
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_address_string',
);

has _subnet_integer => (
    is       => 'ro',
    isa      => IPInt,
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_subnet_integer',
);

around BUILDARGS => sub {
    my $orig  = shift;
    my $class = shift;

    my $p = $class->$orig(@_);
    $p->{prefix_length} = delete $p->{mask_length}
        if exists $p->{mask_length};

    return $p;
};

sub mask_length { $_[0]->prefix_length() }

sub BUILD {
    my $self = shift;

    $self->_validate_ip_integer();

    my $max = $self->bits();
    if ( $self->prefix_length() > $max ) {
        confess $self->prefix_length()
            . ' is not a valid IP network prefix length';
    }

    return;
}

sub new_from_string {
    my $class = shift;
    my %p     = @_;

    die 'undef is not a valid IP network' unless defined $p{string};

    my ( $address, $prefix_length ) = split /\//, $p{string}, 2;

    my $version
        = $p{version} ? $p{version}
        : inet_pton( AF_INET6, $address ) ? 6
        :                                   4;

    if ( $version == 6 && inet_pton( AF_INET, $address ) ) {
        $prefix_length += 96;
        $address = '::' . $address;
    }

    my $integer = _string_address_to_integer( $address, $version );

    confess "$p{string} is not a valid IP network"
        unless defined $integer;

    return $class->new(
        _integer      => $integer,
        prefix_length => $prefix_length,
        version       => $version,
    );
}

sub new_from_integer {
    my $class = shift;
    my %p     = @_;

    my $integer = delete $p{integer};
    my $version = delete $p{version};

    $version ||= ref $integer ? 6 : 4;

    return $class->new(
        _integer => $integer,
        version  => $version,
        %p,
    );
}

sub _build_address_string {
    _integer_address_to_string( $_[0]->first_as_integer );
}

sub _build_subnet_integer {
    my $self = shift;

    return $self->_prefix_length_to_mask( $self->prefix_length() );
}

sub _prefix_length_to_mask {
    my $self          = shift;
    my $prefix_length = shift;

    # We need to special case 0 because left shifting a 128-bit integer by 128
    # bits does not produce 0.
    return $self->prefix_length() == 0
        ? 0
        : $self->_max()
        & ( $self->_max() << ( $self->bits - $prefix_length ) );
}

sub max_prefix_length {
    my $self = shift;

    my $base = $self->first()->as_integer();

    my $prefix_length = $self->prefix_length();

    my $bits = $self->bits;
    while ($prefix_length) {
        my $mask = $self->_prefix_length_to_mask($prefix_length);

        last if ( $base & $mask ) != $base;

        $prefix_length--;
    }

    return $prefix_length + 1;
}

sub max_mask_length { $_[0]->max_prefix_length() }

sub iterator {
    my $self = shift;

    my $version    = $self->version();
    my $current_ip = $self->first()->as_integer();
    my $last_ip    = $self->last()->as_integer();

    return sub {
        return if $current_ip > $last_ip;

        Net::Works::Address->new_from_integer(
            integer => $current_ip++,
            version => $version,
        );
    };
}

sub as_string {
    my $self = shift;

    return join '/', lc $self->_address_string(), $self->prefix_length();
}

sub _build_first {
    my $self = shift;

    my $int = $self->first_as_integer;

    return Net::Works::Address->new_from_integer(
        integer => $int,
        version => $self->version(),
    );
}

sub first_as_integer { $_[0]->_integer() & $_[0]->_subnet_integer() }

sub _build_last {
    my $self = shift;

    my $int = $self->last_as_integer;

    return Net::Works::Address->new_from_integer(
        integer => $int,
        version => $self->version(),
    );
}

sub last_as_integer {
    my $self = shift;

    return $self->_integer() | ( $self->_max() & ~$self->_subnet_integer() );
}

sub contains {
    my $self  = shift;
    my $thing = shift;

    my $first_integer;
    my $last_integer;
    if ( $thing->isa('Net::Works::Address') ) {
        $first_integer = $last_integer = $thing->as_integer();
    }
    elsif ( $thing->isa('Net::Works::Network') ) {
        $first_integer = $thing->first_as_integer();
        $last_integer  = $thing->last_as_integer();
    }
    else {
        confess
            "$thing is not a Net::Works::Address or Net::Works::Network object";
    }

    return $first_integer >= $self->first_as_integer()
        && $last_integer <= $self->last_as_integer();
}

## no critic (Subroutines::ProhibitBuiltinHomonyms)
sub split {
    my $self = shift;

    return () if $self->prefix_length() == $self->bits();

    my $first_int = $self->first_as_integer();
    my $last_int  = $self->last_as_integer();

    return (
        Net::Works::Network->new_from_integer(
            integer       => $first_int,
            prefix_length => $self->prefix_length() + 1,
        ),
        Net::Works::Network->new_from_integer(
            integer => ( $first_int + ( ( $last_int - $first_int ) / 2 ) )
                + 1,
            prefix_length => $self->prefix_length() + 1,
        )
    );
}
## use critic

sub is_single_address {
    my $self = shift;

    return ( $self->version == 4 && $self->prefix_length == 32 )
        || ( $self->version == 6 && $self->prefix_length == 128 );
}

sub range_as_subnets {
    my $class    = shift;
    my $first_ip = shift;
    my $last_ip  = shift;
    my $version  = shift || ( any { /:/ } $first_ip, $last_ip ) ? 6 : 4;

    $first_ip = Net::Works::Address->new_from_string(
        string  => $first_ip,
        version => $version,
    ) unless ref $first_ip;

    $last_ip = Net::Works::Address->new_from_string(
        string  => $last_ip,
        version => $version,
    ) unless ref $last_ip;

    my @ranges = $class->_remove_reserved_subnets_from_range(
        $first_ip->as_integer(),
        $last_ip->as_integer(),
        $version
    );

    my @subnets;
    for my $range (@ranges) {
        push @subnets, $class->_split_one_range( @{$range}, $version );
    }

    return @subnets;
}

{
    my @reserved_4 = qw(
        0.0.0.0/8
        10.0.0.0/8
        100.64.0.0/10
        127.0.0.0/8
        169.254.0.0/16
        172.16.0.0/12
        192.0.0.0/29
        192.0.2.0/24
        192.88.99.0/24
        192.168.0.0/16
        198.18.0.0/15
        198.51.100.0/24
        203.0.113.0/24
        224.0.0.0/4
        240.0.0.0/4
    );

    # ::/128 and ::1/128 are reserved under IPv6 but these are already covered
    # under 0.0.0.0/8
    my @reserved_6 = (
        @reserved_4, qw(
            100::/64
            2001::/23
            2001:db8::/32
            fc00::/7
            fe80::/10
            ff00::/8
            )
    );

    my %reserved_networks = (
        4 => [
            map { [ $_->first()->as_integer(), $_->last()->as_integer() ] }
                sort { $a->first <=> $b->first }
                map {
                Net::Works::Network->new_from_string(
                    string  => $_,
                    version => 4
                    )
                } @reserved_4,
        ],
        6 => [
            map { [ $_->first()->as_integer(), $_->last()->as_integer() ] }
                sort { $a->first <=> $b->first }
                map {
                Net::Works::Network->new_from_string(
                    string  => $_,
                    version => 6
                    )
                } @reserved_6,
        ],
    );

    sub _remove_reserved_subnets_from_range {
        my $class    = shift;
        my $first_ip = shift;
        my $last_ip  = shift;
        my $version  = shift;

        my @ranges;
        my $add_remaining = 1;

        for my $pn ( @{ $reserved_networks{$version} } ) {
            my $reserved_first = $pn->[0];
            my $reserved_last  = $pn->[1];

            next if ( $reserved_last <= $first_ip );
            last if ( $last_ip < $reserved_first );

            push @ranges, [ $first_ip, $reserved_first - 1 ]
                if $first_ip < $reserved_first;

            if ( $last_ip <= $reserved_last ) {
                $add_remaining = 0;
                last;
            }

            $first_ip = $reserved_last + 1;
        }

        push @ranges, [ $first_ip, $last_ip ] if $add_remaining;

        return @ranges;
    }
}

sub _split_one_range {
    my $class    = shift;
    my $first_ip = shift;
    my $last_ip  = shift;
    my $version  = shift;

    my @subnets;
    while ( $first_ip <= $last_ip ) {
        my $max_network = _max_subnet( $first_ip, $last_ip, $version );

        push @subnets, $max_network;

        $first_ip = $max_network->last_as_integer + 1;
    }

    return @subnets;
}

sub _max_subnet {
    my $ip      = shift;
    my $maxip   = shift;
    my $version = shift;

    my $prefix_length = $version == 6 ? 128 : 32;

    my $v = $ip;
    my $reverse_mask = $version == 6 ? uint128(1) : 1;

    while (( $v & 1 ) == 0
        && $prefix_length > 0
        && ( $ip | $reverse_mask ) <= $maxip ) {

        $prefix_length--;
        $v = $v >> 1;

        $reverse_mask = ( $reverse_mask << 1 ) | 1;
    }

    return Net::Works::Network->new_from_integer(
        integer       => $ip,
        prefix_length => $prefix_length,
        version       => $version,
    );
}

sub _compare_overload {
    my $self  = shift;
    my $other = shift;

    confess 'Cannot compare unless both objects are '
        . __PACKAGE__
        . ' objects'
        unless blessed $self
        && blessed $other
        && eval { $self->isa(__PACKAGE__) && $other->isa(__PACKAGE__) };

    my $cmp = (
               $self->first() <=> $other->first()
            or $self->prefix_length() <=> $other->prefix_length()
    );

    return shift() ? $cmp * -1 : $cmp;
}

__PACKAGE__->meta()->make_immutable();

1;

# ABSTRACT: An object representing a single IP address (4 or 6) subnet

__END__