File Coverage

blib/lib/Paranoid/Network.pm

Criterion	Covered	Total	%
statement	119	123	96.7
branch	32	42	76.1
condition	8	18	44.4
subroutine	16	16	100.0
pod	5	5	100.0
total	180	204	88.2

# Paranoid::Network -- Network functions for paranoid programs
#
# $Id: lib/Paranoid/Network.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Network;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Paranoid;
use Paranoid::Debug qw(:all);
use Paranoid::Network::Socket;
use Paranoid::Network::IPv4 qw(:all);
use Paranoid::Network::IPv6 qw(:all);

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT      = qw(ipInNetworks hostInDomains extractIPs netIntersect);
@EXPORT_OK   = ( @EXPORT, qw(NETMATCH HOSTNAME_REGEX) );
%EXPORT_TAGS = ( all => [@EXPORT_OK], );

use constant HOSTNAME_REGEX =>
    qr#(?:[a-z0-9][a-z0-9\-]*)(?:\.[a-z0-9][a-z0-9\-]*)*\.?#s;

#####################################################################
#
# Module code follows
#
#####################################################################

{

    my $lmatch;

    sub NETMATCH : lvalue {
        $lmatch;
    }

}

sub ipInNetworks {

    # Purpose:  Checks to see if the IP occurs in the passed list of IPs and
    #           networks
    # Returns:  True (1) if the IP occurs, False (0) otherwise
    # Usage:    $rv = ipInNetworks($ip, @networks);

    my $ip       = shift;
    my @networks = grep {defined} @_;
    my $rv       = 0;
    my ( $family, @tmp );

    subPreamble( PDLEVEL1, '$@', $ip, @networks );

    NETMATCH = undef;

    # Validate arguments
    if ( defined $ip ) {

        # Extract IPv4 address from IPv6 encoding
        $ip =~ s/^::ffff:(@{[ IPV4REGEX ]})$/$1/sio;

        # Check for IPv6 support
        if ( has_ipv6() or $] >= 5.012 ) {

            pdebug( 'Found IPv4/IPv6 support', PDLEVEL2 );
            $family =
                  $ip =~ m/^@{[ IPV4REGEX ]}$/so ? AF_INET()
                : $ip =~ m/^@{[ IPV6REGEX ]}$/so ? AF_INET6()
                :                                  undef;

        } else {

            pdebug( 'Found only IPv4 support', PDLEVEL2 );
            $family = AF_INET()
                if $ip =~ m/^@{[ IPV4REGEX ]}$/so;
        }
    }

    if ( defined $ip and defined $family ) {

        # Filter out non-family data from @networks
        @networks = grep {
            $family == AF_INET()
                ? m#^(?:@{[ IPV4CIDRRGX ]}|@{[ IPV4REGEX ]})$#so
                : m#^(?:@{[ IPV6CIDRRGX ]}|@{[ IPV6REGEX ]})$#so
        } @networks;

        pdebug( 'networks to compare: %s', PDLEVEL2, @networks );

        # Start comparisons
        foreach (@networks) {
            if ($family == AF_INET()
                ? ipv4NetIntersect( $ip, $_ )
                : ipv6NetIntersect( $ip, $_ )
                ) {
                NETMATCH = $_;
                $rv = 1;
                last;
            }
        }
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub hostInDomains {

    # Purpose:  Checks to see if the host occurs in the list of domains
    # Returns:  True (1) if the host occurs, False (0) otherwise
    # Usage:    $rv = hostInDomains($hostname, @domains);

    my $host    = shift;
    my @domains = @_;
    my $rv      = 0;
    my $domain;

    subPreamble( PDLEVEL1, '$@', $host, @domains );

    NETMATCH = undef;

    if ( defined $host and $host =~ /^@{[ HOSTNAME_REGEX ]}$/so ) {

        # Filter out non-domains
        @domains =
            grep { defined $_ && m/^@{[ HOSTNAME_REGEX ]}$/so } @domains;

        # Start the comparison
        if (@domains) {
            foreach $domain (@domains) {
                if ( $host =~ /^(?:[\w\-]+\.)*\Q$domain\E$/si ) {
                    NETMATCH = $domain;
                    $rv = 1;
                    last;
                }
            }
        }
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub extractIPs {

    # Purpose:  Extracts IPv4/IPv6 addresses from arbitrary text.
    # Returns:  List containing extracted IP addresses
    # Usage:    @ips = extractIPs($string1, $string2);

    my @strings = @_;
    my ( $string, @ips, $ip, @tmp, @rv );

    subPreamble( PDLEVEL1, '@', @strings );

    foreach $string (@strings) {
        next unless defined $string;

        # Look for IPv4 addresses
        @ips = ( $string =~ /(@{[ IPV4CIDRRGX ]}|@{[ IPV4REGEX ]})/sog );

        # Validate them by filtering through inet_aton
        foreach $ip (@ips) {
            @tmp = split m#/#s, $ip;
            push @rv, $ip if defined inet_aton( $tmp[0] );
        }

        # If Socket6 is present or we have Perl 5.14 or higher we'll check
        # for IPv6 addresses
        if ( has_ipv6() or $] >= 5.012 ) {

            @ips =
                ( $string =~ m/(@{[ IPV6CIDRRGX ]}|@{[ IPV6REGEX ]})/sogix );

            # Filter out addresses with more than one ::
            @ips = grep { scalar(m/(::)/sg) <= 1 } @ips;

            # Validate remaining addresses with inet_pton
            foreach $ip (@ips) {
                @tmp = split m#/#s, $ip;
                push @rv, $ip
                    if defined inet_pton( AF_INET6(), $tmp[0] );
            }
        }
    }

    subPostamble( PDLEVEL1, '@', @rv );

    return @rv;
}

sub netIntersect {

    # Purpose:  Tests whether network address ranges intersect
    # Returns:  Integer, denoting whether an intersection exists, and what
    #           kind:
    #
    #               -1: destination range encompasses target range
    #                0: both ranges do not intersect at all
    #                1: target range encompasses destination range
    #
    # Usage:    $rv = netIntersect( $cidr1, $cidr2 );

    my $target = shift;
    my $dest   = shift;
    my $rv     = 0;

    subPreamble( PDLEVEL1, '$$', $target, $dest );

    if ( defined $target and defined $dest ) {
        if ( $target =~ m/^(?:@{[ IPV4CIDRRGX ]}|@{[ IPV4REGEX ]})$/s ) {
            $rv = ipv4NetIntersect( $target, $dest );
        } elsif ( $target =~ m/^(?:@{[ IPV6CIDRRGX ]}|@{[ IPV6REGEX ]})$/si )
        {
            $rv = ipv6NetIntersect( $target, $dest )
                if has_ipv6()
                    or $] >= 5.012;
        } else {
            pdebug(
                'target string (%s) doesn\'t seem to match '
                    . 'an IP/network address',
                PDLEVEL1, $target
                );
        }
    } else {
        pdebug( 'one or both arguments are not defined', PDLEVEL1 );
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

1;

__END__