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

use strict;

use Test::More tests => 33;

use Net::DNS;

use Net::DNS::ZoneFile;

my $source = new Net::DNS::ZoneFile( \*DATA );

my @rr = $source->read;

{

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

	$packet->push( answer	  => @rr );

	$packet->push( authority  => @rr );

	$packet->push( additional => @rr );

	my $unlimited = length $packet->data;

	my %before    = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional);

	my $truncated = length $packet->truncate($unlimited);

	ok( $truncated == $unlimited, "unconstrained packet length $unlimited" );

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

		my $before = $before{$section};

		my $after  = scalar( $packet->$section );

		is( $after, $before, "$section section unchanged, $before RRs" );

	}

	ok( !$packet->header->tc, 'header->tc flag not set' );

}

{

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

	$packet->push( answer	  => @rr );

	$packet->push( authority  => @rr );

	$packet->push( additional => @rr );

	my $unlimited = length $packet->data;

	my %before    = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional);

	my $truncated = length $packet->truncate;		# exercise default size

	ok( $truncated < $unlimited, "long packet was $unlimited, now $truncated" );

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

		my $before = $before{$section};

		my $after  = scalar( $packet->$section );

		ok( $after < $before, "$section section was $before RRs, now $after" );

	}

	ok( $packet->header->tc, 'header->tc flag set' );

}

{

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

	$packet->push( answer	  => @rr );

	$packet->push( authority  => @rr );

	$packet->push( additional => @rr );

	my $tsig = eval { $packet->sign_tsig( 'tsig.example', 'ARDJZgtuTDzAWeSGYPAu9uJUkX0=' ) };

	my $unlimited = length $packet->data;

	my %before    = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional);

	my $truncated = length $packet->data(512);		# explicit minimum size

	ok( $truncated < $unlimited, "signed packet was $unlimited, now $truncated" );

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

		my $before = $before{$section};

		my $after  = scalar( $packet->$section );

		ok( $after < $before, "$section section was $before RRs, now $after" );

	}

	my $sigrr = $packet->sigrr;

	is( $sigrr, $tsig, 'TSIG still in additional section' );

	ok( $packet->header->tc, 'header->tc flag set' );

}

{

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

	my @auth = map Net::DNS::RR->new( type => 'NS', nsdname => $_->name ), @rr;

	$packet->unique_push( authority => @auth );

	$packet->push( additional => @rr );

	$packet->edns->size(2048);				# + all bells and whistles

	my $unlimited = length $packet->data;

	my %before    = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional);

	my $truncated = length $packet->truncate;

	ok( $truncated < $unlimited, "referral packet was $unlimited, now $truncated" );

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

		my $before = $before{$section};

		my $after  = scalar( $packet->$section );

		is( $after, $before, "$section section unchanged, $before RRs" );

	}

	foreach my $section (qw(additional)) {

		my $before = $before{$section};

		my $after  = scalar( $packet->$section );

		ok( $after <= $before, "$section section was $before RRs, now $after" );

	}

	ok( !$packet->header->tc, 'header->tc flag not set' );

}

{

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

	$packet->push( additional => @rr, @rr );		# two of everything

	my $unlimited = length $packet->data;

	my $truncated = length $packet->truncate( $unlimited >> 1 );

	ok( $truncated, "check RRsets in truncated additional section" );

	my %rrset;

	foreach my $rr ( grep $_->type eq 'A', $packet->additional ) {

		my $name = $rr->name;

		$rrset{"$name. A"}++;

	}

	foreach my $rr ( grep $_->type eq 'AAAA', $packet->additional ) {

		my $name = $rr->name;

		$rrset{"$name. AAAA"}++;

	}

	my $expect = 2;

	foreach my $key ( sort keys %rrset ) {

		is( $rrset{$key}, $expect, "$key	; $expect RRs" );

	}

}

exit;

__DATA__

a.example.	A	198.41.0.4

a.example.	AAAA	2001:503:ba3e::2:30

b.example.	A	192.228.79.201

b.example.	AAAA	2001:500:84::b

c.example.	A	192.33.4.12

c.example.	AAAA	2001:500:2::c

d.example.	A	199.7.91.13

d.example.	AAAA	2001:500:2d::d

e.example.	A	192.203.230.10

f.example.	A	192.5.5.241

f.example.	AAAA	2001:500:2f::f

g.example.	A	192.112.36.4

h.example.	A	128.63.2.53

h.example.	AAAA	2001:500:1::803f:235

i.example.	A	192.36.148.17

i.example.	AAAA	2001:7fe::53

j.example.	A	192.58.128.30

j.example.	AAAA	2001:503:c27::2:30

k.example.	A	193.0.14.129

k.example.	AAAA	2001:7fd::1

l.example.	A	199.7.83.42

l.example.	AAAA	2001:500:3::42

m.example.	A	202.12.27.33

m.example.	AAAA	2001:dc3::35