Net::DNS::Packet - DNS packet object class

    $packet = Net::DNS::Packet->new("example.com");
    $packet = Net::DNS::Packet->new("example.com", "MX", "IN");

    $packet = Net::DNS::Packet->new(\$data);
    $packet = Net::DNS::Packet->new(\$data, 1);  # set debugging

    ($packet, $err) = Net::DNS::Packet->new(\$data);

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

    $data = $packet->data;

    $header = $packet->header;

    @question = $packet->question;

    @answer = $packet->answer;

    @authority = $packet->authority;

    @additional = $packet->additional;

    $packet->print;

    print $packet->string;

    print "packet received from ", $packet->answerfrom, "\n";

    print "packet size: ", $packet->answersize, " bytes\n";

    $ancount = $packet->push(pre        => $rr);
    $nscount = $packet->push(update     => $rr);
    $arcount = $packet->push(additional => $rr);

    $nscount = $packet->push(update => $rr1, $rr2, $rr3);
    $nscount = $packet->push(update => @rr);

    $ancount = $packet->unique_push(pre        => $rr);
    $nscount = $packet->unique_push(update     => $rr);
    $arcount = $packet->unique_push(additional => $rr);

    $nscount = $packet->unique_push(update => $rr1, $rr2, $rr3);
    $nscount = $packet->unique_push(update => @rr);

    my $rr = $packet->pop("pre");
    my $rr = $packet->pop("update");
    my $rr = $packet->pop("additional");
    my $rr = $packet->pop("question");

    $compname = $packet->dn_comp("foo.example.com", $offset);

    use Net::DNS::Packet qw(dn_expand);
    ($name, $nextoffset) = dn_expand(\$data, $offset);

    ($name, $nextoffset) = Net::DNS::Packet::dn_expand(\$data, $offset);

    $key_name = "tsig-key";
    $key      = "awwLOtRfpGE+rRKF2+DEiw==";

    $update = Net::DNS::Update->new("example.com");
    $update->push("update", rr_add("foo.example.com A 10.1.2.3"));

    $update->sign_tsig($key_name, $key);

    $response = $res->send($update);

    algorithm   = HMAC-MD5.SIG-ALG.REG.INT
    time_signed = current time
    fudge       = 300 seconds

    $key_name = "tsig-key";
    $key      = "awwLOtRfpGE+rRKF2+DEiw==";

    $tsig = Net::DNS::RR->new("$key_name TSIG $key");
    $tsig->fudge(60);

    $query = Net::DNS::Packet->new("www.example.com");
    $query->sign_tsig($tsig);

    $response = $res->send($query);

    $update = Net::DNS::Update->new("example.com");
    $update->push("update", rr_add("foo.example.com A 10.1.2.3"));
    $update->sign_sig0("Kexample.com+003+25317.private");

package Net::DNS::Packet;
#
# $Id: Packet.pm 837 2009-12-30 10:23:25Z olaf $
#
use strict;

BEGIN { 
    eval { require bytes; }
}

use vars qw(@ISA @EXPORT_OK $VERSION $AUTOLOAD);

use Carp;
use Net::DNS ;
use Net::DNS::Question;
use Net::DNS::RR;
use Data::Dumper;


require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(dn_expand);


$VERSION = (qw$LastChangedRevision: 837 $)[1];

sub new {
	my $class = shift;
	my ($data) = @_;
	return $class->parse(@_) if ref $data;

	my %self = (	header		=> Net::DNS::Header->new,
			question	=> [],
			answer		=> [],
			authority	=> [],
			additional	=> []	);

	push @{$self{question}}, Net::DNS::Question->new(@_) if @_;

	bless \%self, $class;
}



sub parse {
	my $class = shift;
	my $data  = shift;
	my $debug = shift || 0;

	my %self = (	question	=> [],
			answer		=> [],
			authority	=> [],
			additional	=> [],
			answersize	=> length $$data,
			buffer		=> $data	);

	my $self = eval {
		# Parse header section
		my ($header, $offset) = Net::DNS::Header->parse($data);
		$self{header} = $header;

		# Parse question/zone section
		for ( 1 .. $header->qdcount ) {
			my $qd;
			($qd, $offset) = Net::DNS::Question->parse($data, $offset);
			push(@{$self{question}}, $qd);
		}
			
		# Retain offset for on-demand parse of remaining data
		$self{offset} = $offset;

		bless \%self, $class;
	};

	($self || die $@)->print if $debug;

	return wantarray ? ($self, $@) : $self;
}

sub data {
	my $self = shift;
	my $data = '';
	my $header = $self->{header};

	# Default question for empty packet
	$self->push('question', Net::DNS::Question->new('','ANY','ANY'))
						unless @{$self->{question}};

	#----------------------------------------------------------------------
	# Set record counts in packet header
	#----------------------------------------------------------------------
	$header->qdcount( scalar @{$self->{question}} );
	$header->ancount( scalar @{$self->{answer}} );
	$header->nscount( scalar @{$self->{authority}} );
	$header->arcount( scalar @{$self->{additional}} );

	#----------------------------------------------------------------------
	# Get the data for each section in the packet
	#----------------------------------------------------------------------
	$self->{compnames} = {};
	foreach my $component ( $header,
				@{$self->{question}},
				@{$self->{answer}},
				@{$self->{authority}},
				@{$self->{additional}}	) {
		$data .= $component->data($self, length $data);
	}

	return $data;
}

sub header {
	return shift->{header};
}

sub question {
	return @{shift->{question}};
}

sub zone { &question }

sub answer {
	my @rr = eval { &_answer };
	carp "$@ caught" if $@;
	return @rr;
}

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

	my @rr = @{$self->{answer}};
	return @rr if @rr;				# return if already parsed

	my $data = $self->{buffer};			# parse answer data
	my $offset = $self->{offset} || return;
	undef $self->{offset};
	my $ancount = $self->{header}->ancount;
	my $rr;
	while ( $ancount-- ) {
		($rr, $offset) = Net::DNS::RR->parse($data, $offset);
		push(@rr, $rr);
	}
	$self->{offset} = $offset;			# index next section
	@{$self->{answer}} = @rr;
}

sub pre		{ &answer }
sub prerequisite { &answer }

sub authority {
	my @rr = eval { &_authority };
	carp "$@ caught" if $@;
	return @rr;
}

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

	my @rr = @{$self->{authority}};
	return @rr if @rr;				# return if already parsed

	&_answer unless @{$self->{answer}};		# parse answer data

	my $data = $self->{buffer};			# parse authority data
	my $offset = $self->{offset} || return;
	undef $self->{offset};
	my $nscount = $self->{header}->nscount;
	my $rr;
	while ( $nscount-- ) {
		($rr, $offset) = Net::DNS::RR->parse($data, $offset);
		push(@rr, $rr);
	}
	$self->{offset} = $offset;			# index next section
	@{$self->{authority}} = @rr;
}

sub update { &authority }

sub additional {
	my @rr = eval { &_additional };
	carp "$@ caught" if $@;
	return @rr;
}

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

	my @rr = @{$self->{additional}};
	return @rr if @rr;				# return if already parsed

	&_authority unless @{$self->{authority}};	# parse authority data

	my $data = $self->{buffer};			# parse additional data
	undef $self->{buffer};				# discard raw data after use
	my $offset = $self->{offset} || return;
	undef $self->{offset};
	my $arcount = $self->{header}->arcount;
	my $rr;
	while ( $arcount-- ) {
		($rr, $offset) = Net::DNS::RR->parse($data, $offset);
		push(@rr, $rr);
	}
	@{$self->{additional}} = @rr;
}

sub print {	print &string; }

sub string {
	my $self = shift;

	my $header = $self->{header};
	my $update = $header->opcode eq 'UPDATE';

	my $server = $self->{answerfrom};
	my $string = $server ? ";; Answer received from $server ($self->{answersize} bytes)\n" : "";

	$string .= ";; HEADER SECTION\n".$header->string;

	my $question = $update ? 'ZONE' : 'QUESTION';
	my @question = map{$_->string} $self->question;
	my $qdcount = @question;
	my $qds = $qdcount != 1 ? 's' : '';
	$string .= join "\n;; ", "\n;; $question SECTION ($qdcount record$qds)", @question;

	my $answer = $update ? 'PREREQUISITE' : 'ANSWER';
	my @answer = map{$_->string} $self->answer;
	my $ancount = @answer;
	my $ans = $ancount != 1 ? 's' : '';
	$string .= join "\n", "\n\n;; $answer SECTION ($ancount record$ans)", @answer;

	my $authority = $update ? 'UPDATE' : 'AUTHORITY';
	my @authority = map{$_->string} $self->authority;
	my $nscount = @authority;
	my $nss = $nscount != 1 ? 's' : '';
	$string .= join "\n", "\n\n;; $authority SECTION ($nscount record$nss)", @authority;

	my @additional = map{$_->string} $self->additional;
	my $arcount = @additional;
	my $ars = $arcount != 1 ? 's' : '';
	$string .= join "\n", "\n\n;; ADDITIONAL SECTION ($arcount record$ars)", @additional;

	return $string."\n\n";
}

sub answerfrom {
	my $self = shift;

	return $self->{answerfrom} = shift if @_;

	return $self->{answerfrom};
}

sub answersize {
	return shift->{answersize};
}

sub push {
	my $self = shift;
	my $section = lc shift || '';
	my @rr = map{ref $_ ? $_ : ()} @_;

	my $hdr = $self->{header};
	for ( $section ) {
		return $hdr->qdcount(push(@{$self->{question}}, @rr)) if /^question/;

		if ( $hdr->opcode eq 'UPDATE' ) {
			my ($zone) = $self->zone;
			my $zclass = $zone->zclass;
			foreach ( @rr ) {
				$_->class($zclass) unless $_->class =~ /ANY|NONE/;
			}
		}

		return $hdr->ancount(push(@{$self->{answer}}, @rr)) if /^ans|^pre/;
		return $hdr->nscount(push(@{$self->{authority}}, @rr)) if /^auth|^upd/;
		return $hdr->adcount(push(@{$self->{additional}}, @rr)) if /^add/;
	}

	carp qq(invalid section "$section");
	return undef;	# undefined record count
}

sub unique_push {
	my $self = shift;
	my $section = shift;
	my @rr = map{ref $_ ? $_ : ()} @_;

	my @unique = map{$self->{seen}->{ (lc $_->name) . $_->class . $_->type  . $_->rdatastr }++ ? () : $_} @rr;

	return $self->push($section, @unique);
}

sub safe_push {
	carp('safe_push() is deprecated, use unique_push() instead,');
	&unique_push;
}
	

sub pop {
	my $self = shift;
	my $section = lc shift || '';

	for ( $section ) {
		return pop(@{$self->{answer}}) if /^ans|^pre/;
		return pop(@{$self->{question}}) if /^question/;

		$self->additional if $self->{buffer};	# parse remaining data

		return pop(@{$self->{authority}}) if /^auth|^upd/;
		return pop(@{$self->{additional}}) if /^add/;
	}

	carp qq(invalid section "$section");
	return undef;
}

sub dn_comp {
	my ($self, $name, $offset) = @_;
	# The Exporter module does not seem to catch this baby...
	my @names=Net::DNS::name2labels($name);
	my $namehash = $self->{compnames};
	my $compname='';

	while (@names) {
		my $dname = join('.', @names);

		if ( my $pointer = $namehash->{$dname} ) {
			$compname .= pack('n', 0xc000 | $pointer);
			last;
		}
		$namehash->{$dname} = $offset if ($offset < 0x4000);

		my $label  = shift @names;
		my $length = length $label || next;	# skip if null
		if ( $length > 63 ) {
			$length = 63;
			$label = substr($label, 0, $length);
			carp "\n$label...\ntruncated to $length octets (RFC1035 2.3.1)";
		}
		$compname .= pack('C a*', $length, $label);
		$offset   += $length + 1;
	}

	$compname .= pack('C', 0) unless @names;

	return $compname;
}

# '

# This is very hot code, so we try to keep things fast.  This makes for
# odd style sometimes.

sub dn_expand {
#FYI	my ($packet, $offset) = @_;
	return dn_expand_XS(@_) if $Net::DNS::HAVE_XS;
#	warn "USING PURE PERL dn_expand()\n";
	return dn_expand_PP(@_, {} );	# $packet, $offset, anonymous hash
}

sub dn_expand_PP {
	my ($packet, $offset, $visited) = @_;
	my $packetlen = length $$packet;
	my $name = '';

	while ( $offset < $packetlen ) {
		unless ( my $length = unpack("\@$offset C", $$packet) ) {
			$name =~ s/\.$//o;
			return ($name, ++$offset);

		} elsif ( ($length & 0xc0) == 0xc0 ) {		# pointer
			my $point = 0x3fff & unpack("\@$offset n", $$packet);
			die 'Exception: unbounded name expansion' if $visited->{$point}++;

			my ($suffix) = dn_expand_PP($packet, $point, $visited);

			return ($name.$suffix, $offset+2) if defined $suffix;

		} else {
			my $element = substr($$packet, ++$offset, $length);
			$name .= Net::DNS::wire2presentation($element).'.';
			$offset += $length;
		}
	}
	return undef;
}

sub sign_tsig {
	my $self = shift;
	my $tsig = shift || return undef;

	unless ( ref $tsig && ($tsig->type eq "TSIG") ) {
		my $key = shift || return undef;
		$tsig = Net::DNS::RR->new("$tsig TSIG $key");
	}

	$self->push('additional', $tsig) if $tsig;
	return $tsig;
}

sub sign_sig0 {
	my $self = shift;
	my $arg = shift || return undef;
	my $sig0;
	
	croak('sign_sig0() is only available when Net::DNS::SEC is installed') 
		unless $Net::DNS::DNSSEC;
	
	if ( ref $arg ) {
		if ( UNIVERSAL::isa($arg,'Net::DNS::RR::SIG') ) {
			$sig0 = $arg;
		
		} elsif ( UNIVERSAL::isa($arg,'Net::DNS::SEC::Private') ) {
			$sig0 = Net::DNS::RR::SIG->create('', $arg);
		
		} elsif ( UNIVERSAL::isa($arg,'Net::DNS::RR::SIG::Private') ) {
			carp ref($arg).' is deprecated - use Net::DNS::SEC::Private instead';
			$sig0 = Net::DNS::RR::SIG->create('', $arg);

		} else {
			croak 'Incompatible class as argument to sign_sig0: '.ref($arg);

		}

	} else {
		$sig0 = Net::DNS::RR::SIG->create('', $arg);
	}
	
	$self->push('additional', $sig0) if $sig0;
	return $sig0;
}

# From RFC2181:
#9. The TC (truncated) header bit
#
#   The TC bit should be set in responses only when an RRSet is required
#   as a part of the response, but could not be included in its entirety.
#   The TC bit should not be set merely because some extra information
#   could have been included, but there was insufficient room.  This
#   includes the results of additional section processing.  In such cases
#   the entire RRSet that will not fit in the response should be omitted,
#   and the reply sent as is, with the TC bit clear.  If the recipient of
#   the reply needs the omitted data, it can construct a query for that
#   data and send that separately.
#
#   Where TC is set, the partial RRSet that would not completely fit may
#   be left in the response.  When a DNS client receives a reply with TC
#   set, it should ignore that response, and query again, using a
#   mechanism, such as a TCP connection, that will permit larger replies.

# Code inspired on a contribution from Aaron Crane via rt.cpan.org 33547

sub truncate {
	my $self=shift;
	my $max_len=shift;
	my $debug=0;
	$max_len=$max_len>512?$max_len:512;

	print "Truncating to $max_len\n" if $debug;

	if (length $self->data() > $max_len) {
		# first remove data from the additional section
		while (length $self->data() > $max_len){
			# first remove _complete_ RRstes from the additonal section.
			my $popped= CORE::pop(@{$self->{'additional'}});
			last unless defined($popped);
			print "Removed ".$popped->string." from additional \n" if $debug;
			my $i=0;
			my @stripped_additonal;

			while ($i< @{$self->{'additional'}}){
				#remove all of these same RRtypes
				if  (
				    ${$self->{'additional'}}[$i]->type eq $popped->type &&
				    ${$self->{'additional'}}[$i]->name eq $popped->name &&
				    ${$self->{'additional'}}[$i]->class eq $popped->class ){
					print "       Also removed ". ${$self->{'additional'}}[$i]->string." from additonal \n" if $debug;				}else{
					CORE::push @stripped_additonal,  ${$self->{'additional'}}[$i];
				}
				$i++;
			}
			$self->{'additional'}=\@stripped_additonal;
		}
		
		return $self if length $self->data <= $max_len;
		
      		my @sections = qw<authority answer question>;
		while (@sections) {
			while (my $popped=$self->pop($sections[0])) {
				last unless defined($popped);
				print "Popped ".$popped->string." from the $sections[0] section\n" if $debug;
				$self->header->tc(1);
				return $self if length $self->data <= $max_len;
				next;
			}
			shift @sections;
		}
	}
	return $self;
}

1;