File Coverage

blib/lib/Paranoid/Network/IPv6.pm

Criterion	Covered	Total	%
statement	164	168	97.6
branch	35	44	79.5
condition	13	21	61.9
subroutine	27	27	100.0
pod	6	6	100.0
total	245	266	92.1

# Paranoid::Network::IPv6 -- IPv6-specific network functions
#
# $Id: lib/Paranoid/Network/IPv6.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::IPv6;

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;

my @base      = qw(ipv6NetConvert ipv6NetPacked ipv6NetIntersect);
my @constants = qw(MAXIPV6CIDR IPV6REGEX IPV6CIDRRGX IPV6BASE IPV6BRDCST
    IPV6MASK);
my @ipv6sort = qw(ipv6StrSort ipv6PackedSort ipv6NumSort);

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm );
@EXPORT      = @base;
@EXPORT_OK   = ( @base, @constants, @ipv6sort );
%EXPORT_TAGS = (
    all       => [@EXPORT_OK],
    base      => [@base],
    constants => [@constants],
    ipv6Sort  => [@ipv6sort],
    );

use constant MAXIPV6CIDR => 128;
use constant IPV6REGEX   => qr/
                            :(?::[abcdef\d]{1,4}){1,7}                   |
                            \b[abcdef\d]{1,4}(?:::?[abcdef\d]{1,4}){1,7} |
                            (?:\b[abcdef\d]{1,4}:){1,7}:
                            /six;
use constant IPV6CIDRRGX =>
    qr#@{[ IPV6REGEX ]}/(?:1(?:[01]\d|2[0-8])|\d\d?)#s;
use constant IPV6BASE   => 0;
use constant IPV6BRDCST => 1;
use constant IPV6MASK   => 2;
use constant CHUNKMASK  => 0xffffffff;
use constant CHUNK      => 32;
use constant IPV6CHUNKS => 4;
use constant IPV6LENGTH => 16;

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

sub ipv6NetConvert {

    # Purpose:  Takes a string representation of an IPv6 network
    #           address and returns a list of lists containing
    #           the binary network address, broadcast address,
    #           and netmask, each broken into 32bit chunks.
    #           Also allows for a plain IP being passed, in which
    #           case it only returns the binary IP.
    # Returns:  Array, empty on errors
    # Usage:    @network = ipv6NetConvert($netAddr);

    my $netAddr = shift;
    my ( $bnet, $bmask, $t, @tmp, @rv );

    subPreamble( PDLEVEL1, '$', $netAddr );

    if ( has_ipv6() or $] >= 5.012 ) {

        # Extract net address, mask
        if ( defined $netAddr ) {
            ($t) =
                ( $netAddr =~ m#^(@{[ IPV6CIDRRGX ]}|@{[ IPV6REGEX ]})$#s )
                [0];
            ( $bnet, $bmask ) = split m#/#s, $t if defined $t;
        }

        if ( defined $bnet and length $bnet ) {

            # First, convert $bnet to see if we have a valid IP address
            $bnet = [ unpack 'NNNN', inet_pton( AF_INET6(), $bnet ) ];

            if ( defined $bnet and length $bnet ) {

                # Save our network address
                push @rv, $bnet;

                if ( defined $bmask and length $bmask ) {

                    # Convert netmask
                    if ( $bmask <= MAXIPV6CIDR ) {

                        # Add the mask in 32-bit chunks
                        @tmp = ();
                        while ( $bmask >= CHUNK ) {
                            push @tmp, CHUNKMASK;
                            $bmask -= CHUNK;
                        }

                        # Push the final segment if there's a remainder
                        if ($bmask) {
                            push @tmp,
                                CHUNKMASK - ( ( 2**( CHUNK - $bmask ) ) - 1 );
                        }

                        # Add zero'd chunks to fill it out
                        while ( @tmp < IPV6CHUNKS ) {
                            push @tmp, 0x0;
                        }

                        # Finally, save the chunks
                        $bmask = [@tmp];

                    } else {
                        $bmask = undef;
                    }

                    if ( defined $bmask ) {

                        # Apply the mask to the base address
                        foreach ( 0 .. ( IPV6CHUNKS - 1 ) ) {
                            $$bnet[$_] &= $$bmask[$_];
                        }

                        # Calculate and save our broadcast address
                        @tmp = ();
                        foreach ( 0 .. ( IPV6CHUNKS - 1 ) ) {
                            $tmp[$_] =
                                $$bnet[$_] | ( $$bmask[$_] ^ CHUNKMASK );
                        }
                        push @rv, [@tmp];

                        # Save our mask
                        push @rv, $bmask;

                    } else {
                        pdebug( 'invalid netmask passed', PDLEVEL1 );
                    }
                }

            } else {
                pdebug( 'failed to convert IPv6 address', PDLEVEL1 );
            }
        } else {
            pdebug( 'failed to extract an IPv6 address', PDLEVEL1 );
        }

    } else {
        pdebug( 'IPv6 support not present', PDLEVEL1 );
    }

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

    return @rv;
}

sub ipv6NetPacked {

    # Purpose:  Wrapper script for ipv6NetConvert that repacks all of its
    #           32bit chunks into opaque strings in network-byte order.
    # Returns:  Array
    # Usage:    @network = ipv6NetPacked($netAddr);

    my $netAddr = shift;
    my @rv;

    subPreamble( PDLEVEL1, '$', $netAddr );

    @rv = ipv6NetConvert($netAddr);
    foreach (@rv) {
        $_ = pack 'NNNN', @$_;
    }

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

    return @rv;
}

sub _cmpArrays {

    # Purpose:  Compares IPv6 chunked address arrays
    # Returns:  -1:  net1 < net 2
    #            0:  net1 == net2
    #            1:  net1 > net2
    # Usage:    $rv = _cmpArrays( $aref1, $aref2 );

    my $aref1 = shift;
    my $aref2 = shift;
    my $rv    = 0;

    subPreamble( PDLEVEL2, '\@\@', $aref1, $aref2 );

    while ( scalar @$aref1 ) {
        unless ( $$aref1[0] == $$aref2[0] ) {
            $rv = $$aref1[0] > $$aref2[0] ? 1 : -1;
            last;
        }
        shift @$aref1;
        shift @$aref2;
    }

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

    return $rv;
}

sub ipv6NetIntersect {

    # 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 = ipv6NetIntersect($net1, $net2);

    my $tgt  = shift;
    my $dest = shift;
    my $rv   = 0;
    my ( @tnet, @dnet );

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

    # Bypas if one or both isn't defined -- obviously no intersection
    unless ( !defined $tgt or !defined $dest ) {

        # Treat any array references as IPv6 addresses already translated into
        # 32bit integer chunks
        @tnet = ref($tgt)  eq 'ARRAY' ? $tgt  : ipv6NetConvert($tgt);
        @dnet = ref($dest) eq 'ARRAY' ? $dest : ipv6NetConvert($dest);

        # insert bogus numbers for non IP-address info
        @tnet = ( [ -1, 0, 0, 0 ] ) unless scalar @tnet;
        @dnet = ( [ -2, 0, 0, 0 ] ) unless scalar @dnet;

        # Dummy up broadcast address for those single IPs passed (in lieu of
        # network ranges)
        if ( $#tnet == 0 ) {
            $tnet[IPV6BRDCST] = $tnet[IPV6BASE];
            $tnet[IPV6MASK] = [ CHUNKMASK, CHUNKMASK, CHUNKMASK, CHUNKMASK ];
        }
        if ( $#dnet == 0 ) {
            $dnet[IPV6BRDCST] = $dnet[IPV6BASE];
            $dnet[IPV6MASK] = [ CHUNKMASK, CHUNKMASK, CHUNKMASK, CHUNKMASK ];
        }

        if (    _cmpArrays( $tnet[IPV6BASE], $dnet[IPV6BASE] ) <= 0
            and _cmpArrays( $tnet[IPV6BRDCST], $dnet[IPV6BRDCST] ) >= 0 ) {

            # Target fully encapsulates dest
            $rv = 1;

        } elsif ( _cmpArrays( $tnet[IPV6BASE], $dnet[IPV6BASE] ) >= 0
            and _cmpArrays( $tnet[IPV6BRDCST], $dnet[IPV6BRDCST] ) <= 0 ) {

            # Dest fully encapsulates target
            $rv = -1;

        }
    }

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

    return $rv;
}

{

    no strict 'refs';

    sub ipv6NumSort {

        # Purpose:  Sorts IPv6 addresses represented in numeric form
        # Returns:  -1, 0, 1
        # Usage:    @sorted = sort &ipv6NumSort @ipv4;

        my ($pkg) = caller;
        my ( $i, $rv );

        foreach $i ( 0 .. 3 ) {
            $rv = $${"${pkg}::a"}[$i] <=> $${"${pkg}::b"}[$i];
            last if $rv;
        }

        return $rv;
    }

    sub ipv6PackedSort {

        # Purpose:  Sorts IPv6 addresses represented by packed strings
        # Returns:  -1, 0, 1
        # Usage:    @sorted = sort &ipv6PackedSort @ipv6;

        no warnings 'once';

        my ($pkg) = caller;
        $a = [ unpack 'NNNN', ${"${pkg}::a"} ];
        $b = [ unpack 'NNNN', ${"${pkg}::b"} ];

        return ipv6NumSort();
    }

    sub ipv6StrSort {

        # Purpose:  Sorts IPv6 addresses represented in string form
        # Returns:  -1, 0, 1
        # Usage:    @sorted = sort &ipv4StrSort @ipv4;

        my ($pkg) = caller;
        my $a1    = ${"${pkg}::a"};
        my $b1    = ${"${pkg}::b"};
        my ( $i, $rv );

        $a1 =~ s#/.+##s;
        $a1 = [ unpack 'NNNN', inet_pton( AF_INET6(), $a1 ) ];
        $b1 =~ s#/.+##s;
        $b1 = [ unpack 'NNNN', inet_pton( AF_INET6(), $b1 ) ];

        foreach $i ( 0 .. 3 ) {
            $rv = $$a1[$i] <=> $$b1[$i];
            last if $rv;
        }

        return $rv;
    }
}

1;

__END__