File Coverage

blib/lib/Net/IPv6Addr.pm

Criterion	Covered	Total	%
statement	245	292	83.9
branch	56	82	68.2
condition	18	21	85.7
subroutine	34	36	94.4
pod	16	32	50.0
total	369	463	79.7

package Net::IPv6Addr;

use strict;
use warnings;

our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw(
    from_bigint
    in_network
    in_network_of_size
    ipv6_chkip
    ipv6_parse
    is_ipv6
    to_array
    to_bigint
    to_intarray
    to_string_base85
    to_string_compressed
    to_string_ip6_int
    to_string_ipv4
    to_string_ipv4_compressed
    to_string_preferred
);

our %EXPORT_TAGS = (all => \@EXPORT_OK);

our $VERSION = '1.02';

use Carp;
use Math::BigInt '1.999813';

my $base85ok;
eval {
    require Math::Base85;
};
if (! $@) {
    $base85ok = 1;
}

sub base85ok
{
    return $base85ok
}

#  ____       _   _
# |  _ \ __ _| |_| |_ ___ _ __ _ __  ___
# | |_) / _` | __| __/ _ \ '__| '_ \/ __|
# |  __/ (_| | |_| ||  __/ |  | | | \__ \
# |_|   \__,_|\__|\__\___|_|  |_| |_|___/
#

# Match one to four digits of hexadecimal

my $h = qr/[a-f0-9]{1,4}/i;

my $ipn = qr!
    (
	25[0-5]
    |
	2[0-4][0-9]
    |
	1[0-9]{2}
    |
	[1-9][0-9]
    |
	[0-9]
    )
!x;

my $ipv4 = qr!($ipn\.){3}$ipn!;

sub ipv4_validate
{
    my ($ip) = @_;
    if ($ip !~ /$ipv4/) {
	croak "Holy macaroni batman";
    }
}

# base-85

my $base85_re;
if ($base85ok) {
    my $digits = $Math::Base85::base85_digits;
    $digits =~ s/-//;
    $base85_re = qr![$digits-]{20}!;
}

my %ipv6_patterns = (
    'preferred' => [
	qr/^(?:$h:){7}$h$/i,
	\&ipv6_parse_preferred,
    ],
    'compressed' => [
	qr/^[a-f0-9]{0,4}::$/i,
	qr/^:(?::$h){1,7}$/i,
	qr/^(?:$h:){1,}:$/i,
	qr/^(?:$h:)(?::$h){1,6}$/i,
	qr/^(?:$h:){2}(?::$h){1,5}$/i,
	qr/^(?:$h:){3}(?::$h){1,4}$/i,
	qr/^(?:$h:){4}(?::$h){1,3}$/i,
	qr/^(?:$h:){5}(?::$h){1,2}$/i,
	qr/^(?:$h:){6}(?::$h)$/i,
	\&ipv6_parse_compressed,
    ],
    'ipv4' => [
	qr/^(?:0:){5}ffff:$ipv4$/i,
	qr/^(?:0:){6}$ipv4$/,
	\&ipv6_parse_ipv4,
    ],
    'ipv4 compressed' => [
	qr/^::(?:ffff:)?$ipv4$/i,
	\&ipv6_parse_ipv4_compressed,
    ],
    'ipv6v4' => [
	qr/^[a-f0-9]{0,4}::$ipv4$/i,
	# ::1:2:3:4:1.2.3.4
	qr/^::(?:$h:){1,5}$ipv4$/i,
	qr/^(?:$h:):(?:$h:){1,4}$ipv4$/i,
	qr/^(?:$h:){2}:(?:$h:){1,3}$ipv4$/i,
	qr/^(?:$h:){3}:(?:$h:){1,2}$ipv4$/i,
	qr/^(?:$h:){4}:(?:$h:){1}$ipv4$/i,
	# 1:2:3:4:5::1.2.3.4
	qr/^(?:$h:){1,5}:$ipv4$/i,
	# 1:2:3:4:5:6:1.2.3.4
	qr/^(?:$h:){6}$ipv4$/i,
	\&parse_mixed_ipv6v4_compressed,
    ],
);

if ($base85ok) {
    $ipv6_patterns{'base85'} = [
	$base85_re,
	\&ipv6_parse_base85,
    ],
}

#  ____       _            _
# |  _ \ _ __(_)_   ____ _| |_ ___
# | |_) | '__| \ \ / / _` | __/ _ \
# |  __/| |  | |\ V / (_| | ||  __/
# |_|   |_|  |_| \_/ \__,_|\__\___|
#

# Errors which include the package name and the subroutine name. This
# is for consistency with earlier versions of the module.

sub mycroak
{
    my ($message) = @_;
    my @caller = caller (1);
    croak $caller[3] . ' -- ' . $message;
}

# Given one argument with a slash or two arguments, return them as two
# arguments, and check there are one or two arguments.

sub getargs
{
    my ($ip, $pfx);
    if (@_ == 2) {
	($ip, $pfx) = @_;
    }
    elsif (@_ == 1) {
	($ip, $pfx) = split(m!/!, $_[0], 2)
    }
    else {
	mycroak "wrong number of arguments (need 1 or 2)";
    }
    return ($ip, $pfx);
}

# Match $ip against the regexes of type $type, or die.

sub match_or_die
{
    my ($ip, $type) = @_;
    # Instead of trying to construct a gigantic regex which only
    # allows two colons in a row, just check here.
    if ($ip =~ /:::/) {
	mycroak "invalid address $ip for type $type";
    }
    my $patterns = $ipv6_patterns{$type};
    for my $p (@$patterns) {
	# The last thing in the pattern is a code reference, so this
	# match indicates no matches were found.
	if (ref($p) eq 'CODE') {
	    mycroak "invalid address $ip for type $type";
	}
	if ($ip =~ $p) {
	    return;
	}
    }
}

# Make the bit mask for "in_network_of_size".

sub bitmask
{
    my ($j) = @_;
    my $bitmask = '1' x $j . '0' x (16 - $j);
    my $k = unpack("n",pack("B16", $bitmask));
    return $k;
}

#  ____
# |  _ \ __ _ _ __ ___  ___ _ __ ___
# | |_) / _` | '__/ __|/ _ \ '__/ __|
# |  __/ (_| | |  \__ \  __/ |  \__ \
# |_|   \__,_|_|  |___/\___|_|  |___/
#

# Private parser

sub ipv6_parse_preferred
{
    my $ip = shift;
    match_or_die ($ip, 'preferred');
    my @pieces = split (/:/, $ip);
    splice (@pieces, 8);
    return map { hex } @pieces;
}

# Private parser

sub ipv6_parse_compressed
{
    my $ip = shift;
    my $type = 'compressed';
    match_or_die ($ip, $type);
    my $colons = ($ip =~ tr/:/:/);
    my $expanded = ':' x (9 - $colons);
    $ip =~ s/::/$expanded/;
    my @pieces = split (/:/, $ip, 8);
    return map { hex } @pieces;
}

sub parse_mixed_ipv6v4_compressed
{
    my $ip = shift;
    match_or_die ($ip, 'ipv6v4');
    my @result;
    my $v4addr;
    my $colons;
    $colons = ($ip =~ tr/:/:/);
    my $expanded = ':' x (8 - $colons);
    $ip =~ s/::/$expanded/;
    my @v6pcs = split(/:/, $ip, 7);
    $v4addr = $v6pcs[-1];
    splice(@v6pcs, 6);
    push @result, map { hex } @v6pcs;
    ipv4_validate($v4addr);
    my @v4pcs = split(/\./, $v4addr);
    splice(@v4pcs, 4);
    push @result, unpack("n", pack("CC", @v4pcs[0,1]));
    push @result, unpack("n", pack("CC", @v4pcs[2,3]));
    return @result;
}

# Private parser

sub ipv6_parse_ipv4
{
    my $ip = shift;
    match_or_die ($ip, 'ipv4');
    my @result;
    my $v4addr;
    my @v6pcs = split(/:/, $ip);
    $v4addr = $v6pcs[-1];
    splice(@v6pcs, 6);
    push @result, map { hex } @v6pcs;
    ipv4_validate($v4addr);
    my @v4pcs = split(/\./, $v4addr);
    push @result, unpack("n", pack("CC", @v4pcs[0,1]));
    push @result, unpack("n", pack("CC", @v4pcs[2,3]));
    return @result;
}

# Private parser

sub ipv6_parse_ipv4_compressed
{
    my $ip = shift;
    match_or_die ($ip, 'ipv4 compressed');
    my @result;
    my $v4addr;
    my $colons;
    $colons = ($ip =~ tr/:/:/);
    my $expanded = ':' x (8 - $colons);
    $ip =~ s/::/$expanded/;
    my @v6pcs = split(/:/, $ip, 7);
    $v4addr = $v6pcs[-1];
    splice(@v6pcs, 6);
    push @result, map { hex } @v6pcs;
    ipv4_validate($v4addr);
    my @v4pcs = split(/\./, $v4addr);
    splice(@v4pcs, 4);
    push @result, unpack("n", pack("CC", @v4pcs[0,1]));
    push @result, unpack("n", pack("CC", @v4pcs[2,3]));
    return @result;
}

# Private parser

sub ipv6_parse_base85
{
    if (! $base85ok) {
	carp "Math::Base85 is not installed";
	return ();
    }
    my $ip = shift;
    match_or_die ($ip, 'base85');
    my $r;
    my $bigint = Math::Base85::from_base85($ip);
    my @result;
    while ($bigint > 0) {
	$r = $bigint & 0xffff;
	unshift @result, sprintf("%d", $r);
	$bigint = $bigint >> 16;
    }
    foreach $r ($#result+1..7) {
        $result[$r] = 0;
    }
    return @result;
}

#  ____        _     _ _
# |  _ \ _   _| |__ | (_) ___
# | |_) | | | | '_ \| | |/ __|
# |  __/| |_| | |_) | | | (__
# |_|    \__,_|_.__/|_|_|\___|
#

# Public

sub new
{
    my $proto = shift;
    my $class = ref ($proto) || $proto;
    my $maybe_ip = shift;
    my $parser = ipv6_chkip ($maybe_ip);
    if (ref $parser ne 'CODE') {
	mycroak "invalid IPv6 address $maybe_ip";
    }
    my @hexadecets = $parser->($maybe_ip);
    my $self = \@hexadecets;
    bless $self, $class;
    return $self;
}

# Public

sub ipv6_chkip
{
    my $ip = shift;

    my $parser = undef;

    TYPE:
    for my $k (keys %ipv6_patterns) {
	my @patlist = @{$ipv6_patterns{$k}};
	PATTERN:
	for my $pattern (@patlist) {
	    last PATTERN if (ref($pattern) eq 'CODE');
	    if ($ip =~ $pattern) {
		$parser = $patlist[-1];
		last TYPE;
	    }
	}
    }
    return $parser;
}

# Public

sub ipv6_parse
{
    my ($ip, $pfx) = getargs (@_);

    if (! ipv6_chkip ($ip)) {
	mycroak "invalid IPv6 address $ip";
    }

    if (! defined $pfx) {
	return $ip;
    }

    $pfx =~ s/\s+//g;

    if ($pfx =~ /^[0-9]+$/) {
	if ($pfx > 128) {
	    mycroak "invalid prefix length $pfx";
	}
    }
    else {
	mycroak "non-numeric prefix length $pfx";
    }

    if (wantarray ()) {
	return ($ip, $pfx);
    }
    return "$ip/$pfx";
}

# Public

sub is_ipv6
{
    my $r;
    eval {
	$r = ipv6_parse (@_);
    };
    if ($@) {
	return undef;
    }
    return $r;
}

# Public

sub to_string_preferred
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    return v6part (@$self);
}

# Public

sub to_string_compressed
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my $expanded = v6part (@$self);
    $expanded =~ s/^0:/:/;
    $expanded =~ s/:0/:/g;
    if ($expanded =~ s/:::::::/_/ or
	$expanded =~ s/::::::/_/ or
	$expanded =~ s/:::::/_/ or
	$expanded =~ s/::::/_/ or
	$expanded =~ s/:::/_/ or
	$expanded =~ s/::/_/
    ) {
        $expanded =~ s/:(?=:)/:0/g;
	$expanded =~ s/^:(?=[0-9a-f])/0:/;
	$expanded =~ s/([0-9a-f]):$/$1:0/;
	$expanded =~ s/_/::/;
    }
    return $expanded;
}

# Private

sub bytes
{
    my ($in) = @_;
    my $low = $in & 0xff;
    my $high = $in >> 8;
    return ($high, $low);
}

# Private

sub v4part
{
    my ($t, $b) = @_;
    return join('.', bytes ($t), bytes ($b));
}

# Private

sub v6part
{
    return join(':', map { sprintf("%x", $_) } @_);
}

# Public

sub to_string_ipv4
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my $v6part = v6part (@$self[0..5]);
    my $v4part = v4part (@$self[6, 7]);
    return "$v6part:$v4part";
}

# Public

sub to_string_ipv4_compressed
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my $v6part = v6part (@$self[0..5]);
    $v6part .= ':';
    $v6part =~ s/(^|:)(0:)+/::/;
    my $v4part = v4part (@$self[6, 7]);
    return "$v6part$v4part";
}

# Public

sub to_string_base85
{
    if (! $base85ok) {
	carp "Math::Base85 is not installed";
	return undef;
    }
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my $bigint = new Math::BigInt("0");
    for my $i (@{$self}[0..6]) {
	$bigint = $bigint + $i;
	$bigint = $bigint << 16;
    }
    $bigint = $bigint + $self->[7];
    return Math::Base85::to_base85($bigint);
}

# Public

sub to_bigint
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my $bigint = new Math::BigInt("0");
    for my $i (@{$self}[0..6]) {
	$bigint = $bigint + $i;
	$bigint = $bigint << 16;
    }
    $bigint = $bigint + $self->[7];
    $bigint =~ s/\+//;
    return $bigint;
}

# Public

sub to_array
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    return map {sprintf "%04x", $_} @$self;
}

# Public

sub to_intarray
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    return @$self;
}

# Public

sub to_string_ip6_int
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my $hexdigits = sprintf("%04x" x 8, @$self);
    my @nibbles = ('INT', 'IP6', split(//, $hexdigits));
    my $ptr = join('.', reverse @nibbles);
    return $ptr . ".";
}

# Private - validate a given netsize

sub validate_netsize
{
    my ($netsize) = @_;
    if ($netsize !~ /^[0-9]+$/ || $netsize > 128) {
	mycroak "invalid network size $netsize";
    }
}

# Public

sub in_network_of_size
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	if ($self =~ m!(.+)/(.+)!) {
	    unshift @_, $2;
	    $self = $1;
	}
	$self = Net::IPv6Addr->new($self);
    }
    my $netsize = shift;
    if (! defined $netsize) {
	mycroak "network size not given";
    }
    $netsize =~ s!/!!;
    validate_netsize ($netsize);
    my @parts = @$self;
    my $i = int ($netsize / 16);
    if ($i < 8) {
	my $j = $netsize % 16;
	if ($j) {
	    # If $netsize is not a multiple of 16, truncate the lowest
	    # 16-$j bits of the $ith element of @parts.
	    $parts[$i] &= bitmask ($j);
	    # Jump over this element.
	    $i++;
	}
	# Set all the remaining lower parts to zero.
	for ($i..$#parts) {
	    $parts[$_] = 0;
	}
    }
    return bless \@parts;
}

# Public

sub in_network
{
    my $self = shift;
    if (ref $self ne __PACKAGE__) {
	$self = Net::IPv6Addr->new ($self);
    }
    my ($net, $netsize) = getargs (@_);
    unless (defined $netsize) {
	mycroak "not enough parameters, need netsize";
    }
    $netsize =~ s!/!!;
    validate_netsize ($netsize);
    if (! ref $net) {
	$net = Net::IPv6Addr->new($net);
    }
    my @s = $self->in_network_of_size($netsize)->to_intarray;
    my @n = $net->in_network_of_size($netsize)->to_intarray;
    my $i = int ($netsize / 16) + 1;
    if ($i > $#s) {
	$i = $#s;
    }
    for (0..$i) {
	if ($s[$_] != $n[$_]) {
	    return undef;
	}
    }
    return 1;
}

# Public

sub from_bigint
{
    my ($big) = @_;
    # Input is a scalar or a Math::BigInt object.
    if (! ref ($big)) {
	$big = Math::BigInt->new ($big);
    }
    if (ref ($big) ne 'Math::BigInt') {
	mycroak "Cannot process non-scalar, non-Math::BigInt input";
    }
    # Convert the number to a hexadecimal string
    my $hex = $big->to_hex ();
    # Pad if necessary for the colon placement
    if (length ($hex) < 32) {
	my $leading = '0' x (32 - length ($hex));
	$hex = $leading . $hex;
    }
    # Reversing the string makes adding colons with a substitution
    # operator easier.
    my $ipr = reverse $hex;
    $ipr =~ s/(....)/$1:/g;
    $ipr = reverse $ipr;
    # Remove the excess colon.
    $ipr =~ s/^://;
    # Should be OK now, let "new" handle any further issues.
    return Net::IPv6Addr->new ($ipr);
}

1;