File Coverage

blib/lib/Net/IPAddress/Util.pm

Criterion	Covered	Total	%
statement	266	362	73.4
branch	58	116	50.0
condition	36	74	48.6
subroutine	38	51	74.5
pod	28	28	100.0
total	426	631	67.5

package Net::IPAddress::Util;

use 5.012;

use overload (
  '=' => 'new',
  '""' => 'str',
  'cmp' => '_spaceship',
  '<=>' => '_spaceship',
  '+' => '_do_add',
  '-' => '_do_subtract',
  '<<' => '_shift_left',
  '>>' => '_shift_right',
  '&' => '_band',
  '|' => '_bor',
  '~' => '_neg',
);

use Carp qw( carp cluck confess );
use Exporter qw( import );
use List::MoreUtils qw( pairwise );

our %EXPORT_TAGS = (
  constr => [qw( IP n32_to_ipv4 )],
  manip  => [qw( explode_ip implode_ip ip_pad_prefix common_prefix prefix_mask ipv4_mask ipv4_flag )],
  sort   => [qw( radix_sort )],
  compat => [qw( ip2num num2ip validaddr mask fqdn )]
);

my %EXPORT_OK;
for my $k (keys %EXPORT_TAGS) {
  for my $v (@{$EXPORT_TAGS{ $k }}) {
    undef $EXPORT_OK{ $v };
  }
}

our @EXPORT_OK = keys %EXPORT_OK;

$EXPORT_TAGS{ all } = [ @EXPORT_OK ];

our $DIE_ON_ERROR = 0;
our $PROMOTE_N32 = 1;
our $REPAIR_V3_FORMAT = 0;
our $WARN_ON_REPAIR = 1;

our @SIIT = (
  [ 0, 0, 0xff, 0xff ], # off
  [ 0xff, 0xff, 0, 0 ], # on
);

our $VERSION = '5.000';

our $siit_fourish = qr/^(?:::ffff:0+:)?(\d+)\.(\d+)\.(\d+)\.(\d+)$/io;
our $fourish = qr/^(?:::ffff:)?(\d+)\.(\d+)\.(\d+)\.(\d+)$/io;
our $numberish = qr/^(\d+)$/o;
our $normalish = qr/^([0-9a-f]{32})$/io;
our $sixish = qr/^([0-9a-f:]+)(?:\%.*)?$/io;

*__debug
  = $ENV{ IP_UTIL_DEBUG }
  ? sub { my ($p, $f, $l) = caller(); warn('@' . " $l: " . join(', ', @_) . "\n"); }
  : sub { }
  ;

*__dnorm
  = $ENV{ IP_UTIL_DEBUG }
  ? sub {
    my ($p, $f, $l) = caller();
    my $n = 0;
    for my $x (@_) {
      if (eval { @$x }) {
        warn($n++ . ' @' . " $l: [" . join(', ', map { sprintf('%x', $_) } @$x) . "]\n");
      }
      else {
        warn($n++ . ' @' . " $l: " . $x . "\n");
      }
    }
  }
  : sub { }
  ;

sub SIIT {
  my $self = shift;
  my ($do) = @_;
  $do //= 1;
  $self = _set_SIIT($self, $do);
  $self->{ SIIT } = $do;
  return $self;
}

sub _set_SIIT {
  my ($old, $do) = @_;
  my $normal = [ unpack('C16', $old->{ address }) ];
  if (
    !(grep { $_ } @$normal[ 0 .. 7 ])
    && (grep { $normal->[ $_ ] == $SIIT[!!$do]->[ $_ ] } (8 .. 11)) == 4
  ) {
    $normal->[ $_ ] = $SIIT[!$do]->[ $_ ] for (8 .. 11);
  }
  $old->{ address } = pack('C16', @$normal);
  return $old;
}

sub IP {
  return __PACKAGE__->new(@_);
}

sub new {
  my $self = shift;
  my $class = ref($self) || $self;
  my ($address, %opt) = @_;
  __debug(
    eval { @$address }
    ? join(' ', map { sprintf($_ > 255 ? '0x%08x' : '%3s', $_ ) } @$address)
    : $address
  );
  my @siit_prefix = @{$SIIT[$opt{ SIIT }
    ||= (
      !ref($address)
      and
      $address =~ $siit_fourish
      and
      $address !~ $fourish
    )
  ]};
  __debug('is ' . ($opt{ SIIT } ? 'not ' : '') . 'SIIT looking');
  my $promote = $opt{ promote } // $PROMOTE_N32;
  my $normal = [ ];
  if (!defined $address) {
    $normal = [
      0, 0, 0, 0,
      0, 0, 0, 0,
      0, 0, 0, 0,
      0, 0, 0, 0,
    ];
    __dnorm($normal);
  }
  if (ref($address) eq 'ARRAY' && @$address == 16) {
    __debug('16 element array');
    $normal = $address;
    __dnorm($normal);
  }
  elsif (ref($address) eq 'ARRAY' && @$address == 4) {
    # FIXME: Principal of least surprise here? Should feeding in 4 values make an IPv4?
    __debug('4 element array');
    $normal = [ unpack 'C16', pack 'N4', @$address ];
    __dnorm($normal);
  }
  elsif (ref $address and eval { $address->isa(__PACKAGE__) }) {
    $normal = [ unpack 'C16', $address->{ address } ];
  }
  elsif ($address =~ $fourish || $address =~ $siit_fourish) {
    my @addr = ($1, $2, $3, $4);
    # FIXME: Why can't we do this all on one line?
    @addr = map { $_ =~ /^0/ ? oct($_) : int($_) } @addr;
    $normal = [
      0, 0, 0, 0,
      0, 0, 0, 0,
      @siit_prefix,
      @addr
    ];
  }
  elsif (
    $opt{ promote }
    and $address =~ $numberish
    and 0 <= $address && $address <= (2 ** 32) - 1
  ) {
    $normal = [
      0, 0, 0, 0,
      0, 0, 0, 0,
      @siit_prefix,
      unpack('C4', pack('N', $address))
    ];
  }
  elsif ("$address" =~ $normalish) {
    my $fresh = $1;
    eval "require Math::BigInt" or return ERROR("Could not load Math::BigInt: $@");
    my $raw = Math::BigInt->from_hex("$fresh");
    while ($raw > 0) {
      my $word = $raw->copy->band(0xffffffff);
      unshift @$normal, unpack('C4', pack('N', $word));
      $raw = $raw->copy->brsft(32);
    }
    while (@$normal < 16) {
      unshift @$normal, 0;
    }
    eval "no Math::BigInt";
  }
  elsif ($address =~ $numberish) {
    eval "require Math::BigInt" or return ERROR("Could not load Math::BigInt: $@");
    my $raw = Math::BigInt->new("$address");
    while ($raw > 0) {
      my $word = $raw->copy->band(0xffffffff);
      unshift @$normal, unpack('C4', pack('N', $word));
      $raw = $raw->copy->brsft(32);
    }
    while (@$normal < 16) {
      unshift @$normal, 0;
    }
    eval "no Math::BigInt";
  }
  elsif (
    $address =~ $sixish
    and (
      scalar(grep { /::/o } split(/[[:alnum:]]+/, $address)) == 1
      or scalar(grep { /[[:alnum:]]+/ } split(/:/, $address)) == 8
    )
  ) {
    # new() from IPv6 address, accepting and ignoring the Scope ID
    $address = $1;
    my ($lhs, $rhs) = split /::/, $address;
    $rhs = '' unless defined $rhs;
    my $hex = '0' x 32;
    $lhs = join '', map { substr('0000' . $_, -4) } split /:/, $lhs;
    $rhs = join '', map { substr('0000' . $_, -4) } split /:/, $rhs;
    substr($hex, 0,              length($lhs)) = $lhs;
    substr($hex, - length($rhs), length($rhs)) = $rhs;
    my @hex = split //, $hex;
    while (@hex) {
      push @$normal, hex(join('', splice(@hex, 0, 2)));
    }
  }
  elsif (length($address) == 16) {
    $normal = [ unpack('C16', $address) ];
  }
  else {
    return ERROR("Invalid argument `$address', a(n) " . (ref($address) || 'bare scalar') . ' provided');
  }
  # warn(join(',', @$normal) . "\n");
  return bless { address => pack('C16', @$normal), %opt } => $class;
}

sub is_ipv4 {
  my $self = shift;
  my @octets = unpack 'C16', $self->{ address };
  __debug(join(' ', map { sprintf('%3s', $_) } @octets));
  # my $is_siit = $self->{ SIIT } || 0;
  return 0 if grep { $_ } @octets[ 0 .. 7 ];
  return 1;
}

sub ipv4 {
  my $self = shift;
  return join '.', unpack 'C4', substr($self->{ address }, -4);
}

sub as_n32 {
  my $self = shift;
  return unpack 'N', substr($self->{ address }, -4);
}

sub as_n128 {
  my $self = shift;
  my ($keep) = @_;
  my $rv;
  {
    eval "require Math::BigInt" or return ERROR("Could not load Math::BigInt: $@");
    my $accum = Math::BigInt->new(hex($self->normal_form));
    eval "no Math::BigInt" unless $keep;
    $rv = $keep ? $accum : "$accum";
  }
  return $rv;
}

sub normal_form {
  my $self = shift;
  my @addr = unpack('C16', $self->{ address });
  splice(@addr, 8, 4, @{$SIIT[$self->{ SIIT }]}) if $self->is_ipv4;
  my $hex = join('', map { sprintf('%02x', $_) } @addr);
  $hex = substr(('0' x 32) . $hex, -32);
  return lc $hex;
}

sub ipv6_expanded {
  my $self = shift;
  my $hex = $self->normal_form();
  my $rv;
  while ($hex =~ /(....)/g) {
    $rv .= ':' if defined $rv;
    $rv .= $1;
  }
  return $rv;
}

sub ipv6 {
  my $self = shift;
  if ($self->is_ipv4()) {
    return $self->{ SIIT }
      ? '::ffff:0:' . $self->ipv4()
      : '::ffff:' . $self->ipv4()
      ;
  }
  my $iv = $self->ipv6_expanded();
  my $rv = join(':', map { (my $x = $_) =~ s/^0+//; $x ||= '0'; $x } split ':', $iv);
  $rv =~ s/[^[:xdigit:]]0(:0)+/::/;
  $rv =~ s/::+/::/g;
  $rv =~ s/^0::/::/;
  return $rv;
}

sub as_str { return str(@_); }

sub as_string { return str(@_); }

sub str {
  my $self = shift;
  if ($self->is_ipv4()) {
    return $self->ipv4();
  }
  return $self->ipv6();
}

sub _spaceship {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  my $lhs = $self->{ address };
  $lhs = [ unpack 'N4', $lhs ];
  $rhs = eval { $rhs->{ address } } || pack('N4', (0, 0, 0, $rhs));
  $rhs = [ unpack 'N4', $rhs ];
  ($lhs, $rhs) = ($rhs, $lhs) if $swapped;
  return (1 - (2 * $swapped)) * (
    $lhs->[ 0 ] <=> $rhs->[ 0 ]
    || $lhs->[ 1 ] <=> $rhs->[ 1 ]
    || $lhs->[ 2 ] <=> $rhs->[ 2 ]
    || $lhs->[ 3 ] <=> $rhs->[ 3 ]
  );
}

sub _do_add {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  my ($pow, $mask) = $self->_pow_mask;
  my $lhs = $self->{ address };
  $lhs = [ unpack 'N4', $lhs ];
  $rhs = eval { $rhs->{ address } } || pack('N4', (0, 0, 0, $rhs));
  $rhs = [ unpack 'N4', $rhs ];
  ($lhs, $rhs) = ($rhs, $lhs) if $swapped;
  my @l = reverse @$lhs;
  my @r = reverse @$rhs;
  my @rv;
  for my $digit (0 .. 3) {
    my $answer = $l[$digit] + $r[$digit];
    if ($answer > (2 ** 32) - 1) {
      $r[$digit + 1] += int($answer / (2 ** 32)) if exists $r[$digit + 1];
      $answer = $answer % (2 ** 32);
    }
    push @rv, $answer;
  }
  my %opt;
  @opt{qw( SIIT promote )} = @$self{qw( SIIT promote )};
  @rv = $self->_mask_out($pow, $mask, reverse @rv);
  my $retval = Net::IPAddress::Util->new(\@rv, %opt);
  return $retval;
}

sub _do_subtract {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  my ($pow, $mask) = $self->_pow_mask;
  my $lhs = $self->{ address };
  $lhs = [ unpack 'N4', $lhs ];
  $rhs = eval { $rhs->{ address } } || pack('N4', (0, 0, 0, $rhs));
  $rhs = [ unpack 'N4', $rhs ];
  ($lhs, $rhs) = ($rhs, $lhs) if $swapped;
  my @l = reverse @$lhs;
  my @r = reverse @$rhs;
  my @rv;
  for my $digit (0 .. 3) {
    my $answer = $l[$digit] - $r[$digit];
    if ($answer < 0) {
      $answer += (2 ** 32) - 1;
      $r[$digit + 1] -= 1 if exists $r[$digit + 1];
    }
    push @rv, $answer;
  }
  my %opt;
  @opt{qw( SIIT promote )} = @$self{qw( SIIT promote )};
  @rv = $self->_mask_out($pow, $mask, reverse @rv);
  my $retval = Net::IPAddress::Util->new(\@rv, %opt);
  return $retval;
}

sub _shift_left {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  my ($pow, $mask) = $self->_pow_mask;
  my @l = reverse unpack('C16', $self->{ address });
  my @rv;
  for my $octet (0 .. 15) {
    $rv[$octet] += $l[$octet] << $rhs;
    if ($rv[$octet] > 255) {
      my $lsb = $rv[$octet] % 256;
      $rv[$octet + 1] += ($rv[$octet] - $lsb) >> 8 if $octet < 15;
      $rv[$octet] = $lsb;
    }
  }
  @rv = $self->_mask_out($pow, $mask, @rv);
  return Net::IPAddress::Util->new(\@rv);
}

sub _shift_right {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  my ($pow, $mask) = $self->_pow_mask;
  my @l = unpack('C16', $self->{ address });
  my @rv;
  for my $octet (0 .. 15) {
    $rv[$octet] += $l[$octet] >> $rhs;
    if (int($rv[$octet]) - $rv[$octet]) {
      my $msb = int($rv[$octet]);
      my $lsb = $rv[$octet] << $rhs;
      $rv[$octet] = $msb;
      $rv[$octet + 1] += $lsb if $octet < 15;
    }
  }
  @rv = $self->_mask_out($pow, $mask, unpack('C16', pack('N4', @rv)));
  return Net::IPAddress::Util->new(\@rv);
}

sub _band {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  ($self, $rhs) = ($rhs, $self) if $swapped;
  my $lhs = $self->{ address };
  $lhs = [ unpack 'N4', $lhs ];
  $rhs = eval { $rhs->{ address } } || pack('N4', (0, 0, 0, $rhs));
  $rhs = [ unpack 'N4', $rhs ];
  ($lhs, $rhs) = ($rhs, $lhs) if $swapped;
  my @l = @$lhs;
  my @r = @$rhs;
  my @rv;
  for my $hextet (0 .. 3) {
    $rv[$hextet] = $l[$hextet] & $r[$hextet];
  }
  return Net::IPAddress::Util->new(\@rv);
}

sub _bor {
  my $self = shift;
  my ($rhs, $swapped) = @_;
  ($self, $rhs) = ($rhs, $self) if $swapped;
  my $lhs = $self->{ address };
  $lhs = [ unpack 'N4', $lhs ];
  $rhs = eval { $rhs->{ address } } || pack('N4', (0, 0, 0, $rhs));
  $rhs = [ unpack 'N4', $rhs ];
  ($lhs, $rhs) = ($rhs, $lhs) if $swapped;
  my @l = @$lhs;
  my @r = @$rhs;
  my @rv;
  for my $hextet (0 .. 3) {
    $rv[$hextet] = $l[$hextet] | $r[$hextet];
  }
  return Net::IPAddress::Util->new(\@rv);
}

sub _neg {
  my $self = shift;
  my @n = unpack('C16', $self->{ address });
  my @rv = map { 255 - $_ } @n;
  return Net::IPAddress::Util->new(\@rv);
}

sub _pow_mask {
  my $self = shift;
  my $pow = 128;
  my $mask = pack('N4', 0, 0, 0, 0);
  if ($self->is_ipv4) {
    $pow = 32;
    $mask = pack('C16',
      0, 0, 0, 0,
      0, 0, 0, 0,
      @{$SIIT[ $self->{ SIIT } ]},
      0, 0, 0, 0,
    );
  }
  return ($pow, $mask);
}

sub _mask_out {
  my $self = shift;
  my ($pow, $mask, @rv) = @_;
  my @and = (0, 0, 0, 0);
  map { $and[ 4 - $_ ] = 0xffffffff } grep { $pow / $_ >= 32 } (1 .. 4);
  my @or = unpack('N4', $mask);
  @rv = pairwise { $a & $b } @rv, @and;
  @rv = pairwise { $a | $b } @rv, @or;
  return @rv;
}

sub ipv4_mask {
  return implode_ip(('0' x 64) . ('1' x 16) . ('0' x 16) . ('1' x 32));
}

sub ipv4_flag {
  return implode_ip(('0' x 64) . ('1' x 16) . ('0' x 48));
}

sub common_prefix (\@\@) {
  my ($x, $y) = @_;
  return ERROR("Something isn't right there") unless @$x == @$y;
  my @rv;
  for my $i (0 .. $#$x) {
    if($x->[$i] eq $y->[$i]) {
      push @rv, $x->[$i];
    }
    else {
      last;
    }
  }
  return @rv;
}

sub prefix_mask (\@\@) {
  my ($x, $y) = @_;
  return ERROR("Something isn't right there") unless @$x == @$y;
  my @rv;
  for my $i (0 .. $#$x) {
    if($x->[$i] == $y->[$i]) {
      push @rv, 1;
    }
    else {
      last;
    }
  }
  return @rv;
}

sub ip_pad_prefix (\@) {
  my @array = @{$_[0]};
  for my $i (scalar(@array) .. 127) {
    push @array, 0;
  }
  return @array;
}

sub explode_ip {
  my $ip = shift;
  return map { ~~$_ } split //, unpack 'B128', $ip->{ address };
}

sub implode_ip {
  return Net::IPAddress::Util->new([ unpack 'C16', pack 'B128', join '', map { ~~$_ } map { split // } @_ ]);
}

sub n32_to_ipv4 { local $PROMOTE_N32 = 1; return IP(@_) }

sub ERROR {
  my $msg = @_ ? shift() : 'An error has occured';
  if ($DIE_ON_ERROR) {
    confess($msg);
  }
  else {
    cluck($msg) if $^W;
  }
  return;
}

sub radix_sort (\@) {
  # In theory, a radix sort is O(N), which beats Perl's O(N log N) by
  # a fair margin. However, it _does_ discard duplicates, so ymmv.
  shift if $_[0] eq __PACKAGE__;
  my $array = shift;
  my $from = [ map { [ unpack 'C16', $_->{ address } ] } @$array ];
  my $to;
  for (my $i = 15; $i >= 0; $i--) {
    $to = [];
    for my $card (@$from) {
      push @{$to->[ $card->[ $i ] ]}, $card;
    }
    $from = [ map { @{$_ // []} } @$to ];
  }
  my @rv = map { IP(pack 'C16', @$_) } @$from;
  return @rv;
}

sub ip2num {
  carp('Compatibility function ip2num() is deprecated') if $^W;
  my $ip = shift;
  my $self = IP($ip);
  $self &= ((2 ** 32) - 1);
  return $self->as_n32();
}

sub num2ip {
  carp('Compatibility function num2ip() is deprecated') if $^W;
  my $num = shift;
  my $self = n32_to_ipv4($num);
  return $self->str();
}

sub validaddr {
  carp('Compatibility function validaddr() is deprecated') if $^W;
  my $ip = shift;
  my @octets = split(/\./, $ip);
  return unless scalar @octets == 4;
  for (@octets) {
    return unless defined $_ && $_ >= 0 && $_ <= 255;
  }
  return 1;
}

sub mask {
  carp('Compatibility function mask() is deprecated') if $^W;
  my ($ip, $mask) = @_;
  my $self = IP($ip);
  my $nm   = IP($mask);
  return $self & $nm;
}

sub fqdn {
  carp('Compatibility function fqdn() is deprecated') if $^W;
  my $dn = shift;
  return split(/\./, $dn, 2);
}

1;

__END__