← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:13 2021

Filename/usr/local/lib/perl5/site_perl/Net/DNS/Packet.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sNet::DNS::Packet::::BEGIN@107Net::DNS::Packet::BEGIN@107
0000s0sNet::DNS::Packet::::BEGIN@29Net::DNS::Packet::BEGIN@29
0000s0sNet::DNS::Packet::::BEGIN@3Net::DNS::Packet::BEGIN@3
0000s0sNet::DNS::Packet::::BEGIN@30Net::DNS::Packet::BEGIN@30
0000s0sNet::DNS::Packet::::BEGIN@32Net::DNS::Packet::BEGIN@32
0000s0sNet::DNS::Packet::::BEGIN@33Net::DNS::Packet::BEGIN@33
0000s0sNet::DNS::Packet::::BEGIN@35Net::DNS::Packet::BEGIN@35
0000s0sNet::DNS::Packet::::BEGIN@4Net::DNS::Packet::BEGIN@4
0000s0sNet::DNS::Packet::::CORE:packNet::DNS::Packet::CORE:pack (opcode)
0000s0sNet::DNS::Packet::::_sectionNet::DNS::Packet::_section
0000s0sNet::DNS::Packet::::additionalNet::DNS::Packet::additional
0000s0sNet::DNS::Packet::::answerNet::DNS::Packet::answer
0000s0sNet::DNS::Packet::::answerfromNet::DNS::Packet::answerfrom
0000s0sNet::DNS::Packet::::answersizeNet::DNS::Packet::answersize
0000s0sNet::DNS::Packet::::authorityNet::DNS::Packet::authority
0000s0sNet::DNS::Packet::::dataNet::DNS::Packet::data
0000s0sNet::DNS::Packet::::decodeNet::DNS::Packet::decode
0000s0sNet::DNS::Packet::::dumpNet::DNS::Packet::dump
0000s0sNet::DNS::Packet::::ednsNet::DNS::Packet::edns
0000s0sNet::DNS::Packet::::encodeNet::DNS::Packet::encode
0000s0sNet::DNS::Packet::::fromNet::DNS::Packet::from
0000s0sNet::DNS::Packet::::headerNet::DNS::Packet::header
0000s0sNet::DNS::Packet::::newNet::DNS::Packet::new
0000s0sNet::DNS::Packet::::popNet::DNS::Packet::pop
0000s0sNet::DNS::Packet::::preNet::DNS::Packet::pre
0000s0sNet::DNS::Packet::::prerequisiteNet::DNS::Packet::prerequisite
0000s0sNet::DNS::Packet::::printNet::DNS::Packet::print
0000s0sNet::DNS::Packet::::pushNet::DNS::Packet::push
0000s0sNet::DNS::Packet::::questionNet::DNS::Packet::question
0000s0sNet::DNS::Packet::::replyNet::DNS::Packet::reply
0000s0sNet::DNS::Packet::::sign_sig0Net::DNS::Packet::sign_sig0
0000s0sNet::DNS::Packet::::sign_tsigNet::DNS::Packet::sign_tsig
0000s0sNet::DNS::Packet::::sigrrNet::DNS::Packet::sigrr
0000s0sNet::DNS::Packet::::sizeNet::DNS::Packet::size
0000s0sNet::DNS::Packet::::stringNet::DNS::Packet::string
0000s0sNet::DNS::Packet::::truncateNet::DNS::Packet::truncate
0000s0sNet::DNS::Packet::::unique_pushNet::DNS::Packet::unique_push
0000s0sNet::DNS::Packet::::updateNet::DNS::Packet::update
0000s0sNet::DNS::Packet::::verifyNet::DNS::Packet::verify
0000s0sNet::DNS::Packet::::verifyerrNet::DNS::Packet::verifyerr
0000s0sNet::DNS::Packet::::zoneNet::DNS::Packet::zone
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Net::DNS::Packet;
2
3use strict;
4use warnings;
5
6our $VERSION = (qw$Id: Packet.pm 1818 2020-10-18 15:24:42Z willem $)[2];
7
8
9=head1 NAME
10
11Net::DNS::Packet - DNS protocol packet
12
13=head1 SYNOPSIS
14
15 use Net::DNS::Packet;
16
17 $query = Net::DNS::Packet->new( 'example.com', 'MX', 'IN' );
18
19 $reply = $resolver->send( $query );
20
21
22=head1 DESCRIPTION
23
24A Net::DNS::Packet object represents a DNS protocol packet.
25
26=cut
27
28
29use integer;
30use Carp;
31
32use Net::DNS::Parameters qw(:dsotype);
33use constant UDPSZ => 512;
34
35BEGIN {
36 require Net::DNS::Header;
37 require Net::DNS::Question;
38 require Net::DNS::RR;
39}
40
41
42=head1 METHODS
43
44=head2 new
45
46 $packet = Net::DNS::Packet->new( 'example.com' );
47 $packet = Net::DNS::Packet->new( 'example.com', 'MX', 'IN' );
48
49 $packet = Net::DNS::Packet->new();
50
51If passed a domain, type, and class, new() creates a Net::DNS::Packet
52object which is suitable for making a DNS query for the specified
53information. The type and class may be omitted; they default to A
54and IN.
55
56If called with an empty argument list, new() creates an empty packet.
57
58=cut
59
60sub new {
61 return &decode if ref $_[1];
62 my $class = shift;
63
64 my $self = bless {
65 status => 0,
66 question => [],
67 answer => [],
68 authority => [],
69 additional => [],
70 }, $class;
71
72 $self->{question} = [Net::DNS::Question->new(@_)] if scalar @_;
73
74 return $self;
75}
76
77
78#=head2 decode
79
80=pod
81
82 $packet = Net::DNS::Packet->decode( \$data );
83 $packet = Net::DNS::Packet->decode( \$data, 1 ); # debug
84 $packet = Net::DNS::Packet->new( \$data ... );
85
86If passed a reference to a scalar containing DNS packet data, a new
87packet object is created by decoding the data.
88The optional second boolean argument enables debugging output.
89
90Returns undef if unable to create a packet object.
91
92Decoding errors, including data corruption and truncation, are
93collected in the $@ ($EVAL_ERROR) variable.
94
95
96 ( $packet, $length ) = Net::DNS::Packet->decode( \$data );
97
98If called in array context, returns a packet object and the number
99of octets successfully decoded.
100
101Note that the number of RRs in each section of the packet may differ
102from the corresponding header value if the data has been truncated
103or corrupted during transmission.
104
105=cut
106
107use constant HEADER_LENGTH => length pack 'n6', (0) x 6;
108
109sub decode {
110 my $class = shift; # uncoverable pod
111 my $data = shift;
112 my $debug = shift || 0;
113
114 my $offset = 0;
115 my $self;
116 eval {
117 local $SIG{__DIE__};
118 die 'corrupt wire-format data' if length($$data) < HEADER_LENGTH;
119
120 # header section
121 my ( $id, $status, @count ) = unpack 'n6', $$data;
122 my ( $qd, $an, $ns, $ar ) = @count;
123 my $length = length $$data;
124
125 $self = bless {
126 id => $id,
127 status => $status,
128 count => [@count],
129 question => [],
130 answer => [],
131 authority => [],
132 additional => [],
133 replysize => $length
134 }, $class;
135
136 # question/zone section
137 my $hash = {};
138 my $record;
139 $offset = HEADER_LENGTH;
140 while ( $qd-- ) {
141 ( $record, $offset ) = decode Net::DNS::Question( $data, $offset, $hash );
142 CORE::push( @{$self->{question}}, $record );
143 }
144
145 # RR sections
146 while ( $an-- ) {
147 ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
148 CORE::push( @{$self->{answer}}, $record );
149 }
150
151 while ( $ns-- ) {
152 ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
153 CORE::push( @{$self->{authority}}, $record );
154 }
155
156 while ( $ar-- ) {
157 ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
158 CORE::push( @{$self->{additional}}, $record );
159 }
160
161 return unless $offset == HEADER_LENGTH;
162 return unless $self->header->opcode eq 'DSO';
163
164 $self->{dso} = [];
165 my $limit = $length - 4;
166 while ( $offset < $limit ) {
167 my ( $t, $l, $v ) = unpack "\@$offset n2a*", $$data;
168 CORE::push( @{$self->{dso}}, [$t, substr( $v, 0, $l )] );
169 $offset += ( $l + 4 );
170 }
171 };
172
173 if ($debug) {
174 local $@ = $@;
175 print $@ if $@;
176 $self->print if $self;
177 }
178
179 return wantarray ? ( $self, $offset ) : $self;
180}
181
182
183=head2 data
184
185 $data = $packet->data;
186 $data = $packet->data( $size );
187
188Returns the packet data in binary format, suitable for sending as a
189query or update request to a nameserver.
190
191Truncation may be specified using a non-zero optional size argument.
192
193=cut
194
195sub data {
196 return &encode;
197}
198
199sub encode {
200 my ( $self, $size ) = @_; # uncoverable pod
201
202 my $edns = $self->edns; # EDNS support
203 my @addl = grep { !$_->isa('Net::DNS::RR::OPT') } @{$self->{additional}};
204 $self->{additional} = [$edns, @addl] if $edns->_specified;
205
206 return $self->truncate($size) if $size;
207
208 my @part = qw(question answer authority additional);
209 my @size = map { scalar @{$self->{$_}} } @part;
210 my $data = pack 'n6', $self->header->id, $self->{status}, @size;
211 $self->{count} = [];
212
213 my $hash = {}; # packet body
214 foreach my $component ( map { @{$self->{$_}} } @part ) {
215 $data .= $component->encode( length $data, $hash, $self );
216 }
217
218 return $data;
219}
220
221
222=head2 header
223
224 $header = $packet->header;
225
226Constructor method which returns a Net::DNS::Header object which
227represents the header section of the packet.
228
229=cut
230
231sub header {
232 my $self = shift;
233 return bless \$self, q(Net::DNS::Header);
234}
235
236
237=head2 edns
238
239 $edns = $packet->edns;
240 $version = $edns->version;
241 $UDPsize = $edns->size;
242
243Auxiliary function which provides access to the EDNS protocol
244extension OPT RR.
245
246=cut
247
248sub edns {
249 my $self = shift;
250 my $link = \$self->{xedns};
251 ($$link) = grep { $_->isa(qw(Net::DNS::RR::OPT)) } @{$self->{additional}} unless $$link;
252 $$link = Net::DNS::RR->new( type => 'OPT' ) unless $$link;
253 return $$link;
254}
255
256
257=head2 reply
258
259 $reply = $query->reply( $UDPmax );
260
261Constructor method which returns a new reply packet.
262
263The optional UDPsize argument is the maximum UDP packet size which
264can be reassembled by the local network stack, and is advertised in
265response to an EDNS query.
266
267=cut
268
269sub reply {
270 my $query = shift;
271 my $UDPmax = shift;
272 my $qheadr = $query->header;
273 croak 'erroneous qr flag in query packet' if $qheadr->qr;
274
275 my $reply = Net::DNS::Packet->new();
276 my $header = $reply->header;
277 $header->qr(1); # reply with same id, opcode and question
278 $header->id( $qheadr->id );
279 $header->opcode( $qheadr->opcode );
280 my @question = $query->question;
281 $reply->{question} = [@question];
282
283 $header->rcode('FORMERR'); # no RCODE considered sinful!
284
285 $header->rd( $qheadr->rd ); # copy these flags into reply
286 $header->cd( $qheadr->cd );
287
288 return $reply unless grep { $_->isa('Net::DNS::RR::OPT') } @{$query->{additional}};
289
290 my $edns = $reply->edns();
291 CORE::push( @{$reply->{additional}}, $edns );
292 $edns->size($UDPmax);
293 return $reply;
294}
295
296
297=head2 question, zone
298
299 @question = $packet->question;
300
301Returns a list of Net::DNS::Question objects representing the
302question section of the packet.
303
304In dynamic update packets, this section is known as zone() and
305specifies the DNS zone to be updated.
306
307=cut
308
309sub question {
310 my @qr = @{shift->{question}};
311 return @qr;
312}
313
314sub zone { return &question }
315
316
317=head2 answer, pre, prerequisite
318
319 @answer = $packet->answer;
320
321Returns a list of Net::DNS::RR objects representing the answer
322section of the packet.
323
324In dynamic update packets, this section is known as pre() or
325prerequisite() and specifies the RRs or RRsets which must or must
326not preexist.
327
328=cut
329
330sub answer {
331 my @rr = @{shift->{answer}};
332 return @rr;
333}
334
335sub pre { return &answer }
336sub prerequisite { return &answer }
337
338
339=head2 authority, update
340
341 @authority = $packet->authority;
342
343Returns a list of Net::DNS::RR objects representing the authority
344section of the packet.
345
346In dynamic update packets, this section is known as update() and
347specifies the RRs or RRsets to be added or deleted.
348
349=cut
350
351sub authority {
352 my @rr = @{shift->{authority}};
353 return @rr;
354}
355
356sub update { return &authority }
357
358
359=head2 additional
360
361 @additional = $packet->additional;
362
363Returns a list of Net::DNS::RR objects representing the additional
364section of the packet.
365
366=cut
367
368sub additional {
369 my @rr = @{shift->{additional}};
370 return @rr;
371}
372
373
374=head2 print
375
376 $packet->print;
377
378Prints the entire packet to the currently selected output filehandle
379using the master file format mandated by RFC1035.
380
381=cut
382
383sub print {
384 print &string;
385 return;
386}
387
388
389=head2 string
390
391 print $packet->string;
392
393Returns a string representation of the packet.
394
395=cut
396
397sub string {
398 my $self = shift;
399
400 my $header = $self->header;
401 my $server = $self->{replyfrom};
402 my $length = $self->{replysize};
403 my $origin = $server ? ";; Response received from $server ($length octets)\n" : "";
404 my @record = ( "$origin;; HEADER SECTION", $header->string );
405
406 if ( $self->{dso} ) {
407 CORE::push( @record, ";; DSO SECTION" );
408 foreach ( @{$self->{dso}} ) {
409 my ( $t, $v ) = @$_;
410 CORE::push( @record, pack 'a* A18 a*', ";;\t", dsotypebyval($t), unpack( 'H*', $v ) );
411 }
412 return join "\n", @record, "\n";
413 }
414
415 my @section = $header->opcode eq 'UPDATE' ? qw(ZONE PREREQUISITE UPDATE) : qw(QUESTION ANSWER AUTHORITY);
416 my @question = $self->question;
417 my $qdcount = scalar @question;
418 my $qds = $qdcount != 1 ? 's' : '';
419 CORE::push( @record, ";; $section[0] SECTION ($qdcount record$qds)", map { ';; ' . $_->string } @question );
420
421 my @answer = $self->answer;
422 my $ancount = scalar @answer;
423 my $ans = $ancount != 1 ? 's' : '';
424 CORE::push( @record, "\n;; $section[1] SECTION ($ancount record$ans)", map { $_->string } @answer );
425
426 my @authority = $self->authority;
427 my $nscount = scalar @authority;
428 my $nss = $nscount != 1 ? 's' : '';
429 CORE::push( @record, "\n;; $section[2] SECTION ($nscount record$nss)", map { $_->string } @authority );
430
431 my @additional = $self->additional;
432 my $arcount = scalar @additional;
433 my $ars = $arcount != 1 ? 's' : '';
434 CORE::push( @record, "\n;; ADDITIONAL SECTION ($arcount record$ars)", map { $_->string } @additional );
435
436 return join "\n", @record, "\n";
437}
438
439
440=head2 from
441
442 print "packet received from ", $packet->from, "\n";
443
444Returns the IP address from which this packet was received.
445This method will return undef for user-created packets.
446
447=cut
448
449sub from {
450 my $self = shift;
451
452 $self->{replyfrom} = shift if scalar @_;
453 return $self->{replyfrom};
454}
455
456sub answerfrom { return &from; } # uncoverable pod
457
458
459=head2 size
460
461 print "packet size: ", $packet->size, " octets\n";
462
463Returns the size of the packet in octets as it was received from a
464nameserver. This method will return undef for user-created packets
465(use length($packet->data) instead).
466
467=cut
468
469sub size {
470 return shift->{replysize};
471}
472
473sub answersize { return &size; } # uncoverable pod
474
475
476=head2 push
477
478 $ancount = $packet->push( prereq => $rr );
479 $nscount = $packet->push( update => $rr );
480 $arcount = $packet->push( additional => $rr );
481
482 $nscount = $packet->push( update => $rr1, $rr2, $rr3 );
483 $nscount = $packet->push( update => @rr );
484
485Adds RRs to the specified section of the packet.
486
487Returns the number of resource records in the specified section.
488
489Section names may be abbreviated to the first three characters.
490
491=cut
492
493sub push {
494 my $self = shift;
495 my $list = $self->_section(shift);
496 return CORE::push( @$list, grep { ref($_) } @_ );
497}
498
499
500=head2 unique_push
501
502 $ancount = $packet->unique_push( prereq => $rr );
503 $nscount = $packet->unique_push( update => $rr );
504 $arcount = $packet->unique_push( additional => $rr );
505
506 $nscount = $packet->unique_push( update => $rr1, $rr2, $rr3 );
507 $nscount = $packet->unique_push( update => @rr );
508
509Adds RRs to the specified section of the packet provided that the
510RRs are not already present in the same section.
511
512Returns the number of resource records in the specified section.
513
514Section names may be abbreviated to the first three characters.
515
516=cut
517
518sub unique_push {
519 my $self = shift;
520 my $list = $self->_section(shift);
521 my @rr = grep { ref($_) } @_;
522
523 my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list;
524
525 return scalar( @$list = values %unique );
526}
527
528
529=head2 pop
530
531 my $rr = $packet->pop( 'pre' );
532 my $rr = $packet->pop( 'update' );
533 my $rr = $packet->pop( 'additional' );
534
535Removes a single RR from the specified section of the packet.
536
537=cut
538
539sub pop {
540 my $self = shift;
541 my $list = $self->_section(shift);
542 return CORE::pop(@$list);
543}
544
545
546my %_section = ( ## section name abbreviation table
547 'ans' => 'answer',
548 'pre' => 'answer',
549 'aut' => 'authority',
550 'upd' => 'authority',
551 'add' => 'additional'
552 );
553
554sub _section { ## returns array reference for section
555 my $self = shift;
556 my $name = shift;
557 my $list = $_section{unpack 'a3', $name} || $name;
558 return $self->{$list} ||= [];
559}
560
561
562=head2 sign_tsig
563
564 $query = Net::DNS::Packet->new( 'www.example.com', 'A' );
565
566 $query->sign_tsig(
567 'Khmac-sha512.example.+165+01018.private',
568 fudge => 60
569 );
570
571 $reply = $res->send( $query );
572
573 $reply->verify( $query ) || die $reply->verifyerr;
574
575Attaches a TSIG resource record object, which will be used to sign
576the packet (see RFC 2845).
577
578The TSIG record can be customised by optional additional arguments to
579sign_tsig() or by calling the appropriate Net::DNS::RR::TSIG methods.
580
581If you wish to create a TSIG record using a non-standard algorithm,
582you will have to create it yourself. In all cases, the TSIG name
583must uniquely identify the key shared between the parties, and the
584algorithm name must identify the signing function to be used with the
585specified key.
586
587 $tsig = Net::DNS::RR->new(
588 name => 'tsig.example',
589 type => 'TSIG',
590 algorithm => 'custom-algorithm',
591 key => '<base64 key text>',
592 sig_function => sub {
593 my ($key, $data) = @_;
594 ...
595 }
596 );
597
598 $query->sign_tsig( $tsig );
599
600
601The historical simplified syntax is still available, but additional
602options can not be specified.
603
604 $packet->sign_tsig( $key_name, $key );
605
606
607The response to an inbound request is signed by presenting the request
608in place of the key parameter.
609
610 $response = $request->reply;
611 $response->sign_tsig( $request, @options );
612
613
614Multi-packet transactions are signed by chaining the sign_tsig()
615calls together as follows:
616
617 $opaque = $packet1->sign_tsig( 'Kexample.+165+13281.private' );
618 $opaque = $packet2->sign_tsig( $opaque );
619 $packet3->sign_tsig( $opaque );
620
621The opaque intermediate object references returned during multi-packet
622signing are not intended to be accessed by the end-user application.
623Any such access is expressly forbidden.
624
625Note that a TSIG record is added to every packet; this implementation
626does not support the suppressed signature scheme described in RFC2845.
627
628=cut
629
630sub sign_tsig {
631 my $self = shift;
632
633 return eval {
634 local $SIG{__DIE__};
635 require Net::DNS::RR::TSIG;
636 my $tsig = Net::DNS::RR::TSIG->create(@_);
637 $self->push( 'additional' => $tsig );
638 return $tsig;
639 } || return croak "$@\nTSIG: unable to sign packet";
640}
641
642
643=head2 verify and verifyerr
644
645 $packet->verify() || die $packet->verifyerr;
646 $reply->verify( $query ) || die $reply->verifyerr;
647
648Verify TSIG signature of packet or reply to the corresponding query.
649
650
651 $opaque = $packet1->verify( $query ) || die $packet1->verifyerr;
652 $opaque = $packet2->verify( $opaque );
653 $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr;
654
655The opaque intermediate object references returned during multi-packet
656verify() will be undefined (Boolean false) if verification fails.
657Access to the object itself, if it exists, is expressly forbidden.
658Testing at every stage may be omitted, which results in a BADSIG error
659on the final packet in the absence of more specific information.
660
661=cut
662
663sub verify {
664 my $self = shift;
665
666 my $sig = $self->sigrr;
667 return $sig ? $sig->verify( $self, @_ ) : shift;
668}
669
670sub verifyerr {
671 my $self = shift;
672
673 my $sig = $self->sigrr;
674 return $sig ? $sig->vrfyerrstr : 'not signed';
675}
676
677
678=head2 sign_sig0
679
680SIG0 support is provided through the Net::DNS::RR::SIG class.
681The requisite cryptographic components are not integrated into
682Net::DNS but reside in the Net::DNS::SEC distribution available
683from CPAN.
684
685 $update = Net::DNS::Update->new('example.com');
686 $update->push( update => rr_add('foo.example.com A 10.1.2.3'));
687 $update->sign_sig0('Kexample.com+003+25317.private');
688
689Execution will be terminated if Net::DNS::SEC is not available.
690
691
692=head2 verify SIG0
693
694 $packet->verify( $keyrr ) || die $packet->verifyerr;
695 $packet->verify( [$keyrr, ...] ) || die $packet->verifyerr;
696
697Verify SIG0 packet signature against one or more specified KEY RRs.
698
699=cut
700
701sub sign_sig0 {
702 my $self = shift;
703 my $karg = shift;
704
705 return eval {
706 local $SIG{__DIE__};
707
708 my $sig0;
709 if ( ref($karg) eq 'Net::DNS::RR::SIG' ) {
710 $sig0 = $karg;
711
712 } else {
713 require Net::DNS::RR::SIG;
714 $sig0 = Net::DNS::RR::SIG->create( '', $karg );
715 }
716
717 $self->push( 'additional' => $sig0 );
718 return $sig0;
719 } || return croak "$@\nSIG0: unable to sign packet";
720}
721
722
723=head2 sigrr
724
725 $sigrr = $packet->sigrr() || die 'unsigned packet';
726
727The sigrr method returns the signature RR from a signed packet
728or undefined if the signature is absent.
729
730=cut
731
732sub sigrr {
733 my $self = shift;
734
735 my ($sig) = reverse $self->additional;
736 return unless $sig;
737 return $sig if $sig->type eq 'TSIG';
738 return $sig if $sig->type eq 'SIG';
739 return;
740}
741
742
743########################################
744
745=head2 truncate
746
747The truncate method takes a maximum length as argument and then tries
748to truncate the packet and set the TC bit according to the rules of
749RFC2181 Section 9.
750
751The smallest length limit that is honoured is 512 octets.
752
753=cut
754
755# From RFC2181:
756#
757# 9. The TC (truncated) header bit
758#
759# The TC bit should be set in responses only when an RRSet is required
760# as a part of the response, but could not be included in its entirety.
761# The TC bit should not be set merely because some extra information
762# could have been included, for which there was insufficient room. This
763# includes the results of additional section processing. In such cases
764# the entire RRSet that will not fit in the response should be omitted,
765# and the reply sent as is, with the TC bit clear. If the recipient of
766# the reply needs the omitted data, it can construct a query for that
767# data and send that separately.
768#
769# Where TC is set, the partial RRSet that would not completely fit may
770# be left in the response. When a DNS client receives a reply with TC
771# set, it should ignore that response, and query again, using a
772# mechanism, such as a TCP connection, that will permit larger replies.
773
774# Code developed from a contribution by Aaron Crane via rt.cpan.org 33547
775
776sub truncate {
777 my $self = shift;
778 my $size = shift || UDPSZ;
779
780 my $sigrr = $self->sigrr;
781 $size = UDPSZ unless $size > UDPSZ;
782 $size -= $sigrr->_size if $sigrr;
783
784 my $data = pack 'x' x HEADER_LENGTH; # header placeholder
785 $self->{count} = [];
786
787 my $tc;
788 my $hash = {};
789 foreach my $section ( map { $self->{$_} } qw(question answer authority) ) {
790 my @list;
791 foreach my $item (@$section) {
792 my $component = $item->encode( length $data, $hash );
793 last if length($data) + length($component) > $size;
794 last if $tc;
795 $data .= $component;
796 CORE::push @list, $item;
797 }
798 $tc++ if scalar(@list) < scalar(@$section);
799 @$section = @list;
800 }
801 $self->header->tc(1) if $tc; # only set if truncated here
802
803 my %rrset;
804 my @order;
805 foreach my $item ( grep { ref($_) ne ref($sigrr) } $self->additional ) {
806 my $name = $item->{owner}->canonical;
807 my $class = $item->{class} || 0;
808 my $key = pack 'nna*', $class, $item->{type}, $name;
809 CORE::push @order, $key unless $rrset{$key};
810 CORE::push @{$rrset{$key}}, $item;
811 }
812
813 my @list;
814 foreach my $key (@order) {
815 my $component = '';
816 my @item = @{$rrset{$key}};
817 foreach my $item (@item) {
818 $component .= $item->encode( length $data, $hash );
819 }
820 last if length($data) + length($component) > $size;
821 $data .= $component;
822 CORE::push @list, @item;
823 }
824
825 if ($sigrr) {
826 $data .= $sigrr->encode( length $data, $hash, $self );
827 CORE::push @list, $sigrr;
828 }
829 $self->{'additional'} = \@list;
830
831 my @part = qw(question answer authority additional);
832 my @size = map { scalar @{$self->{$_}} } @part;
833 return pack 'n6 a*', $self->header->id, $self->{status}, @size, substr( $data, HEADER_LENGTH );
834}
835
836
837########################################
838
839sub dump { ## print internal data structure
840 require Data::Dumper; # uncoverable pod
841 local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3;
842 local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1;
843 print Data::Dumper::Dumper(@_);
844 return;
845}
846
847
8481;
849__END__