← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:19 2017

Filename/usr/local/lib/perl5/site_perl/Net/DNS/Packet.pm
StatementsExecuted 94482 statements in 713ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
196811406ms1.31sNet::DNS::Packet::::encodeNet::DNS::Packet::encode
196811114ms778msNet::DNS::Packet::::newNet::DNS::Packet::new
39362285.2ms447msNet::DNS::Packet::::ednsNet::DNS::Packet::edns
59043250.6ms50.6msNet::DNS::Packet::::headerNet::DNS::Packet::header
19681126.4ms26.4msNet::DNS::Packet::::questionNet::DNS::Packet::question
19681124.9ms1.34sNet::DNS::Packet::::dataNet::DNS::Packet::data
1969219.21ms9.21msNet::DNS::Packet::::CORE:packNet::DNS::Packet::CORE:pack (opcode)
1116.20ms8.75msNet::DNS::Packet::::BEGIN@36Net::DNS::Packet::BEGIN@36
11146µs63µsNet::DNS::Packet::::BEGIN@29Net::DNS::Packet::BEGIN@29
11145µs246µsNet::DNS::Packet::::BEGIN@107Net::DNS::Packet::BEGIN@107
11127µs213µsNet::DNS::Packet::::BEGIN@32Net::DNS::Packet::BEGIN@32
11125µs31µsNet::DNS::Packet::::BEGIN@31Net::DNS::Packet::BEGIN@31
11123µs51µsNet::DNS::Packet::::BEGIN@30Net::DNS::Packet::BEGIN@30
11119µs246µsNet::DNS::Packet::::BEGIN@34Net::DNS::Packet::BEGIN@34
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::::decodeNet::DNS::Packet::decode
0000s0sNet::DNS::Packet::::dumpNet::DNS::Packet::dump
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::::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::::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
3#
4# $Id: Packet.pm 1584 2017-07-28 16:15:17Z willem $
5#
613µsour $VERSION = (qw$LastChangedRevision: 1584 $)[1];
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 = new Net::DNS::Packet( '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
29275µs280µs
# spent 63µs (46+17) within Net::DNS::Packet::BEGIN@29 which was called: # once (46µs+17µs) by Net::DNS::Resolver::Base::BEGIN@57 at line 29
use strict;
# spent 63µs making 1 call to Net::DNS::Packet::BEGIN@29 # spent 17µs making 1 call to strict::import
30283µs279µs
# spent 51µs (23+28) within Net::DNS::Packet::BEGIN@30 which was called: # once (23µs+28µs) by Net::DNS::Resolver::Base::BEGIN@57 at line 30
use warnings;
# spent 51µs making 1 call to Net::DNS::Packet::BEGIN@30 # spent 28µs making 1 call to warnings::import
312587µs236µs
# spent 31µs (25+6) within Net::DNS::Packet::BEGIN@31 which was called: # once (25µs+6µs) by Net::DNS::Resolver::Base::BEGIN@57 at line 31
use integer;
# spent 31µs making 1 call to Net::DNS::Packet::BEGIN@31 # spent 6µs making 1 call to integer::import
32290µs2398µs
# spent 213µs (27+185) within Net::DNS::Packet::BEGIN@32 which was called: # once (27µs+185µs) by Net::DNS::Resolver::Base::BEGIN@57 at line 32
use Carp;
# spent 213µs making 1 call to Net::DNS::Packet::BEGIN@32 # spent 186µs making 1 call to Exporter::import
33
34294µs2473µs
# spent 246µs (19+227) within Net::DNS::Packet::BEGIN@34 which was called: # once (19µs+227µs) by Net::DNS::Resolver::Base::BEGIN@57 at line 34
use constant UDPSZ => 512;
# spent 246µs making 1 call to Net::DNS::Packet::BEGIN@34 # spent 227µs making 1 call to constant::import
35
36
# spent 8.75ms (6.20+2.55) within Net::DNS::Packet::BEGIN@36 which was called: # once (6.20ms+2.55ms) by Net::DNS::Resolver::Base::BEGIN@57 at line 40
BEGIN {
371264µs require Net::DNS::Header;
381267µs require Net::DNS::Question;
39115µs require Net::DNS::RR;
401292µs18.75ms}
# spent 8.75ms making 1 call to Net::DNS::Packet::BEGIN@36
41
42
43=head1 METHODS
44
45=head2 new
46
47 $packet = new Net::DNS::Packet( 'example.com' );
48 $packet = new Net::DNS::Packet( 'example.com', 'MX', 'IN' );
49
50 $packet = new Net::DNS::Packet();
51
52If passed a domain, type, and class, new() creates a Net::DNS::Packet
53object which is suitable for making a DNS query for the specified
54information. The type and class may be omitted; they default to A
55and IN.
56
57If called with an empty argument list, new() creates an empty packet.
58
59=cut
60
61
# spent 778ms (114+665) within Net::DNS::Packet::new which was called 1968 times, avg 396µs/call: # 1968 times (114ms+665ms) by Mail::SpamAssassin::DnsResolver::new_dns_packet at line 577 of Mail/SpamAssassin/DnsResolver.pm, avg 396µs/call
sub new {
6219683.96ms return &decode if ref $_[1];
6319685.27ms my $class = shift;
64
65196825.7ms my $self = bless {
66 status => 0,
67 question => [],
68 answer => [],
69 authority => [],
70 additional => [],
71 }, $class;
72
73196828.9ms1968665ms $self->{question} = [Net::DNS::Question->new(@_)] if scalar @_;
# spent 665ms making 1968 calls to Net::DNS::Question::new, avg 338µs/call
74
75196826.5ms return $self;
76}
77
78
79#=head2 decode
80
81=pod
82
83 $packet = new Net::DNS::Packet( \$data );
84 $packet = new Net::DNS::Packet( \$data, 1 ); # debug
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 ) = new Net::DNS::Packet( \$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
10724.89ms3448µs
# spent 246µs (45+202) within Net::DNS::Packet::BEGIN@107 which was called: # once (45µs+202µs) by Net::DNS::Resolver::Base::BEGIN@57 at line 107
use constant HEADER_LENGTH => length pack 'n6', (0) x 6;
# spent 246µs making 1 call to Net::DNS::Packet::BEGIN@107 # spent 197µs making 1 call to constant::import # spent 4µs making 1 call to Net::DNS::Packet::CORE:pack
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 $offset = HEADER_LENGTH;
124
125 $self = bless {
126 id => $id,
127 status => $status,
128 count => [@count],
129 question => [],
130 answer => [],
131 authority => [],
132 additional => [],
133 answersize => length $$data
134 }, $class;
135
136 # question/zone section
137 my $hash = {};
138 my $record;
139 while ( $qd-- ) {
140 ( $record, $offset ) = decode Net::DNS::Question( $data, $offset, $hash );
141 CORE::push( @{$self->{question}}, $record );
142 }
143
144 # RR sections
145 while ( $an-- ) {
146 ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
147 CORE::push( @{$self->{answer}}, $record );
148 }
149
150 while ( $ns-- ) {
151 ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
152 CORE::push( @{$self->{authority}}, $record );
153 }
154
155 while ( $ar-- ) {
156 ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
157 CORE::push( @{$self->{additional}}, $record );
158 }
159
160 return $self;
161 };
162
163 if ($debug) {
164 local $@ = $@;
165 print $@ if $@;
166 $self->print if $self;
167 }
168
169 return wantarray ? ( $self, $offset ) : $self;
170}
171
172
173=head2 data
174
175 $data = $packet->data;
176 $data = $packet->data( $size );
177
178Returns the packet data in binary format, suitable for sending as a
179query or update request to a nameserver.
180
181Truncation may be specified using a non-zero optional size argument.
182
183=cut
184
185
# spent 1.34s (24.9ms+1.31) within Net::DNS::Packet::data which was called 1968 times, avg 680µs/call: # 1968 times (24.9ms+1.31s) by Mail::SpamAssassin::DnsResolver::bgsend at line 703 of Mail/SpamAssassin/DnsResolver.pm, avg 680µs/call
sub data {
186196824.6ms19681.31s &encode;
# spent 1.31s making 1968 calls to Net::DNS::Packet::encode, avg 667µs/call
187}
188
189
# spent 1.31s (406ms+908ms) within Net::DNS::Packet::encode which was called 1968 times, avg 667µs/call: # 1968 times (406ms+908ms) by Net::DNS::Packet::data at line 186, avg 667µs/call
sub encode {
19019683.97ms my ( $self, $size ) = @_; # uncoverable pod
191
192196812.5ms196823.5ms my $edns = $self->edns; # EDNS support
# spent 23.5ms making 1968 calls to Net::DNS::Packet::edns, avg 12µs/call
193393613.2ms my @addl = grep !$_->isa('Net::DNS::RR::OPT'), @{$self->{additional}};
194196826.4ms196826.5ms $self->{additional} = [$edns, @addl] if $edns->_specified;
# spent 26.5ms making 1968 calls to Net::DNS::RR::OPT::_specified, avg 13µs/call
195
19619683.28ms return $self->truncate($size) if $size;
197
19819687.82ms my @part = qw(question answer authority additional);
199984052.8ms my @size = map scalar( @{$self->{$_}} ), @part;
200196857.8ms590454.4ms my $data = pack 'n6', $self->header->id, $self->{status}, @size;
# spent 30.9ms making 1968 calls to Net::DNS::Header::id, avg 16µs/call # spent 14.3ms making 1968 calls to Net::DNS::Packet::header, avg 7µs/call # spent 9.21ms making 1968 calls to Net::DNS::Packet::CORE:pack, avg 5µs/call
201196814.6ms $self->{count} = [];
202
20319685.13ms my $hash = {}; # packet body
204984049.4ms foreach my $component ( map @{$self->{$_}}, @part ) {
205393671.2ms3936803ms $data .= $component->encode( length $data, $hash, $self );
# spent 536ms making 1968 calls to Net::DNS::Question::encode, avg 272µs/call # spent 267ms making 1968 calls to Net::DNS::RR::OPT::encode, avg 136µs/call
206 }
207
208196834.2ms return $data;
209}
210
211
212=head2 header
213
214 $header = $packet->header;
215
216Constructor method which returns a Net::DNS::Header object which
217represents the header section of the packet.
218
219=cut
220
221
# spent 50.6ms within Net::DNS::Packet::header which was called 5904 times, avg 9µs/call: # 1968 times (20.1ms+0s) by Mail::SpamAssassin::DnsResolver::_packet_id at line 622 of Mail/SpamAssassin/DnsResolver.pm, avg 10µs/call # 1968 times (16.3ms+0s) by Mail::SpamAssassin::DnsResolver::new_dns_packet at line 596 of Mail/SpamAssassin/DnsResolver.pm, avg 8µs/call # 1968 times (14.3ms+0s) by Net::DNS::Packet::encode at line 200, avg 7µs/call
sub header {
222590410.8ms my $self = shift;
223590493.1ms bless \$self, q(Net::DNS::Header);
224}
225
226
227=head2 edns
228
229 $edns = $packet->edns;
230 $version = $edns->version;
231 $UDPsize = $edns->size;
232
233Auxiliary function which provides access to the EDNS protocol
234extension OPT RR.
235
236=cut
237
238
# spent 447ms (85.2+361) within Net::DNS::Packet::edns which was called 3936 times, avg 113µs/call: # 1968 times (61.7ms+361ms) by Mail::SpamAssassin::DnsResolver::new_dns_packet at line 603 of Mail/SpamAssassin/DnsResolver.pm, avg 215µs/call # 1968 times (23.5ms+0s) by Net::DNS::Packet::encode at line 192, avg 12µs/call
sub edns {
23939367.07ms my $self = shift;
240393611.8ms my $link = \$self->{xedns};
241590416.9ms ($$link) = grep $_->isa(qw(Net::DNS::RR::OPT)), @{$self->{additional}} unless $$link;
242393619.7ms1968361ms $$link = new Net::DNS::RR( type => 'OPT' ) unless $$link;
# spent 361ms making 1968 calls to Net::DNS::RR::new, avg 184µs/call
243393640.8ms return $$link;
244}
245
246
247=head2 reply
248
249 $reply = $query->reply( $UDPmax );
250
251Constructor method which returns a new reply packet.
252
253The optional UDPsize argument is the maximum UDP packet size which
254can be reassembled by the local network stack, and is advertised in
255response to an EDNS query.
256
257=cut
258
259sub reply {
260 my $query = shift;
261 my $UDPmax = shift;
262 my $qheadr = $query->header;
263 croak 'erroneous qr flag in query packet' if $qheadr->qr;
264
265 my $reply = new Net::DNS::Packet();
266 my $header = $reply->header;
267 $header->qr(1); # reply with same id, opcode and question
268 $header->id( $qheadr->id );
269 $header->opcode( $qheadr->opcode );
270 my @question = $query->question;
271 $reply->{question} = [@question];
272
273 $header->rcode('FORMERR'); # no RCODE considered sinful!
274
275 $header->rd( $qheadr->rd ); # copy these flags into reply
276 $header->cd( $qheadr->cd );
277
278 return $reply unless grep $_->isa('Net::DNS::RR::OPT'), @{$query->{additional}};
279
280 my $edns = $reply->edns();
281 CORE::push( @{$reply->{additional}}, $edns );
282 $edns->size($UDPmax);
283 return $reply;
284}
285
286
287=head2 question, zone
288
289 @question = $packet->question;
290
291Returns a list of Net::DNS::Question objects representing the
292question section of the packet.
293
294In dynamic update packets, this section is known as zone() and
295specifies the DNS zone to be updated.
296
297=cut
298
299
# spent 26.4ms within Net::DNS::Packet::question which was called 1968 times, avg 13µs/call: # 1968 times (26.4ms+0s) by Mail::SpamAssassin::DnsResolver::_packet_id at line 624 of Mail/SpamAssassin/DnsResolver.pm, avg 13µs/call
sub question {
300393638.7ms my @qr = @{shift->{question}};
301}
302
303sub zone {&question}
304
305
306=head2 answer, pre, prerequisite
307
308 @answer = $packet->answer;
309
310Returns a list of Net::DNS::RR objects representing the answer
311section of the packet.
312
313In dynamic update packets, this section is known as pre() or
314prerequisite() and specifies the RRs or RRsets which must or must
315not preexist.
316
317=cut
318
319sub answer {
320 my @rr = @{shift->{answer}};
321}
322
323sub pre {&answer}
324sub prerequisite {&answer}
325
326
327=head2 authority, update
328
329 @authority = $packet->authority;
330
331Returns a list of Net::DNS::RR objects representing the authority
332section of the packet.
333
334In dynamic update packets, this section is known as update() and
335specifies the RRs or RRsets to be added or deleted.
336
337=cut
338
339sub authority {
340 my @rr = @{shift->{authority}};
341}
342
343sub update {&authority}
344
345
346=head2 additional
347
348 @additional = $packet->additional;
349
350Returns a list of Net::DNS::RR objects representing the additional
351section of the packet.
352
353=cut
354
355sub additional {
356 my @rr = @{shift->{additional}};
357}
358
359
360=head2 print
361
362 $packet->print;
363
364Prints the packet data on the standard output in an ASCII format
365similar to that used in DNS zone files.
366
367=cut
368
369sub print { print &string; }
370
371
372=head2 string
373
374 print $packet->string;
375
376Returns a string representation of the packet.
377
378=cut
379
380sub string {
381 my $self = shift;
382
383 my $header = $self->header;
384 my $update = $header->opcode eq 'UPDATE';
385
386 my $server = $self->{answerfrom};
387 my $length = $self->{answersize};
388 my $string = $server ? ";; Answer received from $server ($length bytes)\n" : "";
389
390 $string .= ";; HEADER SECTION\n" . $header->string;
391
392 my $question = $update ? 'ZONE' : 'QUESTION';
393 my @question = map $_->string, $self->question;
394 my $qdcount = scalar @question;
395 my $qds = $qdcount != 1 ? 's' : '';
396 $string .= join "\n;; ", "\n;; $question SECTION ($qdcount record$qds)", @question;
397
398 my $answer = $update ? 'PREREQUISITE' : 'ANSWER';
399 my @answer = map $_->string, $self->answer;
400 my $ancount = scalar @answer;
401 my $ans = $ancount != 1 ? 's' : '';
402 $string .= join "\n", "\n\n;; $answer SECTION ($ancount record$ans)", @answer;
403
404 my $authority = $update ? 'UPDATE' : 'AUTHORITY';
405 my @authority = map $_->string, $self->authority;
406 my $nscount = scalar @authority;
407 my $nss = $nscount != 1 ? 's' : '';
408 $string .= join "\n", "\n\n;; $authority SECTION ($nscount record$nss)", @authority;
409
410 my @additional = map $_->string, $self->additional;
411 my $arcount = scalar @additional;
412 my $ars = $arcount != 1 ? 's' : '';
413 $string .= join "\n", "\n\n;; ADDITIONAL SECTION ($arcount record$ars)", @additional;
414
415 return "$string\n\n";
416}
417
418
419=head2 answerfrom
420
421 print "packet received from ", $packet->answerfrom, "\n";
422
423Returns the IP address from which this packet was received.
424User-created packets will return undef for this method.
425
426=cut
427
428sub answerfrom {
429 my $self = shift;
430
431 $self->{answerfrom} = shift if scalar @_;
432 $self->{answerfrom};
433}
434
435
436=head2 answersize
437
438 print "packet size: ", $packet->answersize, " bytes\n";
439
440Returns the size of the packet in bytes as it was received from a
441nameserver. User-created packets will return undef for this method
442(use length($packet->data) instead).
443
444=cut
445
446sub answersize {
447 shift->{answersize};
448}
449
450
451=head2 push
452
453 $ancount = $packet->push( prereq => $rr );
454 $nscount = $packet->push( update => $rr );
455 $arcount = $packet->push( additional => $rr );
456
457 $nscount = $packet->push( update => $rr1, $rr2, $rr3 );
458 $nscount = $packet->push( update => @rr );
459
460Adds RRs to the specified section of the packet.
461
462Returns the number of resource records in the specified section.
463
464Section names may be abbreviated to the first three characters.
465
466=cut
467
468sub push {
469 my $self = shift;
470 my $list = $self->_section(shift);
471 CORE::push( @$list, grep ref($_), @_ );
472}
473
474
475=head2 unique_push
476
477 $ancount = $packet->unique_push( prereq => $rr );
478 $nscount = $packet->unique_push( update => $rr );
479 $arcount = $packet->unique_push( additional => $rr );
480
481 $nscount = $packet->unique_push( update => $rr1, $rr2, $rr3 );
482 $nscount = $packet->unique_push( update => @rr );
483
484Adds RRs to the specified section of the packet provided that the
485RRs are not already present in the same section.
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 unique_push {
494 my $self = shift;
495 my $list = $self->_section(shift);
496 my @rr = grep ref($_), @_;
497
498 my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list;
499
500 scalar( @$list = values %unique );
501}
502
503
504=head2 pop
505
506 my $rr = $packet->pop( 'pre' );
507 my $rr = $packet->pop( 'update' );
508 my $rr = $packet->pop( 'additional' );
509
510Removes a single RR from the specified section of the packet.
511
512=cut
513
514sub pop {
515 my $self = shift;
516 my $list = $self->_section(shift);
517 CORE::pop(@$list);
518}
519
520
52119µsmy %_section = ( ## section name abbreviation table
522 'ans' => 'answer',
523 'pre' => 'answer',
524 'aut' => 'authority',
525 'upd' => 'authority',
526 'add' => 'additional'
527 );
528
529sub _section { ## returns array reference for section
530 my $self = shift;
531 my $name = shift;
532 my $list = $_section{unpack 'a3', $name} || $name;
533 $self->{$list} ||= [];
534}
535
536
537=head2 sign_tsig
538
539 $query = Net::DNS::Packet->new( 'www.example.com', 'A' );
540
541 $query->sign_tsig(
542 'Khmac-sha512.example.+165+01018.private',
543 fudge => 60
544 );
545
546 $reply = $res->send( $query );
547
548 $reply->verify( $query ) || die $reply->verifyerr;
549
550Attaches a TSIG resource record object, which will be used to sign
551the packet (see RFC 2845).
552
553The TSIG record can be customised by optional additional arguments to
554sign_tsig() or by calling the appropriate Net::DNS::RR::TSIG methods.
555
556If you wish to create a TSIG record using a non-standard algorithm,
557you will have to create it yourself. In all cases, the TSIG name
558must uniquely identify the key shared between the parties, and the
559algorithm name must identify the signing function to be used with the
560specified key.
561
562 $tsig = Net::DNS::RR->new(
563 name => 'tsig.example',
564 type => 'TSIG',
565 algorithm => 'custom-algorithm',
566 key => '<base64 key text>',
567 sig_function => sub {
568 my ($key, $data) = @_;
569 ...
570 }
571 );
572
573 $query->sign_tsig( $tsig );
574
575
576The historical simplified syntax is still available, but additional
577options can not be specified.
578
579 $packet->sign_tsig( $key_name, $key );
580
581
582The response to an inbound request is signed by presenting the request
583in place of the key parameter.
584
585 $response = $request->reply;
586 $response->sign_tsig( $request, @options );
587
588
589Multi-packet transactions are signed by chaining the sign_tsig()
590calls together as follows:
591
592 $opaque = $packet1->sign_tsig( 'Kexample.+165+13281.private' );
593 $opaque = $packet2->sign_tsig( $opaque );
594 $packet3->sign_tsig( $opaque );
595
596The opaque intermediate object references returned during multi-packet
597signing are not intended to be accessed by the end-user application.
598Any such access is expressly forbidden.
599
600Note that a TSIG record is added to every packet; this implementation
601does not support the suppressed signature scheme described in RFC2845.
602
603=cut
604
605sub sign_tsig {
606 my $self = shift;
607
608 eval {
609 local $SIG{__DIE__};
610 require Net::DNS::RR::TSIG;
611 my $tsig = Net::DNS::RR::TSIG->create(@_);
612 $self->push( 'additional' => $tsig );
613 return $tsig;
614 } || do {
615 croak "$@\nTSIG: unable to sign packet";
616 };
617}
618
619
620=head2 verify and verifyerr
621
622 $packet->verify() || die $packet->verifyerr;
623 $reply->verify( $query ) || die $reply->verifyerr;
624
625Verify TSIG signature of packet or reply to the corresponding query.
626
627
628 $opaque = $packet1->verify( $query ) || die $packet1->verifyerr;
629 $opaque = $packet2->verify( $opaque );
630 $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr;
631
632The opaque intermediate object references returned during multi-packet
633verify() will be undefined (Boolean false) if verification fails.
634Access to the object itself, if it exists, is expressly forbidden.
635Testing at every stage may be omitted, which results in a BADSIG error
636on the final packet in the absence of more specific information.
637
638=cut
639
640sub verify {
641 my $self = shift;
642
643 my $sig = $self->sigrr;
644 return $sig ? $sig->verify( $self, @_ ) : shift;
645}
646
647sub verifyerr {
648 my $self = shift;
649
650 my $sig = $self->sigrr;
651 return $sig ? $sig->vrfyerrstr : 'not signed';
652}
653
654
655=head2 sign_sig0
656
657SIG0 support is provided through the Net::DNS::RR::SIG class.
658The requisite cryptographic components are not integrated into
659Net::DNS but reside in the Net::DNS::SEC distribution available
660from CPAN.
661
662 $update = new Net::DNS::Update('example.com');
663 $update->push( update => rr_add('foo.example.com A 10.1.2.3'));
664 $update->sign_sig0('Kexample.com+003+25317.private');
665
666Execution will be terminated if Net::DNS::SEC is not available.
667
668
669=head2 verify SIG0
670
671 $packet->verify( $keyrr ) || die $packet->verifyerr;
672 $packet->verify( [$keyrr, ...] ) || die $packet->verifyerr;
673
674Verify SIG0 packet signature against one or more specified KEY RRs.
675
676=cut
677
678sub sign_sig0 {
679 my $self = shift;
680 my $karg = shift;
681
682 eval {
683 local $SIG{__DIE__};
684 require Net::DNS::RR::SIG;
685
686 my $sig0;
687 if ( ref($karg) eq 'Net::DNS::RR::SIG' ) {
688 $sig0 = $karg;
689
690 } else {
691 $sig0 = Net::DNS::RR::SIG->create( '', $karg );
692 }
693
694 $self->push( 'additional' => $sig0 );
695 return $sig0;
696 } || do {
697 croak "$@\nSIG0: unable to sign packet";
698 };
699}
700
701
702=head2 sigrr
703
704 $sigrr = $packet->sigrr() || die 'unsigned packet';
705
706The sigrr method returns the signature RR from a signed packet
707or undefined if the signature is absent.
708
709=cut
710
711sub sigrr {
712 my $self = shift;
713
714 my ($sig) = reverse $self->additional;
715 return undef unless $sig;
716 return $sig if $sig->type eq 'TSIG';
717 return $sig if $sig->type eq 'SIG';
718 return undef;
719}
720
721
722########################################
723
724=head2 truncate
725
726The truncate method takes a maximum length as argument and then tries
727to truncate the packet and set the TC bit according to the rules of
728RFC2181 Section 9.
729
730The smallest length limit that is honoured is 512 octets.
731
732=cut
733
734# From RFC2181:
735#
736# 9. The TC (truncated) header bit
737#
738# The TC bit should be set in responses only when an RRSet is required
739# as a part of the response, but could not be included in its entirety.
740# The TC bit should not be set merely because some extra information
741# could have been included, for which there was insufficient room. This
742# includes the results of additional section processing. In such cases
743# the entire RRSet that will not fit in the response should be omitted,
744# and the reply sent as is, with the TC bit clear. If the recipient of
745# the reply needs the omitted data, it can construct a query for that
746# data and send that separately.
747#
748# Where TC is set, the partial RRSet that would not completely fit may
749# be left in the response. When a DNS client receives a reply with TC
750# set, it should ignore that response, and query again, using a
751# mechanism, such as a TCP connection, that will permit larger replies.
752
753# Code developed from a contribution by Aaron Crane via rt.cpan.org 33547
754
755sub truncate {
756 my $self = shift;
757 my $size = shift || UDPSZ;
758
759 my $sigrr = $self->sigrr;
760 $size = UDPSZ unless $size > UDPSZ;
761 $size -= $sigrr->_size if $sigrr;
762
76316µs my $data = pack 'x' x HEADER_LENGTH; # header placeholder
# spent 6µs making 1 call to main::CORE:pack
764 $self->{count} = [];
765
766 my $tc;
767 my $hash = {};
768 foreach my $section ( map $self->{$_}, qw(question answer authority) ) {
769 my @list;
770 foreach my $item (@$section) {
771 my $component = $item->encode( length $data, $hash );
772 last if length($data) + length($component) > $size;
773 last if $tc;
774 $data .= $component;
775 CORE::push @list, $item;
776 }
777 $tc++ if scalar(@list) < scalar(@$section);
778 @$section = @list;
779 }
780 $self->header->tc(1) if $tc; # only set if truncated here
781
782 my %rrset;
783 my @order;
784 foreach my $item ( grep ref($_) ne ref($sigrr), $self->additional ) {
785 my $name = $item->{owner}->canonical;
786 my $class = $item->{class} || 0;
787 my $key = pack 'nna*', $class, $item->{type}, $name;
788 CORE::push @order, $key unless $rrset{$key};
789 CORE::push @{$rrset{$key}}, $item;
790 }
791
792 my @list;
793 foreach my $key (@order) {
794 my $component = '';
795 my @item = @{$rrset{$key}};
796 foreach my $item (@item) {
797 $component .= $item->encode( length $data, $hash );
798 }
799 last if length($data) + length($component) > $size;
800 $data .= $component;
801 CORE::push @list, @item;
802 }
803
804 if ($sigrr) {
805 $data .= $sigrr->encode( length $data, $hash, $self );
806 CORE::push @list, $sigrr;
807 }
808 $self->{'additional'} = \@list;
809
810 my @part = qw(question answer authority additional);
811 my @size = map scalar( @{$self->{$_}} ), @part;
812 pack 'n6 a*', $self->header->id, $self->{status}, @size, substr( $data, HEADER_LENGTH );
813}
814
815
816########################################
817
818sub dump { ## print internal data structure
819 require Data::Dumper; # uncoverable pod
820 local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3;
821 local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1;
822 print Data::Dumper::Dumper(@_);
823}
824
825
826114µs1;
827__END__
 
# spent 9.21ms within Net::DNS::Packet::CORE:pack which was called 1969 times, avg 5µs/call: # 1968 times (9.21ms+0s) by Net::DNS::Packet::encode at line 200, avg 5µs/call # once (4µs+0s) by Net::DNS::Packet::BEGIN@107 at line 107
sub Net::DNS::Packet::CORE:pack; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.