File Coverage

blib/lib/NetPacket/TCP.pm

Criterion	Covered	Total	%
statement	111	139	79.8
branch	15	20	75.0
condition			n/a
subroutine	17	19	89.4
pod	4	5	80.0
total	147	183	80.3

#
# NetPacket::TCP - Decode and encode TCP (Transmission Control
# Protocol) packets.
#
# Encode and checksumming part, Stephanie Wehner, [e-mail]

package NetPacket::TCP;
BEGIN {
  $NetPacket::TCP::AUTHORITY = 'cpan:YANICK';
}
# ABSTRACT: Assemble and disassemble TCP (Transmission Control Protocol) packets.
$NetPacket::TCP::VERSION = '1.5.0';
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
use NetPacket;

my $myclass;

# TCP Flags

use constant FIN => 0x01;
use constant SYN => 0x02;
use constant RST => 0x04;
use constant PSH => 0x08;
use constant ACK => 0x10;
use constant URG => 0x20;
use constant ECE => 0x40;
use constant CWR => 0x80;

BEGIN {
    @ISA = qw(Exporter NetPacket);

# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)

    @EXPORT = qw(FIN SYN RST PSH ACK URG ECE CWR
    );

# Other items we are prepared to export if requested

    @EXPORT_OK = qw(tcp_strip
    );

# Tags:

    %EXPORT_TAGS = (
    ALL         => [@EXPORT, @EXPORT_OK],
    strip       => [qw(tcp_strip)],
);

}

#
# Strip header from packet and return the data contained in it
#

undef &tcp_strip;
*tcp_strip = \&strip;

sub strip {
    my ($pkt) = @_;

    my $tcp_obj = NetPacket::TCP->decode($pkt);
    return $tcp_obj->{data};
}

#
# Decode the packet
#

sub decode {
    my $class = shift;
    my($pkt, $parent) = @_;
    my $self = {};

    # Class fields

    $self->{_parent} = $parent;
    $self->{_frame} = $pkt;

    # Decode TCP packet

    if (defined($pkt)) {
	my $tmp;

	($self->{src_port}, $self->{dest_port}, $self->{seqnum},
	 $self->{acknum}, $tmp, $self->{winsize}, $self->{cksum},
	 $self->{urg}, $self->{options}) =
	     unpack("nnNNnnnna*", $pkt);

	# Extract flags

	$self->{hlen}     = ($tmp & 0xf000) >> 12;
	$self->{reserved} = ($tmp & 0x0f00) >> 8;
	$self->{flags}    =  $tmp & 0x00ff;

	# Decode variable length header and remaining data

	my $olen = $self->{hlen} - 5;
	$olen = 0 if $olen < 0;  # Check for bad hlen

        # Option length is number of 32 bit words

    $olen *= 4;

	( $self->{options}, $self->{data} )
        = unpack( 'a' . $olen .  'a*', $self->{options});
    }

    # Return a blessed object

    bless($self, $class);
    return $self;
}

#
# Encode a packet
#

sub encode {

    my $self = shift;
    my ($ip) = @_;
    my ($packet,$tmp);

    # First of all, fix the checksum
    $self->checksum($ip);

    $tmp = $self->{hlen} << 12;
    $tmp = $tmp | (0x0f00 & ($self->{reserved} << 8));
    $tmp = $tmp | (0x00ff & $self->{flags});

    # Put the packet together
    $packet = pack('n n N N n n n n a* a*',
            $self->{src_port}, $self->{dest_port}, $self->{seqnum},
            $self->{acknum}, $tmp, $self->{winsize}, $self->{cksum},
            $self->{urg}, $self->{options},$self->{data});


    return($packet);

}

#
# TCP Checksum
#

sub checksum {

    my $self = shift;
    my ($ip) = @_;
    my ($packet,$zero,$tcplen,$tmp);
    my ($src_ip, $dest_ip,$proto);

    $zero = 0;
    $proto = 6;
    $tcplen = ($self->{hlen} * 4)+ length($self->{data});

    no warnings qw/ uninitialized /;
    $tmp = $self->{hlen} << 12;
    $tmp = $tmp | (0x0f00 & ($self->{reserved} << 8));
    $tmp = $tmp | (0x00ff & $self->{flags});

    # Pack pseudo-header for tcp checksum

    $src_ip = gethostbyname($ip->{src_ip});
    $dest_ip = gethostbyname($ip->{dest_ip});

    $packet = pack('a4a4nnnnNNnnnna*a*',
            $src_ip,$dest_ip,$proto,$tcplen,
            $self->{src_port}, $self->{dest_port}, $self->{seqnum},
            $self->{acknum}, $tmp, $self->{winsize}, $zero,
            $self->{urg}, $self->{options},$self->{data});

    # pad packet if odd-sized
    $packet .= "\x00" if length( $packet ) % 2;

    $self->{cksum} = NetPacket::htons(NetPacket::in_cksum($packet));
}

sub parse_tcp_options {
  #
  # dissect tcp options header. see:
  # http://www.networksorcery.com/enp/protocol/tcp.htm#Options
  #
  # we create an byte array from the options header
  # and iterate through that. If we find an option
  # kind number we act accordingly (sometimes it has
  # a fixed length, sometimes a variable one).
  # once we've got the option stored, we shift the
  # bytes we fetched away from the byte array and
  # re-enter the loop.

  my $self = shift;

  my $opts = $self->{options};
  my @bytes = split //, $opts;
  my %options;
  my $size;
 ENTRY:
  $size = $#bytes;
  foreach my $byte (@bytes) {
    my $kind = unpack('C', $byte);
    if($kind == 2) {
      # MSS.
      # next byte is size, set to 4
      # next 2 bytes are mss value 16 bit unsigned short
      $options{mss} = unpack('n', $bytes[2] . $bytes[3]);
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      goto ENTRY;
    }
    elsif ($kind == 1) {
      # a noop
      shift @bytes;
      goto ENTRY;
    }
    elsif ($kind == 3) {
      # Windows Scale Factor
      # next byte is size, set to 3
      # next byte is shift count, 8 bit unsigned
      $options{ws} = unpack('C', $bytes[2]);
      shift @bytes;
      shift @bytes;
      shift @bytes;
      goto ENTRY;
    }
    elsif ($kind == 4) {
      # SACK Permitted
      # next byte is length
      $options{sack} = unpack('C', $bytes[1]);
      shift @bytes;
      shift @bytes;
      goto ENTRY;
    }
    elsif ($kind == 5) {
      # SACK Blocks
      # next byte is length, 2 + (number of blocks * 8)
      # in every block,
      # former 4 bytes is SACK left edge, 32 bit unsigned int
      # latter 4 bytes is SACK right edge, 32 bit unsigned int
      my $block_num = (unpack('C', $bytes[1]) - 2) / 8;
      shift @bytes;
      shift @bytes;
      my @sack_blocks;
      for (1..$block_num) {
        push @sack_blocks, [unpack('N', join '', @bytes[0..3]),
                            unpack('N', join '', @bytes[4..7])];
        shift @bytes;
        shift @bytes;
        shift @bytes;
        shift @bytes;
        shift @bytes;
        shift @bytes;
        shift @bytes;
        shift @bytes;
      }
      $options{sack_blocks} = \@sack_blocks;
    }
    elsif ($kind == 8) {
      # timestamp
      # next byte is length, set to 10
      # next 4 byte is timestamp, 32 bit unsigned int
      # next 4 byte is timestamp echo reply, 32 bit unsigned int
      $options{ts} = unpack('N', join '', @bytes[2..5]);
      $options{er} = unpack('N', join '', @bytes[6,7,8,9]);
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      shift @bytes;
      goto ENTRY;
    }
  }
  return wantarray ? %options : \%options;
}
#
# Module initialisation
#

1;

# autoloaded methods go after the END token (&& pod) below

__END__