File Coverage

blib/lib/NetAddr/IP/Util.pm

Criterion	Covered	Total	%
statement	24	49	48.9
branch	1	18	5.5
condition	0	6	0.0
subroutine	8	14	57.1
pod	4	4	100.0
total	37	91	40.6

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

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

use vars qw($VERSION @EXPORT_OK @ISA %EXPORT_TAGS $Mode);
use AutoLoader qw(AUTOLOAD);
use NetAddr::IP::Util_IS;
use NetAddr::IP::InetBase qw(
	:upper
	:all
);

*NetAddr::IP::Util::upper = \&NetAddr::IP::InetBase::upper;
*NetAddr::IP::Util::lower = \&NetAddr::IP::InetBase::lower;

require DynaLoader;
require Exporter;

@ISA = qw(Exporter DynaLoader);

$VERSION = do { my @r = (q$Revision: 1.51 $ =~ /\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
	hasbits
	isIPv4
	isNewIPv4
	isAnyIPv4
	inet_n2dx
	inet_n2ad
	inet_pton
	inet_ntop
	inet_4map6
	shiftleft
	addconst
	add128
	sub128
	notcontiguous
	bin2bcd
	bcd2bin
	mode
	ipv4to6
	mask4to6
	ipanyto6
	maskanyto6
	ipv6to4
	bin2bcdn
	bcdn2txt
	bcdn2bin
	simple_pack
	comp128
	packzeros
	AF_INET
	AF_INET6
	naip_gethostbyname
	havegethostbyname2
);

%EXPORT_TAGS = (
	all     => [@EXPORT_OK],
	inet	=> [qw(
		inet_aton
		inet_ntoa
		ipv6_aton
		ipv6_ntoa
		ipv6_n2x
		ipv6_n2d
		inet_any2n
		inet_n2dx
		inet_n2ad
		inet_pton
		inet_ntop
		inet_4map6
		ipv4to6
		mask4to6
		ipanyto6
		maskanyto6
		ipv6to4
		packzeros
		naip_gethostbyname
	)],
	math	=> [qw(
		shiftleft
		hasbits
		isIPv4
		isNewIPv4
		isAnyIPv4
		addconst
		add128
		sub128
		notcontiguous
		bin2bcd
		bcd2bin
	)],
	ipv4	=> [qw(
		inet_aton
		inet_ntoa
	)],
	ipv6	=> [qw(
		ipv6_aton
		ipv6_ntoa
		ipv6_n2x
		ipv6_n2d
		inet_any2n
		inet_n2dx
		inet_n2ad
		inet_pton
		inet_ntop
		inet_4map6
		ipv4to6
		mask4to6
		ipanyto6
		maskanyto6
		ipv6to4
		packzeros
		naip_gethostbyname
	)],
);

if (NetAddr::IP::Util_IS->not_pure) {
  eval {		## attempt to load 'C' version of utilities
	bootstrap NetAddr::IP::Util $VERSION;
  };
}
if (NetAddr::IP::Util_IS->pure || $@) {	## load the pure perl version if 'C' lib missing
  require NetAddr::IP::UtilPP;
  import NetAddr::IP::UtilPP qw( :all );
#  require Socket;
#  import Socket qw(inet_ntoa);
#  *yinet_aton = \&Socket::inet_aton;
  $Mode = 'Pure Perl';
}
else {
  $Mode = 'CC XS';
}

# 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 mode() { $Mode };

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

sub inet_4map6 {
  my $naddr = shift;
  if (length($naddr) == 4) {
    $naddr = ipv4to6($naddr);
  }
  elsif (length($naddr) == 16) {
    ;	# is OK
    return undef unless isAnyIPv4($naddr);
  } else {
    return undef;
  }
  $naddr |= $_newV4compat;
  return $naddr;
}

sub DESTROY {};

my $havegethostbyname2 = 0;

my $mygethostbyname;

my $_Sock6ok = 1;		# for testing gethostbyname

sub havegethostbyname2 {
  return $_Sock6ok
	? $havegethostbyname2
	: 0;
}

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

package NetAddr::IP::UtilPolluted;

# Socket pollutes the name space with all of its symbols. Since
# we don't want them all, confine them to this name space.

use strict;
use Socket;

my $_v4zero = pack('L',0);
my $_zero = pack('L4',0,0,0,0);

# invoke replacement subroutine for Perl's "gethostbyname"
# if Socket6 is available.
#
# NOTE: in certain BSD implementations, Perl's gethostbyname is broken
# we will use our own InetBase::inet_aton instead

sub _end_gethostbyname {
#  my ($name,$aliases,$addrtype,$length,@addrs) = @_;
  my @rv = @_;
# first ip address = rv[4]
  my $tip = $rv[4];
  unless ($tip && $tip ne $_v4zero && $tip ne $_zero) {
    @rv = ();
  }
# length = rv[3]
  elsif ($rv[3] && $rv[3] == 4) {
    foreach (4..$#rv) {
      $rv[$_] = NetAddr::IP::Util::inet_4map6(NetAddr::IP::Util::ipv4to6($rv[$_]));
    }
    $rv[3] = 16;	# unconditionally set length to 16
  }
  elsif ($rv[3] == 16) {
    ;	# is ok
  } else {
    @rv = ();
  }
  return @rv;
}

unless ( eval { require Socket6 }) {
  $mygethostbyname = sub {
# SEE NOTE above about broken BSD
	my @tip = gethostbyname(NetAddr::IP::InetBase::fillIPv4($_[0]));
	return &_end_gethostbyname(@tip);
  };
} else {
  import Socket6 qw( gethostbyname2 getipnodebyname );
  my $try = eval { my @try = gethostbyname2('127.0.0.1',NetAddr::IP::Util::AF_INET()); $try[4] };
  if (! $@ && $try && $try eq INADDR_LOOPBACK()) {
    *_ghbn2 = \&Socket6::gethostbyname2;
    $havegethostbyname2 = 1;
  } else {
    *_ghbn2 = sub { return () };	# use failure branch below
  }

  $mygethostbyname = sub {
	my @tip;
        unless ($_Sock6ok && (@tip = _ghbn2($_[0],NetAddr::IP::Util::AF_INET6())) && @tip > 1) {
# SEE NOTE above about broken BSD
          @tip = gethostbyname(NetAddr::IP::InetBase::fillIPv4($_[0]));
        }
	return &_end_gethostbyname(@tip);
  };
}

package NetAddr::IP::Util;

sub naip_gethostbyname {
# turn off complaint from Socket6 about missing numeric argument
  undef local $^W;
  my @rv = &$mygethostbyname($_[0]);
  return wantarray
	? @rv
	: $rv[4];
}

1;

__END__