# 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 -- leonerd@leonerd.org.uk 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<IO::Socket::Packet> - Object interface to C<AF_PACKET> 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<PF_PACKET> sockets on Linux. It is built upon L<IO::Socket> 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<IO::Socket::Packet> object. If any arguments are passed it will be configured to contain a newly created socket handle, and be C<bind>ed as required by the arguments. The recognised arguments are: =over 8 =item Type => INT The socktype to use; should be either C<SOCK_RAW> or C<SOCK_DGRAM>. It not supplied a default of C<SOCK_RAW> will be used. =item Protocol => INT Ethernet protocol number to bind to. To capture all protocols, use the C<ETH_P_ALL> 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<recv> builtin, except it returns the packet length as an explict return value. This may be useful if C<$flags> contains the C<MSG_TRUNC> 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<recv_len> and C<unpack_sockaddr_ll>. 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<setup_rx_ring>, 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<SIOCGSTAMP> C<ioctl>). 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<setup_rx_ring>, 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<SIOCGSTAMPNS> C<ioctl>). 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<setup_rx_ring>, 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<siocgifindex> and C<siocgifname>. 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<undef> 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<undef> 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<packets>, the total number of packets the socket has seen, and C<drops>, 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<PACKET_ORIGDEV> 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<examples/capture-rxring.pl> 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<Socket::Packet> function C<setup_rx_ring>, 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<recv_len>, C<timestamp> and C<timestamp_nano> methods will automatically use it instead of the regular C<recv()>+C<ioctl()> 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 C<mmap()>ed packet buffer. For detail on the C<%info> hash, see L<Socket::Packet>'s C<get_ring_frame()> function. Once the caller has finished with the C<$buffer> data, the C<done_ring_frame> 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<get_ring_frame> method. If there are no packets waiting and the socket is in blocking mode, it will C<select()> 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<EAGAIN>. For detail on the C<%info> hash, see L<Socket::Packet>'s C<get_ring_frame()> function. Once the caller has finished with the C<$buffer> data, the C<done_ring_frame> 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<Socket::Packet> - interface to Linux's C<PF_PACKET> socket family =back =head1 AUTHOR Paul Evans <leonerd@leonerd.org.uk> =cut 0x55AA;