File Coverage

blib/lib/Net/Frame/Layer.pm

Criterion	Covered	Total	%
statement	109	194	56.1
branch	20	56	35.7
condition			n/a
subroutine	28	42	66.6
pod	23	23	100.0
total	180	315	57.1

#
# $Id: Layer.pm,v ce68fbcc7f6d 2019/05/23 05:58:40 gomor $
#
package Net::Frame::Layer;
use strict;
use warnings;

require Class::Gomor::Array;
require Exporter;
our @ISA = qw(Class::Gomor::Array Exporter);

our %EXPORT_TAGS = (
   consts => [qw(
      NF_LAYER_NONE
      NF_LAYER_UNKNOWN
      NF_LAYER_NOT_AVAILABLE
   )],
   subs => [qw(
      getHostIpv4Addr
      getHostIpv4Addrs
      getHostIpv6Addr
      inetAton
      inetNtoa
      inet6Aton
      inet6Ntoa
      getRandomHighPort
      getRandom32bitsInt
      getRandom16bitsInt
      convertMac
      inetChecksum
   )],
);
our @EXPORT_OK = (
   @{$EXPORT_TAGS{consts}},
   @{$EXPORT_TAGS{subs}},
);

use constant NF_LAYER_NONE          => 0;
use constant NF_LAYER_UNKNOWN       => 1;
use constant NF_LAYER_NOT_AVAILABLE => 2;

our @AS = qw(
   raw
   payload
   nextLayer
);
__PACKAGE__->cgBuildIndices;
__PACKAGE__->cgBuildAccessorsScalar(\@AS);

no strict 'vars';

use Carp;

sub new { shift->SUPER::new(nextLayer => NF_LAYER_NONE, @_) }

sub layer {
   my $layer = ref(shift);
   $layer =~ s/^Net::Frame::Layer:://;
   $layer;
}

# XXX: may use some optimizations
sub pack {
   my $self = shift;
   my ($fmt, @args) = @_;
   my $res;
   eval { $res = CORE::pack($fmt, @args) };
   $@ ? do { carp("@{[ref($self)]}: unable to pack structure\n"); undef }
      : $res;
}

sub unpack {
   my $self = shift;
   my ($fmt, $arg) = @_;
   my @res;
   eval { @res = CORE::unpack($fmt, $arg) };
   $@ ? do { carp("@{[ref($self)]}: unable to unpack structure\n"); () }
      : @res;
}

sub getPayloadLength {
   my $self = shift;
   $self->payload ? length($self->payload) : 0;
}

sub encapsulate      { shift->nextLayer              }
sub computeLengths   { 1                             }
sub computeChecksums { 1                             }
sub print            { $self->layer.': to implement' }
sub getLength        { 0                             }

sub dump { CORE::unpack('H*', shift->raw) }

#
# Useful subroutines
#

# Load AF_INET and default imports from Socket. Safe back to at least 5.8.8.
use Socket qw(:DEFAULT AF_INET);

sub _setInet6Sub {
   no strict 'refs';

   my $inetp_found = 0;

   # Check Socket against some IPv6 functions and constants.
   eval {
      require Socket;
      Socket->import(qw(AF_INET6 inet_pton inet_ntop));
   };
   if (! $@) {   # Socket has support for required functions and constants.
      *{__PACKAGE__.'::_inet_pton'} = \&Socket::inet_pton;
      *{__PACKAGE__.'::_inet_ntop'} = \&Socket::inet_ntop;

      $inetp_found = 1;
   }

   # Fallback to Socket6
   if (! $inetp_found) {
      eval {
         require Socket6;
         Socket6->import(qw(AF_INET6 inet_pton inet_ntop));
      };
      if (! $@) {   # Socket6 has support for required functions and constants.
         *{__PACKAGE__.'::_inet_pton'} = \&Socket6::inet_pton;
         *{__PACKAGE__.'::_inet_ntop'} = \&Socket6::inet_ntop;
      }
   }

   # Unfortunately, we have to test if inet_ntop()/inet_pton() works (i.e., are implemented)
   # If no support for inet_ntop/inet_pton, we branch to fake functions.
   if ($inetp_found) {
      eval {
         # inet_pton() may exist, but die with:
         # inet_pton not implemented on this architecture
         _inet_pton(AF_INET6(), "::1");
      };
      if ($@) {
         print "[!] inet_pton support: $@\n";
         *{__PACKAGE__.'::_inet_pton'} = sub { return 0; };
         *{__PACKAGE__.'::_inet_ntop'} = sub { return 0; };
      }
      else {
         return 1;   # OK
      }
   }

   die("[-] Net::Frame: inet_pton/inet_ntop: not supported by Socket nor Socket6: ".
       "try upgrading your Perl version or Socket/Socket6 modules.\n");
}

sub _setGetAddressSub {
   no strict 'refs';

   my $getaddr_found = 0;

   # Check Socket against some IPv6 functions and constants.
   eval {
      require Socket;
      Socket->import(qw(getaddrinfo getnameinfo AF_INET6));
   };
   if (! $@) {   # Socket has support for required functions and constants.
      *{__PACKAGE__.'::_getAddress'} = sub {
         my ($name) = @_;

         #print STDERR "*** Socket supports IPv6 OK\n";

         my %hints = (
            family => Socket::AF_INET6(),
         );
         my ($err, @res) = Socket::getaddrinfo($name, '', \%hints);
         if ($err) {
            carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname: getaddrinfo: $err\n");
            return;
         }
         if (@res > 0) {
            my $h = $res[0];
            my ($err, $ipv6) = Socket::getnameinfo(
               $h->{addr}, Socket::NI_NUMERICHOST() | Socket::NI_NUMERICSERV()
            );
            if ($err) {
               carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname: getnameinfo: $err\n");
               return;
            }

            return $ipv6;
         }
         else {
            carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname: getaddrinfo: $!\n");
            return;
         }
      };

      $getaddr_found = 1;
   }

   # Fallback to Socket6
   if (! $getaddr_found) {
      eval {
         require Socket6;
         Socket6->import(qw(getaddrinfo getnameinfo AF_INET6));
      };
      if (! $@) {   # Socket6 has support for required functions and constants.
         *{__PACKAGE__.'::_getAddress'} = sub {
            my ($name) = @_;

            #print STDERR "*** Fallback to Socket6 support\n";

            my @res = Socket6::getaddrinfo($name, '', Socket6::AF_INET6(), SOCK_STREAM);
            if (@res >= 5) {
               my ($ipv6) = Socket6::getnameinfo(
                  $res[3], Socket6::NI_NUMERICHOST() | Socket6::NI_NUMERICSERV()
               );

               return $ipv6;
            }
         };
      }

      $getaddr_found = 1;
   }

   # Unfortunately, we have to test if INET6 family is supported
   # If no support, we branch to fake functions.
   if ($getaddr_found) {
      eval {
         # getaddrinfo() may exist, but die with:
         # getaddrinfo: ai_family not supported
         _getAddress("::1");
      };
      if ($@) {
         print "[!] getaddrinfo support: $@\n";
         *{__PACKAGE__.'::_getAddress'} = sub { return 0; };
         *{__PACKAGE__.'::_getAddress'} = sub { return 0; };
      }
      else {
         return 1;   # OK
      }
   }

   die("[-] Net::Frame: getaddrinfo/getnameinfo: not supported by Socket nor Socket6: ".
       "try upgrading your Perl version or Socket/Socket6 modules.\n");
}

BEGIN {
   _setInet6Sub();
   _setGetAddressSub();
}

require Net::IPv6Addr;

sub getHostIpv4Addr {
   my ($name) = @_;

   # No address given
   if (! defined($name)) {
      return;
   }

   # Already an IPv4 address
   if ($name =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
      return $name;
   }

   my @addrs = (gethostbyname($name))[4];
   @addrs ? return join('.', CORE::unpack('C4', $addrs[0]))
          : carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname\n");

   # Error
   return;
}

sub getHostIpv4Addrs {
   my ($name) = @_;

   # No address given
   if (! defined($name)) {
      return;
   }

   # Already an IPv4 address
   if ($name =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
      return $name;
   }

   my @addrs = (gethostbyname($name))[4];
   @addrs ? return @addrs
          : carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname\n");

   # Error
   return ();
}

sub getHostIpv6Addr {
   my ($name) = @_;

   # No address given
   if (! defined($name)) {
      return;
   }

   # Already an IPv6 address
   if (Net::IPv6Addr::is_ipv6($name)) {
      return $name;
   }

   my $ipv6 = _getAddress($name);
   if (! defined($ipv6)) {
      carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname\n");
      return;
   }

   $ipv6 =~ s/%.*$//;

   return $ipv6;
}

sub inetAton  { Socket::inet_aton(shift()) }
sub inetNtoa  { Socket::inet_ntoa(shift()) }
sub inet6Aton { _inet_pton(AF_INET6, shift()) }
sub inet6Ntoa { _inet_ntop(AF_INET6, shift()) }

sub getRandomHighPort {
   my $highPort = int rand 0xffff;
   $highPort += 1024 if $highPort < 1025;
   $highPort;
}

sub getRandom32bitsInt { int rand 0xffffffff }
sub getRandom16bitsInt { int rand 0xffff     }

sub convertMac {
   return lc(join(':', $_[0] =~ /../g));
}

sub inetChecksum {
   my ($phpkt) = @_;

   $phpkt      .= "\x00" if length($phpkt) % 2;
   my $len      = length $phpkt;
   my $nshort   = $len / 2;
   my $checksum = 0;
   $checksum   += $_ for CORE::unpack("S$nshort", $phpkt);
   # XXX: This line never does anything as the lenth was made even above. Currently testing it breaks nothing.
   #$checksum   += CORE::unpack('C', substr($phpkt, $len - 1, 1)) if $len % 2;
   $checksum    = ($checksum >> 16) + ($checksum & 0xffff);

   CORE::unpack('n',
      CORE::pack('S', ~(($checksum >> 16) + $checksum) & 0xffff),
   );
}

1;

__END__