File Coverage

blib/lib/NetPacket/IPX.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	7	14	50.0
condition	3	9	33.3
subroutine	11	11	100.0
pod	3	4	75.0
total	74	88	84.0

package NetPacket::IPX;
our $AUTHORITY = 'cpan:YANICK';
# ABSTRACT: Assemble and disassemble IPX packets
$NetPacket::IPX::VERSION = '1.7.2';
use strict;
use warnings;

use parent qw(NetPacket);

use Carp;

sub new
{
	my ($class, %packet) = @_;

	foreach my $key(qw(tc type dest_network dest_node dest_socket
		src_network src_node src_socket data))
	{
		croak("Missing $key argument") unless(defined($packet{$key}));
	}

	croak("Invalid tc argument")    unless($packet{tc}   =~ m/^\d+$/ && $packet{tc}   <= 255);
	croak("Invalid type argument")  unless($packet{type} =~ m/^\d+$/ && $packet{type} <= 255);

	_check_address("destination", $packet{dest_network}, $packet{dest_node}, $packet{dest_socket});
	_check_address("source",      $packet{src_network},  $packet{src_node},  $packet{src_socket});

	return bless(\%packet, $class);
}

sub _check_address
{
	my ($direction, $network, $node, $socket) = @_;

	my $OCTET = qr/[0-9A-F][0-9A-F]?/i;

	croak("Invalid $direction network") unless($network =~ m/^$OCTET(:$OCTET){3}$/);
	croak("Invalid $direction node")    unless($node =~ m/^$OCTET(:$OCTET){5}$/);
	croak("Invalid $direction socket")  unless($socket =~ m/^\d+$/ && $socket <= 65535);
}

#
# Decode the packet
#

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

	my $self = bless({
		_parent => $parent,
		_frame  => $pkt,
	}, $class);

	if(defined($pkt))
	{
		# Use array slices to capture the appropriate number of bytes
		# from each address field.

		my (
			$checksum, $length, $tc, $type,
			@dst_network, @dst_node, $dst_socket,
			@src_network, @src_node, $src_socket,
		);

		(
			$checksum, $length, $tc, $type,
			@dst_network[0..3], @dst_node[0..5], $dst_socket,
			@src_network[0..3], @src_node[0..5], $src_socket,
		) = unpack("nnCC C4C6n C4C6n", $pkt);

		$self->{tc}   = $tc;
		$self->{type} = $type;

		$self->{dest_network} = _addr_to_string(@dst_network);
		$self->{dest_node}    = _addr_to_string(@dst_node);
		$self->{dest_socket}  = $dst_socket;

		$self->{src_network} = _addr_to_string(@src_network);
		$self->{src_node}    = _addr_to_string(@src_node);
		$self->{src_socket}  = $src_socket;

		$self->{data} = substr($pkt, 30);
	}

	return $self;
}

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

sub strip {
	my ($pkt) = @_;
	return NetPacket::IPX->decode($pkt)->{data};
}

#
# Encode a packet
#

sub encode
{
	my ($self) = @_;

	return pack("nnCC", 0xFFFF, 30 + length($self->{data}), $self->{tc}, $self->{type})
		._addr_from_string($self->{dest_network})
		._addr_from_string($self->{dest_node})
		.pack("n", $self->{dest_socket})
		._addr_from_string($self->{src_network})
		._addr_from_string($self->{src_node})
		.pack("n", $self->{src_socket})
		.$self->{data};
}

sub _addr_to_string
{
	my (@bytes) = @_;
	return join(":", map { sprintf("%02X", $_) } @bytes);
}

sub _addr_from_string
{
	my ($string) = @_;
	return join("", map { pack("C", hex($_)) } split(m/:/, $string));
}

1;

__END__