File Coverage

blib/lib/NetAddr/IP/InetBase.pm

Criterion	Covered	Total	%
statement	52	65	80.0
branch	13	30	43.3
condition	7	48	14.5
subroutine	15	19	78.9
pod	10	10	100.0
total	97	172	56.4

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

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

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

@ISA = qw(Exporter);

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

@EXPORT_OK = qw(
	inet_aton
	inet_ntoa
	ipv6_aton
	ipv6_ntoa
	ipv6_n2x
	ipv6_n2d
	inet_any2n
	inet_n2dx
	inet_n2ad
	inet_ntop
	inet_pton
	packzeros
	isIPv4
	isNewIPv4
	isAnyIPv4
	AF_INET
	AF_INET6
	fake_AF_INET6
	fillIPv4
);

%EXPORT_TAGS = (
	all     => [@EXPORT_OK],
	ipv4	=> [qw(
		inet_aton
		inet_ntoa
		fillIPv4
	)],
	ipv6	=> [qw(
		ipv6_aton
		ipv6_ntoa
		ipv6_n2x
		ipv6_n2d
		inet_any2n
		inet_n2dx
		inet_n2ad
		inet_pton
		inet_ntop
		packzeros
	)],
);

# prototypes
sub inet_ntoa;
sub ipv6_aton;
sub ipv6_ntoa;
sub inet_any2n($);
sub inet_n2dx($);
sub inet_n2ad($);
sub _inet_ntop;
sub _inet_pton;

my $emulateAF_INET6 = 0;

{ no warnings 'once';

*packzeros = \&_packzeros;

## dynamic configuraton for IPv6

require Socket;

*AF_INET = \&Socket::AF_INET;

if (eval { AF_INET6() } ) {
  *AF_INET6 = \&Socket::AF_INET6;
  $emulateAF_INET6 = -1;			# have it, remind below
}
if (eval{ require Socket6 } ) {
  import Socket6 qw(
	inet_pton
	inet_ntop
  );
  unless ($emulateAF_INET6) {
    *AF_INET6 = \&Socket6::AF_INET6;
  }
  $emulateAF_INET6 = 0;				# clear, have it from elsewhere or here
} else {
  unless ($emulateAF_INET6) {	# unlikely at this point
    if ($^O =~ /(?:free|dragon.+)bsd/i) {	# FreeBSD, DragonFlyBSD
	$emulateAF_INET6 = 28;
    } elsif ($^O =~ /bsd/i) {		# other BSD flavors like NetBDS, OpenBSD, BSD
	$emulateAF_INET6 = 24;
    } elsif ($^O =~ /(?:darwin|mac)/i) {	# Mac OS X
	$emulateAF_INET6 = 30;
    } elsif ($^O =~ /win/i) {		# Windows
	$emulateAF_INET6 = 23;
    } elsif ($^O =~ /(?:solaris|sun)/i) {		# Sun box
	$emulateAF_INET6 = 26;
    } else {					# use linux default
	$emulateAF_INET6 = 10;
    }
    *AF_INET6 = sub { $emulateAF_INET6; };
  } else {
    $emulateAF_INET6 = 0;			# clear, have it from elsewhere
  }
  *inet_pton = \&_inet_pton;
  *inet_ntop = \&_inet_ntop;
}

} # end no warnings 'once'

sub fake_AF_INET6 {
  return $emulateAF_INET6;
}

# allow user to choose upper or lower case
BEGIN {
  use vars qw($n2x_format $n2d_format);
  $n2x_format = "%x:%x:%x:%x:%x:%x:%x:%x";
  $n2d_format = "%x:%x:%x:%x:%x:%x:%d.%d.%d.%d";
}

my $case = 0;	# default lower case

sub upper { $n2x_format = uc($n2x_format); $n2d_format = uc($n2d_format); $case = 1; }
sub lower { $n2x_format = lc($n2x_format); $n2d_format = lc($n2d_format); $case = 0; }

sub ipv6_n2x {
  die "Bad arg length for 'ipv6_n2x', length is ". length($_[0]) ." should be 16"
	unless length($_[0]) == 16;
  return sprintf($n2x_format,unpack("n8",$_[0]));
}

sub ipv6_n2d {
  die "Bad arg length for 'ipv6_n2d', length is ". length($_[0]) ." should be 16"
	unless length($_[0]) == 16;
  my @hex = (unpack("n8",$_[0]));
  $hex[9] = $hex[7] & 0xff;
  $hex[8] = $hex[7] >> 8;
  $hex[7] = $hex[6] & 0xff;
  $hex[6] >>= 8;
  return sprintf($n2d_format,@hex);
}

# if Socket lib is broken in some way, check for overange values
#
#my $overange = yinet_aton('256.1') ? 1:0;
#my $overange = gethostbyname('256.1') ? 1:0;

#sub inet_aton {
#  unless (! $overange || $_[0] =~ /[^0-9\.]/) {	# hostname
#    my @dq = split(/\./,$_[0]);
#    foreach (@dq) {
#      return undef if $_ > 255;
#    }
#  }
#  scalar gethostbyname($_[0]);
#}

sub fillIPv4 {
  my $host = $_[0];
  return undef unless defined $host;
  if ($host =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/) {
    if (defined $4) {
      return undef unless
        $1 >= 0 && $1 < 256 &&
        $2 >= 0 && $2 < 256 &&
        $3 >= 0 && $3 < 256 &&
        $4 >= 0 && $4 < 256;
      $host = $1.'.'.$2.'.'.$3.'.'.$4;
#      return pack('C4',$1,$2,$3,$4);
#      $host = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4;
    } elsif (defined $3) {
      return undef unless
        $1 >= 0 && $1 < 256 &&
        $2 >= 0 && $2 < 256 &&
        $3 >= 0 && $3 < 256;
      $host = $1.'.'.$2.'.0.'.$3
#      return pack('C4',$1,$2,0,$3);
#      $host = ($1 << 24) + ($2 << 16) + $3;
    } elsif (defined $2) {
      return undef unless
        $1 >= 0 && $1 < 256 &&
        $2 >= 0 && $2 < 256;
      $host = $1.'.0.0.'.$2;
#      return pack('C4',$1,0,0,$2);
#      $host = ($1 << 24) + $2;
    } else {
      $host = '0.0.0.'.$1;
#      return pack('C4',0,0,0,$1);
#      $host = $1;
    }
#    return pack('N',$host);
  }
  $host;
}

sub inet_aton {
  my $host = fillIPv4($_[0]);
  return $host ? scalar gethostbyname($host) : undef;
}

#sub inet_aton {
#  my $host = $_[0];
#  return undef unless defined $host;
#  if ($host =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/) {
#    if (defined $4) {
#      return undef unless
#        $1 >= 0 && $1 < 256 &&
#        $2 >= 0 && $2 < 256 &&
#        $3 >= 0 && $3 < 256 &&
#        $4 >= 0 && $4 < 256;
#      return pack('C4',$1,$2,$3,$4);
##      $host = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4;
#    } elsif (defined $3) {
#      return undef unless
#        $1 >= 0 && $1 < 256 &&
#        $2 >= 0 && $2 < 256 &&
#        $3 >= 0 && $3 < 256;
#      return pack('C4',$1,$2,0,$3);
##      $host = ($1 << 24) + ($2 << 16) + $3;
#    } elsif (defined $2) {
#      return undef unless
#        $1 >= 0 && $1 < 256 &&
#        $2 >= 0 && $2 < 256;
#      return pack('C4',$1,0,0,$2);
##      $host = ($1 << 24) + $2;
#    } else {
#      return pack('C4',0,0,0,$1);
##      $host = $1;
#    }
##    return pack('N',$host);
#  }
#  scalar gethostbyname($host);
#}

my $_zero = pack('L4',0,0,0,0);
my $_ipv4mask = pack('L4',0xffffffff,0xffffffff,0xffffffff,0);

sub isIPv4 {
  if (length($_[0]) != 16) {
    my $sub = (caller(1))[3] || (caller(0))[3];
    die "Bad arg length for $sub, length is ". (length($_[0]) *8) .", should be 128";
  }
  return ($_[0] & $_ipv4mask) eq $_zero
	? 1 : 0;
}

my $_newV4compat = pack('N4',0,0,0xffff,0);

sub isNewIPv4 {
  my $naddr = $_[0] ^ $_newV4compat;
  return isIPv4($naddr);
}

sub isAnyIPv4 {
  my $naddr = $_[0];
  my $rv = isIPv4($_[0]);
  return $rv if $rv;
  return isNewIPv4($naddr);
}

sub DESTROY {};

sub import {
  if (grep { $_ eq ':upper' } @_) {
	upper();
	@_ = grep { $_ ne ':upper' } @_;
  }
  NetAddr::IP::InetBase->export_to_level(1,@_);
}

1;

__END__