NetAddr::IP::UtilPP - pure Perl functions for NetAddr::IP::Util

  use NetAddr::IP::UtilPP qw(
	hasbits
	isIPv4
	shiftleft
	addconst
	add128
	sub128
	notcontiguous
	ipv4to6
	mask4to6
	ipanyto6
	maskanyto6
	ipv6to4
	bin2bcd
	bcd2bin
  );

  use NetAddr::IP::UtilPP qw(:all)

  $rv = hasbits($bits128);
  $rv = isIPv4($bits128);
  $bitsX2 = shiftleft($bits128,$n);
  $carry = addconst($ipv6naddr,$signed_32con);
  ($carry,$ipv6naddr)=addconst($ipv6naddr,$signed_32con);
  $carry = add128($ipv6naddr1,$ipv6naddr2);
  ($carry,$ipv6naddr)=add128($ipv6naddr1,$ipv6naddr2);
  $carry = sub128($ipv6naddr1,$ipv6naddr2);
  ($spurious,$cidr) = notcontiguous($mask128);
  ($carry,$ipv6naddr)=sub128($ipv6naddr1,$ipv6naddr2);
  $ipv6naddr = ipv4to6($netaddr);
  $ipv6naddr = mask4to6($netaddr);
  $ipv6naddr = ipanyto6($netaddr);
  $ipv6naddr = maskanyto6($netaddr);
  $netaddr = ipv6to4($pv6naddr);
  $bcdtext = bin2bcd($bits128);
  $bits128 = bcd2bin($bcdtxt);

	hasbits
	isIPv4
	shiftleft
	addconst
	add128
	sub128
	notcontiguous
	ipv4to6
	mask4to6
	ipanyto6
	maskanyto6
	ipv6to4
	bin2bcd
	bcd2bin
	comp128
	bin2bcdn
	bcdn2txt
	bcdn2bin
	simple_pack
	threads

#!/usr/bin/perl
package NetAddr::IP::UtilPP;

use strict;
#use diagnostics;
#use lib qw(blib lib);

use AutoLoader qw(AUTOLOAD);
use vars qw($VERSION @EXPORT_OK @ISA %EXPORT_TAGS);
require Exporter;


@ISA = qw(Exporter);

$VERSION = do { my @r = (q$Revision: 1.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

@EXPORT_OK = qw(
	hasbits
	isIPv4
	shiftleft
	addconst
	add128
	sub128
	notcontiguous
	ipv4to6
	mask4to6
	ipanyto6
	maskanyto6
	ipv6to4
	bin2bcd
	bcd2bin
	comp128
	bin2bcdn
	bcdn2txt
	bcdn2bin
	simple_pack
);

%EXPORT_TAGS = (
	all	=> [@EXPORT_OK],
);

sub DESTROY {};

1;
__END__

sub _deadlen {
  my($len,$should) = @_;
  $len *= 8;
  $should = 128 unless $should;
  my $sub = (caller(1))[3];
  die "Bad argument length for ".__PACKAGE__.":$sub, is $len, should be $should";
}

sub hasbits {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  return 1 if vec($_[0],3,32);
  return (isIPv4($_[0])) ? 0 : 1;
}

sub isIPv4 {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  return 0 if vec($_[0],0,32);
  return 0 if vec($_[0],1,32);
  return 0 if vec($_[0],2,32);
  return 1;
}

# multiply x 2
#
sub _128x2 {
  my $inp = shift;
  $$inp[0] = ($$inp[0] << 1 & 0xffffffff) + (($$inp[1] & 0x80000000) ? 1:0);
  $$inp[1] = ($$inp[1] << 1 & 0xffffffff) + (($$inp[2] & 0x80000000) ? 1:0);
  $$inp[2] = ($$inp[2] << 1 & 0xffffffff) + (($$inp[3] & 0x80000000) ? 1:0);
  $$inp[3] = $$inp[3] << 1 & 0xffffffff;
}

# multiply x 10
#
sub _128x10 {
  my($a128p) = @_;
  _128x2($a128p);		# x2
  my @x2 = @$a128p;		# save the x2 value
  _128x2($a128p);
  _128x2($a128p);		# x8
  _sa128($a128p,\@x2,0);	# add for x10
}

sub shiftleft {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  my($bits,$shifts) = @_;
  return $bits unless $shifts;
  die "Bad arg value for ".__PACKAGE__.":shiftleft, length should be 0 thru 128"
	if $shifts < 0 || $shifts > 128;
  my @uint32t = unpack('N4',$bits);
  do {
    $bits = _128x2(\@uint32t);
    $shifts--
  } while $shifts > 0;
   pack('N4',@uint32t);
}

sub slowadd128 {
  my @ua = unpack('N4',$_[0]);
  my @ub = unpack('N4',$_[1]);
  my $carry = _sa128(\@ua,\@ub,$_[2]);
  return ($carry,pack('N4',@ua))
        if wantarray;
  return $carry;
}

sub _sa128 {
  my($uap,$ubp,$carry) = @_;
  if (($$uap[3] += $$ubp[3] + $carry) > 0xffffffff) {
    $$uap[3] -= 4294967296;	# 0x1_00000000
    $carry = 1;
  } else {
    $carry = 0;
  }

  if (($$uap[2] += $$ubp[2] + $carry) > 0xffffffff) {
    $$uap[2] -= 4294967296;
    $carry = 1;
  } else {
    $carry = 0;
  }

  if (($$uap[1] += $$ubp[1] + $carry) > 0xffffffff) {
    $$uap[1] -= 4294967296;
    $carry = 1;
  } else {
    $carry = 0;
  }

  if (($$uap[0] += $$ubp[0] + $carry) > 0xffffffff) {
    $$uap[0] -= 4294967296;
    $carry = 1;
  } else {
    $carry = 0;
  }
  $carry;
}

sub addconst {
  my($a128,$const) = @_;
  _deadlen(length($a128))
	if length($a128) != 16;
  unless ($const) {
    return (wantarray) ? ($const,$a128) : $const;
  }
  my $sign = ($const < 0) ? 0xffffffff : 0;
  my $b128 = pack('N4',$sign,$sign,$sign,$const);
  @_ = ($a128,$b128,0);
# perl 5.8.4 fails with this operation. see perl bug [ 23429]
#  goto &slowadd128;
  slowadd128(@_);
}

sub add128 {
  my($a128,$b128) = @_;
  _deadlen(length($a128))
	if length($a128) != 16;
  _deadlen(length($b128))
	if length($b128) != 16;
  @_ = ($a128,$b128,0);
# perl 5.8.4 fails with this operation. see perl bug [ 23429]
#  goto &slowadd128;
  slowadd128(@_);
}

sub sub128 {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  _deadlen(length($_[1]))
	if length($_[1]) != 16;
  my $a128 = $_[0];
  my $b128 = ~$_[1];
  @_ = ($a128,$b128,1);
# perl 5.8.4 fails with this operation. see perl bug [ 23429]
#  goto &slowadd128;
  slowadd128(@_);
}

sub notcontiguous {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  my @ua = unpack('N4', ~$_[0]);
  my $count;
  for ($count = 128;$count > 0; $count--) {
	last unless $ua[3] & 1;
	$ua[3] >>= 1;
	$ua[3] |= 0x80000000 if $ua[2] & 1;
	$ua[2] >>= 1;
	$ua[2] |= 0x80000000 if $ua[1] & 1;
	$ua[1] >>= 1;
	$ua[1] |= 0x80000000 if $ua[0] & 1;
	$ua[0] >>= 1;
  }

  my $spurious = $ua[0] | $ua[1] | $ua[2] | $ua[3];
  return $spurious unless wantarray;
  return ($spurious,$count);
}

sub ipv4to6 {
  _deadlen(length($_[0]),32)
        if length($_[0]) != 4;
#  return pack('L3H8',0,0,0,unpack('H8',$_[0]));
  return pack('L3a4',0,0,0,$_[0]);
}

sub mask4to6 {
  _deadlen(length($_[0]),32)
        if length($_[0]) != 4;
#  return pack('L3H8',0xffffffff,0xffffffff,0xffffffff,unpack('H8',$_[0]));
  return pack('L3a4',0xffffffff,0xffffffff,0xffffffff,$_[0]);
}

sub ipanyto6 {
  my $naddr = shift;
  my $len = length($naddr);
  return $naddr if $len == 16;
#  return pack('L3H8',0,0,0,unpack('H8',$naddr))
  return pack('L3a4',0,0,0,$naddr)
	if $len == 4;
  _deadlen($len,'32 or 128');
}

sub maskanyto6 {
  my $naddr = shift;
  my $len = length($naddr);
  return $naddr if $len == 16;
#  return pack('L3H8',0xffffffff,0xffffffff,0xffffffff,unpack('H8',$naddr))
  return pack('L3a4',0xffffffff,0xffffffff,0xffffffff,$naddr)
	if $len == 4;
  _deadlen($len,'32 or 128');
}

sub ipv6to4 {
  my $naddr = shift;
_deadlen(length($naddr))
	if length($naddr) != 16;
  @_ = unpack('L3H8',$naddr);
  return pack('H8',@{_}[3..10]);
}

sub bin2bcd {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  unpack("H40",&_bin2bcdn) =~ /^0*(.+)/;
  $1;
}

sub bcd2bin {
  &_bcdcheck;
# perl 5.8.4 fails with this operation. see perl bug [ 23429]
#  goto &_bcd2bin;
  &_bcd2bin;
}

#=item * $onescomp = comp128($ipv6addr);
#
#This function is for testing, it is more efficient to use perl " ~ "
#on the bit string directly. This interface to the B<C> routine is published for
#module testing purposes because it is used internally in the B<sub128> routine. The
#function is very fast, but calling if from perl directly is very slow. It is almost
#33% faster to use B<sub128> than to do a 1's comp with perl and then call
#B<add128>. In the PurePerl version, it is a call to
#
#  sub {return ~ $_[0]};
#
#=cut

sub comp128 {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
  return ~ $_[0];
}

#=item * $bcdpacked = bin2bcdn($bits128);
#
#Convert a 128 bit binary string into binary coded decimal digits.
#This function is for testing only.
#
#  input:	128 bit string variable
#  returns:	string of packed decimal digits
#
#  i.e.	text = unpack("H*", $bcd);
#
#=cut

sub bin2bcdn {
  _deadlen(length($_[0]))
	if length($_[0]) != 16;
# perl 5.8.4 fails with this operation. see perl bug [ 23429]
#  goto &_bin2bcdn;
  &_bin2bcdn;
}

sub _bin2bcdn {
  my($b128) = @_;
  my @binary = unpack('N4',$b128);
  my @nbcd = (0,0,0,0,0);	# 5 - 32 bit registers
  my ($add3, $msk8, $bcd8, $carry, $tmp);
  my $j = 0;
  my $k = -1;
  my $binmsk = 0;
  foreach(0..127) {
    unless ($binmsk) {
      $binmsk = 0x80000000;
      $k++;
    }
    $carry = $binary[$k] & $binmsk;
    $binmsk >>= 1;
    next unless $carry || $j;				# skip leading zeros
    foreach(4,3,2,1,0) {
      $bcd8 = $nbcd[$_];
      $add3 = 3;
      $msk8 = 8;

      $j = 0;
      while ($j < 8) {
	$tmp = $bcd8 + $add3;
	if ($tmp & $msk8) {
	  $bcd8 = $tmp;
	}
	$add3 <<= 4;
	$msk8 <<= 4;
	$j++;
      }
      $tmp = $bcd8 & 0x80000000;	# propagate carry
      $bcd8 <<= 1;			# x2
      if ($carry) {
	$bcd8 += 1;
      }
      $nbcd[$_] = $bcd8;
      $carry = $tmp;
    }
  }
  pack('N5',@nbcd);
}

#=item * $bcdtext = bcdn2txt($bcdpacked);
#
#Convert a packed bcd string into text digits, suppress the leading zeros.
#This function is for testing only.
#
#  input:	string of packed decimal digits
#		consisting of exactly 40 digits
#  returns:	hexdecimal digits
#
#Similar to unpack("H*", $bcd);
#
#=cut

sub bcdn2txt {
  die "Bad argument length for ".__PACKAGE__.":bcdn2txt, is ".(2 * length($_[0])).", should be exactly 40 digits"
	if length($_[0]) != 20;
  (unpack('H40',$_[0])) =~ /^0*(.+)/;
  $1;
}

#=item * $bits128 = bcdn2bin($bcdpacked,$ndigits);
#
# Convert a packed bcd string into a 128 bit string variable
#
# input:	packed bcd string
#		number of digits in string
# returns:	128 bit string variable
#

sub bcdn2bin {
  my($bcd,$dc) = @_;
  $dc = 0 unless $dc;
  die "Bad argument length for ".__PACKAGE__.":bcdn2txt, is ".(2 * length($bcd)).", should be 1 to 40 digits"
	if length($bcd) > 20;
  die "Bad digit count for ".__PACKAGE__.":bcdn2bin, is $dc, should be 1 to 40 digits"
	if $dc < 1 || $dc > 40;
  return _bcd2bin(unpack("H$dc",$bcd));
}

sub _bcd2bin {
  my @bcd = split('',$_[0]);
  my @hbits = (0,0,0,0);
  my @digit = (0,0,0,0);
  my $found = 0;
  foreach(@bcd) {
    my $bcd = $_ & 0xf;		# just the nibble
    unless ($found) {
      next unless $bcd;		# skip leading zeros
      $found = 1;
      $hbits[3] = $bcd;		# set the first digit, no x10 necessary
      next;
    }
    _128x10(\@hbits);
    $digit[3] = $bcd;
    _sa128(\@hbits,\@digit,0);
  }
  return pack('N4',@hbits);
}

#=item * $bcdpacked = simple_pack($bcdtext);
#
#Convert a numeric string into a packed bcd string, left fill with zeros
#This function is for testing only.
#
#  input:	string of decimal digits
#  returns:	string of packed decimal digits
#
#Similar to pack("H*", $bcdtext);
#
sub _bcdcheck {
  my($bcd) = @_;;
  my $sub = (caller(1))[3];
  my $len = length($bcd);
  die "Bad bcd number length $_ ".__PACKAGE__.":simple_pack, should be 1 to 40 digits"
	if $len > 40 || $len < 1;
  die "Bad character in decimal input string '$1' for ".__PACKAGE__.":simple_pack"
	if $bcd =~ /(\D)/;
}

sub simple_pack {
  &_bcdcheck;
  my($bcd) = @_;
  while (length($bcd) < 40) {
    $bcd = '0'. $bcd;
  }
  return pack('H40',$bcd);
}

1;