File Coverage

blib/lib/IP/Random.pm

Criterion	Covered	Total	%
statement	80	90	88.8
branch	9	14	64.2
condition	9	11	81.8
subroutine	15	16	93.7
pod	3	3	100.0
total	116	134	86.5

#!/usr/bin/perl

#
# Copyright (C) 2016 Joelle Maslak
# All Rights Reserved - See License
#

package IP::Random;
$IP::Random::VERSION = '1.004';
# ABSTRACT: Generate IP Addresses Randomly


# Some boilerplate
use v5.20;
use strict;
use warnings;

use feature 'signatures';
no warnings 'experimental::signatures';

use Carp;
use List::Util qw(none notall pairs);
use Socket qw(inet_aton);

my $DEFAULT_IPV4_EXCLUDE = {
    '0.0.0.0/8'          => 'rfc1122',
    '10.0.0.0/8'         => 'rfc1918',
    '100.64.0.0/10'      => 'rfc6598',
    '127.0.0.0/8'        => 'rfc1122',
    '169.254.0.0/16'     => 'rfc3927',
    '172.16.0.0/12'      => 'rfc1918',
    '192.0.0.0/24'       => 'rfc5736',
    '192.0.2.0/24'       => 'rfc5737',
    '192.88.99.0/24'     => 'rfc3068',
    '192.168.0.0/16'     => 'rfc1918',
    '198.18.0.0/15'      => 'rfc2544',
    '198.51.100.0/24'    => 'rfc5737',
    '203.0.113.0/24'     => 'rfc5737',
    '224.0.0.0/4'        => 'rfc3171',
    '240.0.0.0/4'        => 'rfc1112',
    '255.255.255.255/32' => 'rfc919',
};


sub random_ipv4 ( %args ) {
    $args{rand} //= sub { int( rand( shift() + 1 ) ) };

    # Can't have exclude and additional_types_allowed both existing
    if ( exists( $args{exclude} ) && exists( $args{additional_types_allowed} ) )
    {
        croak(  "Cannot define both 'exclude' and "
              . "'additional_types_allowed' parameters" );
    }

    # This saves us some later branches
    # Define defaults
    $args{additional_types_allowed} //= [];
    $args{additional_exclude}       //= [];

    # What are valid option names?
    my $optre = qr/\A(?:rand|exclude|additional_(?:types_allowed|exclude))\z/;

    # Make sure all options are valid
    if ( notall { m/$optre/ } keys %args ) {
        my (@bad) = grep { !m/$optre/ } keys %args;
        croak( "unknown named argument passed to random_ipv4: " . $bad[0] );
    }

    # Get default excludes
    if ( !defined( $args{exclude} ) ) {
        $args{exclude} =
          _get_ipv4_excludes( $args{additional_types_allowed} );
    }

    # Build a closure for checking to see if an address is excluded
    my (@exclude_all) = ( @{ $args{exclude} }, @{ $args{additional_exclude} } );
    my $is_not_excluded = sub($addr) {
        none { in_ipv4_subnet( $_, $addr ) } @exclude_all;
    };

    my $addr;
    do {
        my @parts;
        for my $octet ( 1 .. 4 ) {
            push @parts, $args{rand}->( 255, $octet );
        }
        $addr = join '.', @parts;
    } until $is_not_excluded->($addr);

    return $addr;
}

# Private sub to build the default list of excludes, when passed a list
# of additional types allowed
#
# Returns a list ref
sub _get_ipv4_excludes( $addl_types ) {
    my @ret = grep {
        my $k = $_;
        none { $DEFAULT_IPV4_EXCLUDE->{$k} eq $_ } @{ $addl_types }
    } keys %{ $DEFAULT_IPV4_EXCLUDE };

    return \@ret;
}


sub in_ipv4_subnet ( $sub_cidr, $ip ) {
    if ( !defined($sub_cidr) ) { confess("subnet_cidr is not defined"); }
    if ( !defined($ip) )       { confess("ip is not defined"); }

    if ( $sub_cidr !~ m/\A(?:[\d\.]+)(?:\/(?:\d+))?\z/ ) {
        confess("$sub_cidr is not in the format A.B.C.D/N");
    }
    my ( $sub_net, $sub_mask ) = $sub_cidr =~ m/\A([\d\.]+)(?:\/(\d+))?\z/ms;
    $sub_mask //= 32;

    my $addr = unpack( 'N', inet_aton( $ip ) );
    my $sub  = unpack( 'N', inet_aton( $sub_net ) );

    my $mask = 0;
    for ( 1 .. $sub_mask ) {
        $mask = $mask >> 1;
        $mask = $mask | ( 1 << 31 );
    }

    if ( ( $addr & $mask ) == ( $sub & $mask ) ) {
        return 1;
    }

    return undef;
}


sub default_ipv4_exclude() {
    return _get_ipv4_excludes( [] );
}

1;

__END__