File Coverage

blib/lib/Net/Analysis/Packet.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	12	22	54.5
condition	2	4	50.0
subroutine	15	15	100.0
pod	2	5	40.0
total	102	117	87.1

package Net::Analysis::Packet;

use 5.008000;
our $VERSION = '0.03';
use strict;
use warnings;
use Carp qw(carp cluck);
use POSIX qw(strftime);

# {{{ Exported boilerplate

require Exporter;

our @ISA = qw(Exporter);

our @PKT_SLOT_CONSTS = qw(PKT_SLOT_TO
                          PKT_SLOT_FROM
                          PKT_SLOT_FLAGS
                          PKT_SLOT_DATA
                          PKT_SLOT_SEQNUM
                          PKT_SLOT_ACKNUM
                          PKT_SLOT_PKT_NUMBER
                          PKT_SLOT_TV_SEC
                          PKT_SLOT_TV_USEC
                          PKT_SLOT_SOCKETPAIR_KEY
                          PKT_SLOT_CLASS
                          );

our @PKT_FUNCTIONS = qw(pkt_time pkt_init pkt_as_string pkt_class);

our @EXPORT    = ();
our @EXPORT_OK = (@PKT_SLOT_CONSTS, @PKT_FUNCTIONS);
our %EXPORT_TAGS = (all      => [ @EXPORT, @EXPORT_OK ],
                    pktslots => [ @PKT_SLOT_CONSTS ],
                    func     => [ @PKT_FUNCTIONS],
                   );

# }}}

use Net::Analysis::Constants qw(:tcpflags :packetclasses);
use Net::Analysis::Time;

use Data::Dumper;

use constant {
    PKT_SLOT_TO              => 0,
    PKT_SLOT_FROM            => 1,
    PKT_SLOT_FLAGS           => 2,
    PKT_SLOT_DATA            => 3,
    PKT_SLOT_SEQNUM          => 4,
    PKT_SLOT_ACKNUM          => 5,
    PKT_SLOT_PKT_NUMBER      => 6,
    PKT_SLOT_TV_SEC          => 7,
    PKT_SLOT_TV_USEC         => 8,
    PKT_SLOT_TIME            => 9,
    PKT_SLOT_SOCKETPAIR_KEY  => 10,
    PKT_SLOT_CLASS           => 11,
};

#### Public methods
#
# {{{ pkt_time

sub pkt_time {
    my $pkt = shift;
    return $pkt->[PKT_SLOT_TIME];
}

# }}}
# {{{ pkt_init

sub pkt_init {
    my $pkt = shift;
    $pkt->[PKT_SLOT_CLASS] = PKT_NOCLASS;
    $pkt->[PKT_SLOT_SOCKETPAIR_KEY] = join('-', sort
                                           ($pkt->[PKT_SLOT_FROM],
                                            $pkt->[PKT_SLOT_TO]));

    $pkt->[PKT_SLOT_TIME] = Net::Analysis::Time->new
        ($pkt->[PKT_SLOT_TV_SEC], $pkt->[PKT_SLOT_TV_USEC]);

    return $pkt;
}

# }}}
# {{{ pkt_class

sub pkt_class {
    my ($self, $new) = @_;

    $self->[PKT_SLOT_CLASS] = $new if (defined $new);

    return $self->[PKT_SLOT_CLASS];
}

# }}}
# {{{ pkt_as_string

sub pkt_as_string {
    my ($self, $v) = @_;

    #cluck ("I was invoked :(");
    #exit;

    carp "bad pkt !\n" if (!exists $self->[PKT_SLOT_PKT_NUMBER]);

    my $flags = '';
    $flags .= 'F' if ($self->[PKT_SLOT_FLAGS] & FIN);
    $flags .= 'S' if ($self->[PKT_SLOT_FLAGS] & SYN);
    $flags .= 'A' if ($self->[PKT_SLOT_FLAGS] & ACK);
    $flags .= 'R' if ($self->[PKT_SLOT_FLAGS] & RST);
    $flags .= 'P' if ($self->[PKT_SLOT_FLAGS] & PSH);
    $flags .= 'U' if ($self->[PKT_SLOT_FLAGS] & URG);
    $flags .= '.' if ($flags eq '');

    my $p_time = pkt_time($self);

    my $time = ($p_time) ? $p_time->as_string('time') : "--";

    my $str = sprintf ("(% 3d $time %s-%s) ",
                       $self->[PKT_SLOT_PKT_NUMBER],
                       $self->[PKT_SLOT_FROM],
                       $self->[PKT_SLOT_TO]);

    # Show which class we have assigned to the packet
    $str .= {PKT_NOCLASS,     '-',
             PKT_NONDATA,     '_',
             PKT_DATA,        '*',
             PKT_DUP_DATA,    'p',
             PKT_FUTURE_DATA, 'f'}->{$self->[PKT_SLOT_CLASS]} || '?';

    $str .= sprintf ("%-6s ", "$flags");

    $str .= "SEQ:".$self->[PKT_SLOT_SEQNUM]." ACK:".$self->[PKT_SLOT_ACKNUM].
        " ".length($self->[PKT_SLOT_DATA])."b";

    if ($v) { # Get all verbose
        $str .= "\n"._hex_dump ($self->[PKT_SLOT_DATA]);
    }

    return $str;
}

# }}}

#### Private helpers
#
# {{{ _hex_dump

sub _hex_dump {
    my ($binary, $prefix) = @_;

    $prefix ||= '';
    my $hex = $prefix.unpack("H*", $binary);

    $hex =~ s {([0-9a-f]{2}(?! ))}     { $1}mg;

    $hex =~ s {(( [0-9a-f]{2}){16})}
              {"$1   ".safe_raw_line($1)."\n"}emg;

    # Unfinished last line
    $hex =~ s {(( [0-9a-f]{2})*)$}
              {sprintf("%-47.47s    ",$1) .safe_raw_line($1)."\n"}es;

    chomp($hex);
    return $hex."\n";
}

sub safe_raw_line {
    my ($s) = @_;
    $s =~ s {\s+} {}mg;

    my $raw = pack("H*", $s);
    $raw =~ s {([^\x20-\x7e])} {.}g;
    return "{$raw}";
}

# }}}

1;
__END__