# $Id: 04-packet.t 1449 2016-02-01 12:27:12Z willem $	-*-perl-*-

use strict;

BEGIN {

	use Test::More tests => 99;

	use_ok('Net::DNS');

}

#	new() class constructor method must return object of appropriate class

my $object = Net::DNS::Packet->new();

ok( $object->isa('Net::DNS::Packet'), 'new() object' );

ok( $object->header,			      'header() method works' );

ok( $object->header->isa('Net::DNS::Header'), 'header() returns header object' );

ok( $object->edns,			     'edns() method works' );

ok( $object->edns->isa('Net::DNS::RR::OPT'), 'edns() returns OPT RR object' );

like( $object->string, '/HEADER/', 'string() returns representation of packet' );

$object->header->opcode('UPDATE');

like( $object->string, '/UPDATE/', 'string() returns representation of update' );

#	Empty packet created when new() arguments omitted

my $empty = Net::DNS::Packet->new();

ok( $empty, 'create empty packet' );

foreach my $method ( qw(question answer authority additional), qw(zone pre prerequisite update) ) {

	my @result = $empty->$method;

	ok( @result == 0, "$method() returns empty list" );

}

#	Create a DNS query packet

my ( $domain, $type, $class ) = qw(example.test MX IN);

my $question = Net::DNS::Question->new( $domain, $type, $class );

my $packet = Net::DNS::Packet->new( $domain, $type, $class );

like( $packet->string, "/$class\t$type/", 'create query packet' );

my @question = $packet->question;

ok( @question && @question == 1, 'packet->question() returns single element list' );

my ($q) = @question;

ok( $q->isa('Net::DNS::Question'), 'list element is a question object' );

is( $q->string, $question->string, 'question object correct' );

#	data() method returns non-empty scalar

my $packet_data = $packet->data;

ok( $packet_data, 'packet->data() method works' );

#	new(\$data) class constructor method returns object of appropriate class

my $packet2 = Net::DNS::Packet->new( \$packet_data );

ok( $packet2->isa('Net::DNS::Packet'), 'new(\$data) object' );

is( $packet2->string, $packet->string, 'decoded packet matches original' );

is( unpack( 'H*', $packet2->data ), unpack( 'H*', $packet_data ), 'retransmitted packet matches original' );

#	new(\$data) class constructor captures exception text when data truncated

my @data = unpack 'C*', $packet->data;

while (@data) {

	pop(@data);

	my $truncated = pack 'C*', @data;

	my $length    = length $truncated;

	my $object    = Net::DNS::Packet->new( \$truncated );

	my $exception = $@;

	$exception =~ s/\n.*$//g;

	ok( $exception, "truncated ($length octets):\t[$exception]" );

}

#	Use push() to add RRs to each section

my $update = Net::DNS::Packet->new('.');

my $index;

foreach my $section (qw(answer authority additional)) {

	my $i	= ++$index;

	my $rr1 = Net::DNS::RR->new(

		Name	=> "$section$i.example.test",

		Type	=> "A",

		Address => "10.0.0.$i"

		);

	my $string1 = $rr1->string;

	my $count1 = $update->push( $section, $rr1 );

	like( $update->string, "/$string1/", "push first RR into $section section" );

	is( $count1, 1, "push() returns $section RR count" );

	my $j	= ++$index;

	my $rr2 = Net::DNS::RR->new(

		Name	=> "$section$j.example.test",

		Type	=> "A",

		Address => "10.0.0.$j"

		);

	my $string2 = $rr2->string;

	my $count2 = $update->push( $section, $rr2 );

	like( $update->string, "/$string2/", "push second RR into $section section" );

	is( $count2, 2, "push() returns $section RR count" );

}

# Add enough distinct labels to render compression unusable at some point

for ( 0 .. 255 ) {

	$update->push( 'answer', Net::DNS::RR->new( "X$_ TXT \"" . pack( "A255", "x" ) . '"' ) );

}

$update->push( 'answer', Net::DNS::RR->new('XY TXT ""') );

$update->push( 'answer', Net::DNS::RR->new('VW.XY TXT ""') );

#	Decode data buffer and compare with original

my $buffer = $update->data;

my $decoded = eval { Net::DNS::Packet->new( \$buffer ) };

ok( $decoded, 'new() from data buffer works' );

is( $decoded->answersize, length($buffer), '$decoded->answersize() works' );

$decoded->answerfrom('local');

ok( $decoded->answerfrom(), '$decoded->answerfrom() works' );

ok( $decoded->string(),	    '$decoded->string() works' );

foreach my $count (qw(qdcount ancount nscount arcount)) {

	is( $decoded->header->$count, $update->header->$count, "check header->$count correct" );

}

foreach my $section (qw(question)) {

	my @original = map { $_->string } $update->$section;

	my @content  = map { $_->string } $decoded->$section;

	is_deeply( \@content, \@original, "check content of $section section" );

}

foreach my $section (qw(answer authority additional)) {

	my @original = map { $_->ttl(0); $_->string } $update->$section;    # almost! need TTL defined

	my @content = map { $_->string } $decoded->$section;

	is_deeply( \@content, \@original, "check content of $section section" );

}

#	check that pop() removes RR from section	Memo to self: no RR in question section!

foreach my $section (qw(answer authority additional)) {

	my $c1 = $update->push( $section, Net::DNS::RR->new('X TXT ""') );

	my $rr = $update->pop($section);

	my $c2 = $update->push($section);

	is( $c2, $c1 - 1, "pop() RR from $section section" );

}

#	Test using a predefined answer.

#	This is an answer that was generated by a bind server, with an option munged on the end.

my $BIND = pack( 'H*',

'22cc85000001000000010001056461636874036e657400001e0001c00c0006000100000e100025026e730472697065c012046f6c6166c02a7754e1ae0000a8c0000038400005460000001c2000002910000000800000050000000130'

	);

my $bind = Net::DNS::Packet->new( \$BIND );

is( $bind->header->qdcount, 1, 'check question count in synthetic packet header' );

is( $bind->header->ancount, 0, 'check answer count in synthetic packet header' );

is( $bind->header->nscount, 1, 'check authority count in synthetic packet header' );

is( $bind->header->adcount, 1, 'check additional count in synthetic packet header' );

my ($rr) = $bind->additional;

is( $rr->type, 'OPT',  'Additional section packet is EDNS0 type' );

is( $rr->size, '4096', 'EDNS0 packet size correct' );

{					## check tolerance of invalid pop

	my $packet = new Net::DNS::Packet('example.com');

	my $case1  = $packet->pop('');

	my $case2  = $packet->pop('bogus');

}

{					## check $packet->reply()

	my $packet = new Net::DNS::Packet('example.com');

	my $reply  = $packet->reply();

	ok( $reply->isa('Net::DNS::Packet'), '$packet->reply() returns packet' );

	eval { $reply->reply(); };

	my $exception = $1 if $@ =~ /^(.+)\n/;

	ok( $exception ||= '', "reply->reply()\t[$exception]" );

	my $udpmax = 2048;

	$packet->edns->size($udpmax);

	$packet->data;

	is( $packet->reply($udpmax)->edns->size(), $udpmax, 'packet->reply() supports EDNS' );

}

{					## check $packet->sigrr

	my $packet = new Net::DNS::Packet();

	is( $packet->sigrr(), undef, 'sigrr() undef for empty packet' );

	$packet->push( additional => new Net::DNS::RR( type => 'OPT' ) );

	is( $packet->sigrr(),  undef, 'sigrr() undef for unsigned packet' );

	is( $packet->verify(), undef, 'verify() fails for unsigned packet' );

	ok( $packet->verifyerr(), 'verifyerr() returned for unsigned packet' );

}

{					## go through the motions of SIG0

	my $packet = new Net::DNS::Packet('example.com');

	my $sig = new Net::DNS::RR( type => 'SIG' );

	ok( $packet->sign_sig0($sig), 'sign_sig0() returns SIG0 record' );

	is( ref( $packet->sigrr() ), ref($sig), 'sigrr() returns SIG RR' );

	eval { $packet->sign_sig0( [] ); };

	my $exception = $1 if $@ =~ /^(.+)\n/;

	ok( $exception ||= '', "sign_sig0([])\t[$exception]" );

}

{					## check exception raised for bad TSIG

	my $packet = new Net::DNS::Packet('example.com');

	my $bogus = new Net::DNS::RR( type => 'NULL' );

	eval { $packet->sign_tsig($bogus); };

	my $exception = $1 if $@ =~ /^(.+)\n/;

	ok( $exception ||= '', "sign_tsig([])\t[$exception]" );

}

eval {					## exercise but do not test print

	require Data::Dumper;

	local $Data::Dumper::Maxdepth;

	local $Data::Dumper::Sortkeys;

	my $object   = new Net::DNS::Packet('example.com');

	my $buffer   = $object->data;

	my $corrupt  = substr $buffer, 0, 10;

	my $filename = '04-packet.txt';

	open( TEMP, ">$filename" ) || die "Could not open $filename for writing";

	select( ( select(TEMP), $object->print )[0] );

	select( ( select(TEMP), $object->dump )[0] );

	$Data::Dumper::Maxdepth = 6;

	$Data::Dumper::Sortkeys = 1;

	select( ( select(TEMP), $object->dump )[0] );

	select( ( select(TEMP), Net::DNS::Packet->new( \$buffer, 1 ) )[0] );

	select( ( select(TEMP), Net::DNS::Packet->new( \$corrupt, 1 ) )[0] );

	close(TEMP);

	unlink($filename);

};

exit;