File Coverage

blib/lib/IO/Socket/Packet.pm

Criterion	Covered	Total	%
statement	62	131	47.3
branch	14	58	24.1
condition	5	7	71.4
subroutine	16	28	57.1
pod	18	19	94.7
total	115	243	47.3

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2009-2020 -- [e-mail]

package IO::Socket::Packet;

use strict;
use warnings;
use base qw( IO::Socket );

our $VERSION = '0.11';

use Carp;

use POSIX qw( EAGAIN );
use Socket qw( AF_INET SOCK_STREAM SOCK_RAW );

use Socket::Packet qw(
   AF_PACKET ETH_P_ALL
   pack_sockaddr_ll unpack_sockaddr_ll
   pack_packet_mreq
   unpack_tpacket_stats
   siocgstamp siocgstampns
   siocgifindex siocgifname
   recv_len

   SOL_PACKET

   PACKET_ADD_MEMBERSHIP
   PACKET_DROP_MEMBERSHIP
   PACKET_STATISTICS

   PACKET_MR_MULTICAST
   PACKET_MR_PROMISC
   PACKET_MR_ALLMULTI
);

__PACKAGE__->register_domain( AF_PACKET );

=head1 NAME

C - Object interface to C domain sockets

=head1 SYNOPSIS

   use IO::Socket::Packet;
   use Socket::Packet qw( unpack_sockaddr_ll );

   my $sock = IO::Socket::Packet->new( IfIndex => 0 );

   while( my ( $protocol, $ifindex, $hatype, $pkttype, $addr ) =
      $sock->recv_unpack( my $packet, 8192, 0 ) ) {

      ...
   }

=head1 DESCRIPTION

This class provides an object interface to C sockets on Linux. It
is built upon L and inherits all the methods defined by this base
class.

=cut

=head1 CONSTRUCTOR

=cut

=head2 new

   $sock = IO::Socket::Packet->new( %args )

Creates a new C object. If any arguments are passed it
will be configured to contain a newly created socket handle, and be Ced
as required by the arguments. The recognised arguments are:

=over 8

=item Type => INT

The socktype to use; should be either C or C. It not
supplied a default of C will be used.

=item Protocol => INT

Ethernet protocol number to bind to. To capture all protocols, use the
C constant (or omit this key, which implies that as a default).

=item IfIndex => INT

If supplied, binds the socket to the specified interface index. To bind to all
interfaces, use 0 (or omit this key, which implies that as a default).

=item IfName => STRING

If supplied, binds the socket to the interface with the specified name.

=back

=cut

sub configure
{
   my $self = shift;
   my ( $arg ) = @_;

   my $type = $arg->{Type} || SOCK_RAW;

   $self->socket( AF_PACKET, $type, 0 ) or return undef;

   # bind() arguments
   my ( $protocol, $ifindex );

   $protocol = $arg->{Protocol} if exists $arg->{Protocol};
   $ifindex  = $arg->{IfIndex}  if exists $arg->{IfIndex};

   if( !defined $ifindex and exists $arg->{IfName} ) {
      $ifindex = siocgifindex( $self, $arg->{IfName} );
      defined $ifindex or return undef;
   }

   $self->bind( pack_sockaddr_ll(
         defined $protocol ? $protocol : ETH_P_ALL,
         $ifindex || 0,
         0, 0, '' ) ) or return undef;

   return $self;
}

=head1 METHODS

=cut

=head2 recv_len

   ( $addr, $len ) = $sock->recv_len( $buffer, $maxlen, $flags )

Similar to Perl's C builtin, except it returns the packet length as an
explict return value. This may be useful if C<$flags> contains the
C flag, obtaining the true length of the packet on the wire, even
if this is longer than the data written in the buffer.

=cut

# don't actually need to implement it; the imported symbol works fine

=head2 recv_unpack

   ( $protocol, $ifindex, $hatype, $pkttype, $addr, $len ) =
      $sock->recv_unpack( $buffer, $size, $flags )

This method is a combination of C and C. If it
successfully receives a packet, it unpacks the address and returns the fields
from it, and the length of the received packet. If it fails, it returns an
empty list.

If the ring-buffer has been set using C, it will automatically
be used by this method.

=cut

sub recv_unpack
{
   my $self = shift;

   if( defined ${*$self}{packet_rx_ring} ) {
      defined $self->wait_ring_frame( my $buffer, \my %info ) or return;

      # Copy to caller
      $_[0] = $buffer;

      $self->done_ring_frame;

      ${*$self}{packet_ts_sec}  = $info{tp_sec};
      ${*$self}{packet_ts_nsec} = $info{tp_nsec};

      return ( $info{sll_protocol},
               $info{sll_ifindex},
               $info{sll_hatype},
               $info{sll_pkttype},
               $info{sll_addr},
               $info{tp_len} );
   }

   my ( $addr, $len ) = $self->recv_len( @_ ) or return;
   return unpack_sockaddr_ll( $addr ), $len;
}

=head2 protocol

   $protocol = $sock->protocol

Returns the ethertype protocol the socket is bound to.

=cut

sub protocol
{
   my $self = shift;
   return (unpack_sockaddr_ll($self->sockname))[0];
}

=head2 ifindex

   $ifindex = $sock->ifindex

Returns the interface index the socket is bound to.

=cut

sub ifindex
{
   my $self = shift;
   return (unpack_sockaddr_ll($self->sockname))[1];
}

=head2 ifname

   $ifname = $sock->ifname

Returns the name of the interface the socket is bound to.

=cut

sub ifname
{
   my $self = shift;
   return siocgifname( $self, $self->ifindex );
}

=head2 hatype

   $hatype = $sock->hatype

Returns the hardware address type for the interface the socket is bound to.

=cut

sub hatype
{
   my $self = shift;
   return (unpack_sockaddr_ll($self->sockname))[2];
}

=head2 timestamp

   $time = $sock->timestamp

   ( $sec, $usec ) = $sock->timestamp

Returns the timestamp of the last received packet on the socket (as obtained
by the C C). In scalar context, returns a single
floating-point value in UNIX epoch seconds. In list context, returns the
number of seconds, and the number of microseconds.

If the ring-buffer has been set using C, this method returns
the timestamp of the last packet received from it.

=cut

sub timestamp
{
   my $self = shift;

   if( defined ${*$self}{packet_ts_sec} ) {
      my $sec  = delete ${*$self}{packet_ts_sec};
      my $nsec = delete ${*$self}{packet_ts_nsec};

      return wantarray ? ( $sec, int($nsec/1000) ) : $sec + $nsec/1_000_000_000;
   }

   return siocgstamp( $self );
}

=head2 timestamp_nano

   $time = $sock->timestamp_nano

   ( $sec, $nsec ) = $sock->timestamp_nano

Returns the nanosecond-precise timestamp of the last received packet on the
socket (as obtained by the C C). In scalar context,
returns a single floating-point value in UNIX epoch seconds. In list context,
returns the number of seconds, and the number of nanoseconds.

If the ring-buffer has been set using C, this method returns
the timestamp of the last packet received from it.

=cut

sub timestamp_nano
{
   my $self = shift;

   if( defined ${*$self}{packet_ts_sec} ) {
      my $sec  = delete ${*$self}{packet_ts_sec};
      my $nsec = delete ${*$self}{packet_ts_nsec};

      return wantarray ? ( $sec, $nsec ) : $sec + $nsec/1_000_000_000;
   }

   return siocgstampns( $self );
}

=head1 INTERFACE NAME UTILITIES

The following methods are utilities around C and C.
If called on an object, they use the encapsulated socket. If called as class
methods, they will create a temporary socket to pass to the kernel, then close
it again.

=cut

=head2 ifname2index

   $ifindex = $sock->ifname2index( $ifname )

   $ifindex = IO::Socket::Packet->ifname2index( $ifname )

Returns the name for the given interface index, or C if it doesn't
exist.

=cut

sub ifname2index
{
   my $self = shift;
   my ( $ifname ) = @_;

   my $sock;
   if( ref $self ) {
      $sock = $self;
   }
   else {
      socket( $sock, AF_INET, SOCK_STREAM, 0 ) or
         croak "Cannot socket(AF_INET) - $!";
   }

   return siocgifindex( $sock, $ifname );
}

=head2 ifindex2name

   $ifname = $sock->ifindex2name( $ifindex )

   $ifname = IO::Socket::Packet->ifindex2name( $ifindex )

Returns the index for the given interface name, or C if it doesn't
exist.

=cut

sub ifindex2name
{
   my $self = shift;
   my ( $ifindex ) = @_;

   my $sock;
   if( ref $self ) {
      $sock = $self;
   }
   else {
      socket( $sock, AF_INET, SOCK_STREAM, 0 ) or
         croak "Cannot socket(AF_INET) - $!";
   }

   return siocgifname( $sock, $ifindex );
}

sub _make_sockopt_int
{
   my ( $optname ) = @_;

   # IO::Socket automatically handles the pack/unpack in this case

   sub {
      my $sock = shift;

      if( @_ ) {
         $sock->setsockopt( SOL_PACKET, $optname, $_[0] );
      }
      else {
         return $sock->getsockopt( SOL_PACKET, $optname );
      }
   };
}

=head1 SOCKET OPTION ACCESSORS

=cut

=head2 add_multicast

   $sock->add_multicast( $addr, $ifindex )

Adds the given multicast address on the given interface index. If the
interface index is not supplied, C<< $sock->ifindex >> is used.

=cut

sub add_multicast
{
   my $self = shift;
   my ( $addr, $ifindex ) = @_;
   defined $ifindex or $ifindex = $self->ifindex;

   $self->setsockopt( SOL_PACKET, PACKET_ADD_MEMBERSHIP,
      pack_packet_mreq( $ifindex, PACKET_MR_MULTICAST, $addr )
   );
}

=head2 drop_multicast

   $sock->drop_multicast( $addr, $ifindex )

Drops the given multicast address on the given interface index. If the
interface index is not supplied, C<< $sock->ifindex >> is used.

=cut

sub drop_multicast
{
   my $self = shift;
   my ( $addr, $ifindex ) = @_;
   defined $ifindex or $ifindex = $self->ifindex;

   $self->setsockopt( SOL_PACKET, PACKET_DROP_MEMBERSHIP,
      pack_packet_mreq( $ifindex, PACKET_MR_MULTICAST, $addr )
   );
}

=head2 promisc

   $sock->promisc( $promisc, $ifindex )

Sets or clears the PACKET_MR_PROMISC flag on the given interface. If the
interface index is not supplied, C<< $sock->ifindex >> is used.

=cut

sub promisc
{
   my $self = shift;
   my ( $value, $ifindex ) = @_;
   defined $ifindex or $ifindex = $self->ifindex;

   $self->setsockopt( SOL_PACKET, $value ? PACKET_ADD_MEMBERSHIP : PACKET_DROP_MEMBERSHIP,
      pack_packet_mreq( $ifindex, PACKET_MR_PROMISC, "" )
   );
}

=head2 allmulti

   $sock->allmulti( $allmulti, $ifindex )

Sets or clears the PACKET_MR_ALLMULTI flag on the given interface. If the
interface index is not supplied, C<< $sock->ifindex >> is used.

=cut

sub allmulti
{
   my $self = shift;
   my ( $value, $ifindex ) = @_;
   defined $ifindex or $ifindex = $self->ifindex;

   $self->setsockopt( SOL_PACKET, $value ? PACKET_ADD_MEMBERSHIP : PACKET_DROP_MEMBERSHIP,
      pack_packet_mreq( $ifindex, PACKET_MR_ALLMULTI, "" )
   );
}

=head2 statistics

   $stats = $sock->statistics

Returns the socket statistics. This will be a two-field hash containing
counts C, the total number of packets the socket has seen, and
C, the number of packets that could not stored because the buffer was
full.

=cut

sub statistics
{
   my $self = shift;

   my $stats = $self->getsockopt( SOL_PACKET, PACKET_STATISTICS )
      or return;

   my %stats;
   @stats{qw( packets drops)} = unpack_tpacket_stats( $stats );

   return \%stats;
}

=head2 origdev

   $val = $sock->origdev

   $sock->origdev( $val )

Return or set the value of the C socket option.

=cut

if( defined &Socket::Packet::PACKET_ORIGDEV ) {
   *origdev = _make_sockopt_int( Socket::Packet::PACKET_ORIGDEV() );
}

=head1 RING-BUFFER METHODS

These methods operate on the high-performance memory-mapped capture buffer.

An example of how to use these methods for packet capture is included in the
module distribution; see F for more detail.

=cut

=head2 setup_rx_ring

   $size = $sock->setup_rx_ring( $frame_size, $frame_nr, $block_size )

Sets up the ring-buffer on the object. This method is identical to the
C function C, except that the ring-buffer
variable is stored transparently within the C<$sock> object; the caller does
not need to manage it.

Once this buffer is enabled, the C, C and
C methods will automatically use it instead of the regular
C+C interface.

=cut

sub setup_rx_ring
{
   my $self = shift;
   my ( $frame_size, $frame_nr, $block_size ) = @_;

   my $ret = Socket::Packet::setup_rx_ring( $self, $frame_size, $frame_nr, $block_size );
   ${*$self}{packet_rx_ring} = 1 if defined $ret;

   return $ret;
}

=head2 get_ring_frame

   $len = $sock->get_ring_frame( $buffer, \%info )

Receives the next packet from the ring-buffer. If there are no packets waiting
it will return undef. This method aliases the C<$buffer> variable to the
Ced packet buffer.

For detail on the C<%info> hash, see L's C
function.

Once the caller has finished with the C<$buffer> data, the C
method should be called to hand the frame buffer back to the kernel.

=cut

sub get_ring_frame
{
   my $self = shift;

   return Socket::Packet::get_ring_frame( $self, $_[0], $_[1] );
}

=head2 wait_ring_frame

   $len = $sock->wait_ring_frame( $buffer, \%info )

If a packet is ready, this method sets C<$buffer> and C<%info> as per the
C method. If there are no packets waiting and the socket is
in blocking mode, it will C on the socket until a packet is
available. If the socket is in non-blocking mode, it will return false with
C<$!> set to C.

For detail on the C<%info> hash, see L's C
function.

Once the caller has finished with the C<$buffer> data, the C
method should be called to hand the frame buffer back to the kernel.

=cut

sub wait_ring_frame
{
   my $self = shift;

   my $len;
   while( !defined( $len = $self->get_ring_frame( $_[0], $_[1] ) ) ) {
      $! = EAGAIN, return if not $self->blocking;

      my $rvec = '';
      vec( $rvec, fileno $self, 1 ) = 1;
      select( $rvec, undef, undef, undef ) or return;
   }

   return $len;
}

=head2 done_ring_frame

   $sock->done_ring_frame

Hands the current ring-buffer frame back to the kernel.

=cut

sub done_ring_frame
{
   my $self = shift;

   Socket::Packet::done_ring_frame( $self );
}

=head1 SEE ALSO

=over 4

=item *

L - interface to Linux's C socket family

=back

=head1 AUTHOR

Paul Evans

=cut

0x55AA;