File Coverage

lib/IP/Random.pm

Criterion	Covered	Total	%
statement	105	111	94.5
branch	18	22	81.8
condition	9	11	81.8
subroutine	17	17	100.0
pod	3	3	100.0
total	152	164	92.6

#!/usr/bin/perl

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

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


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

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

use Carp;

# We need a version of List::Util with uniq in it
use List::Util 1.50 qw(any none notall pairs uniq);
use Socket qw(inet_aton);

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

# Build cache of valid types
my %VALID_TYPES = map { $_, 1 } uniq sort map { @$_ } values %$IPV4_EXCLUDE;


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} );
    }

    # Expand out tags in exclude list
    my (@exclude_cidrs) = grep { m/^\d+\.\d+\.\d+\.\d+(:?\/\d+)$/ } @{ $args{exclude} },
      @{ $args{additional_exclude} };

    my (@exclude_tags) = grep { !m/^\d+\.\d+\.\d+\.\d+(:?\/\d+)$/ } @{ $args{exclude} },
      @{ $args{additional_exclude} };

    my (@exclude_expanded) = ( @exclude_cidrs, map { @{ _get_ipv4_excludes( $args{additional_types_allowed}, $_ ) } } @exclude_tags );

    my (@exclude_all) = uniq sort @exclude_expanded;

    # Build a closure for checking to see if an address is excluded
    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, $tag = 'default' ) {
    foreach my $t (@$addl_types) {
        if ( !exists( $VALID_TYPES{$t} ) ) {
            confess("Type '$t' is not a valid type");
        }
    }
    if ( !exists( $VALID_TYPES{$tag} ) ) {
        confess("Type '$tag' is not a valid type");
    }

    my @ret;

  NEXT_EXCLUDE:
    foreach my $default_exclude ( keys %$IPV4_EXCLUDE ) {
        if ( none { $_ eq $tag } @{ $IPV4_EXCLUDE->{$default_exclude} } ) {
            next NEXT_EXCLUDE;
        }

        foreach my $checktype ( @{ $IPV4_EXCLUDE->{$default_exclude} } ) {
            if ( any { $_ eq $checktype } @$addl_types ) {
                # Not excluded.
                next NEXT_EXCLUDE;
            }
        }
        push @ret, $default_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(?:[0-9\.]+)(?:\/(?:[0-9]+))?\z/ ) {
        confess("$sub_cidr is not in the format A.B.C.D/N");
    }
    my ( $sub_net, $sub_mask ) = $sub_cidr =~ m/\A([0-9\.]+)(?:\/([0-9]+))?\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;
}


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

1;

__END__