← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 03:09:29 2017
Reported on Mon Nov 6 13:20:47 2017

Filename/usr/local/lib/perl5/site_perl/Net/DNS/RR.pm
StatementsExecuted 47277 statements in 321ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
196811159ms291msNet::DNS::RR::::_new_hashNet::DNS::RR::_new_hash
19681162.4ms353msNet::DNS::RR::::newNet::DNS::RR::new
19681147.6ms53.3msNet::DNS::RR::::_subclassNet::DNS::RR::_subclass
19681136.4ms77.8msNet::DNS::RR::::ownerNet::DNS::RR::owner
11113.6ms15.7msNet::DNS::RR::::BEGIN@41Net::DNS::RR::BEGIN@41
11111.4ms19.3msNet::DNS::RR::::BEGIN@42Net::DNS::RR::BEGIN@42
1111.67ms2.64msNet::DNS::RR::::BEGIN@43Net::DNS::RR::BEGIN@43
11140µs49µsNet::DNS::RR::::BEGIN@34Net::DNS::RR::BEGIN@34
11137µs206µsNet::DNS::RR::::BEGIN@227Net::DNS::RR::BEGIN@227
11125µs80µsNet::DNS::RR::::BEGIN@758Net::DNS::RR::BEGIN@758
11123µs234µsNet::DNS::RR::::BEGIN@39Net::DNS::RR::BEGIN@39
11120µs46µsNet::DNS::RR::::BEGIN@35Net::DNS::RR::BEGIN@35
11119µs160µsNet::DNS::RR::::BEGIN@37Net::DNS::RR::BEGIN@37
11119µs24µsNet::DNS::RR::::BEGIN@36Net::DNS::RR::BEGIN@36
1116µs6µsNet::DNS::RR::::CORE:packNet::DNS::RR::CORE:pack (opcode)
1116µs6µsNet::DNS::RR::::_defaultsNet::DNS::RR::_defaults
1113µs3µsNet::DNS::RR::::CORE:substNet::DNS::RR::CORE:subst (opcode)
0000s0sNet::DNS::RR::::AUTOLOADNet::DNS::RR::AUTOLOAD
0000s0sNet::DNS::RR::::DESTROYNet::DNS::RR::DESTROY
0000s0sNet::DNS::RR::::__ANON__[:643]Net::DNS::RR::__ANON__[:643]
0000s0sNet::DNS::RR::::__ANON__[:688]Net::DNS::RR::__ANON__[:688]
0000s0sNet::DNS::RR::::__ANON__[:760]Net::DNS::RR::__ANON__[:760]
0000s0sNet::DNS::RR::::_annotationNet::DNS::RR::_annotation
0000s0sNet::DNS::RR::::_decode_rdataNet::DNS::RR::_decode_rdata
0000s0sNet::DNS::RR::::_emptyNet::DNS::RR::_empty
0000s0sNet::DNS::RR::::_encode_rdataNet::DNS::RR::_encode_rdata
0000s0sNet::DNS::RR::::_format_rdataNet::DNS::RR::_format_rdata
0000s0sNet::DNS::RR::::_new_stringNet::DNS::RR::_new_string
0000s0sNet::DNS::RR::::_parse_rdataNet::DNS::RR::_parse_rdata
0000s0sNet::DNS::RR::::_wrapNet::DNS::RR::_wrap
0000s0sNet::DNS::RR::::canonicalNet::DNS::RR::canonical
0000s0sNet::DNS::RR::::classNet::DNS::RR::class
0000s0sNet::DNS::RR::::decodeNet::DNS::RR::decode
0000s0sNet::DNS::RR::::dumpNet::DNS::RR::dump
0000s0sNet::DNS::RR::::encodeNet::DNS::RR::encode
0000s0sNet::DNS::RR::::genericNet::DNS::RR::generic
0000s0sNet::DNS::RR::::get_rrsort_funcNet::DNS::RR::get_rrsort_func
0000s0sNet::DNS::RR::::nameNet::DNS::RR::name
0000s0sNet::DNS::RR::::plainNet::DNS::RR::plain
0000s0sNet::DNS::RR::::printNet::DNS::RR::print
0000s0sNet::DNS::RR::::rdataNet::DNS::RR::rdata
0000s0sNet::DNS::RR::::rdatastrNet::DNS::RR::rdatastr
0000s0sNet::DNS::RR::::rdlengthNet::DNS::RR::rdlength
0000s0sNet::DNS::RR::::rdstringNet::DNS::RR::rdstring
0000s0sNet::DNS::RR::::set_rrsort_funcNet::DNS::RR::set_rrsort_func
0000s0sNet::DNS::RR::::stringNet::DNS::RR::string
0000s0sNet::DNS::RR::::tokenNet::DNS::RR::token
0000s0sNet::DNS::RR::::ttlNet::DNS::RR::ttl
0000s0sNet::DNS::RR::::typeNet::DNS::RR::type
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::RR;
2
3#
4# $Id: RR.pm 1597 2017-09-22 08:04:02Z willem $
5#
612µsour $VERSION = (qw$LastChangedRevision: 1597 $)[1];
7
8
9=head1 NAME
10
11Net::DNS::RR - DNS resource record base class
12
13=head1 SYNOPSIS
14
15 use Net::DNS;
16
17 $rr = new Net::DNS::RR('example.com IN A 192.0.2.99');
18
19 $rr = new Net::DNS::RR(
20 owner => 'example.com',
21 type => 'A',
22 address => '192.0.2.99'
23 );
24
25
26=head1 DESCRIPTION
27
28Net::DNS::RR is the base class for DNS Resource Record (RR) objects.
29See also the manual pages for each specific RR type.
30
31=cut
32
33
34258µs258µs
# spent 49µs (40+9) within Net::DNS::RR::BEGIN@34 which was called: # once (40µs+9µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 34
use strict;
# spent 49µs making 1 call to Net::DNS::RR::BEGIN@34 # spent 9µs making 1 call to strict::import
35255µs271µs
# spent 46µs (20+26) within Net::DNS::RR::BEGIN@35 which was called: # once (20µs+26µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 35
use warnings;
# spent 46µs making 1 call to Net::DNS::RR::BEGIN@35 # spent 26µs making 1 call to warnings::import
36257µs229µs
# spent 24µs (19+5) within Net::DNS::RR::BEGIN@36 which was called: # once (19µs+5µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 36
use integer;
# spent 24µs making 1 call to Net::DNS::RR::BEGIN@36 # spent 5µs making 1 call to integer::import
37274µs2301µs
# spent 160µs (19+141) within Net::DNS::RR::BEGIN@37 which was called: # once (19µs+141µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 37
use Carp;
# spent 160µs making 1 call to Net::DNS::RR::BEGIN@37 # spent 141µs making 1 call to Exporter::import
38
39277µs2445µs
# spent 234µs (23+211) within Net::DNS::RR::BEGIN@39 which was called: # once (23µs+211µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 39
use constant LIB => grep !ref($_), @INC;
# spent 234µs making 1 call to Net::DNS::RR::BEGIN@39 # spent 211µs making 1 call to constant::import
40
412348µs216.2ms
# spent 15.7ms (13.6+2.04) within Net::DNS::RR::BEGIN@41 which was called: # once (13.6ms+2.04ms) by Net::DNS::Resolver::Base::BEGIN@56 at line 41
use Net::DNS::Parameters;
# spent 15.7ms making 1 call to Net::DNS::RR::BEGIN@41 # spent 539µs making 1 call to Exporter::import
422403µs119.3ms
# spent 19.3ms (11.4+7.88) within Net::DNS::RR::BEGIN@42 which was called: # once (11.4ms+7.88ms) by Net::DNS::Resolver::Base::BEGIN@56 at line 42
use Net::DNS::Domain;
# spent 19.3ms making 1 call to Net::DNS::RR::BEGIN@42
4321.75ms12.64ms
# spent 2.64ms (1.67+978µs) within Net::DNS::RR::BEGIN@43 which was called: # once (1.67ms+978µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 43
use Net::DNS::DomainName;
# spent 2.64ms making 1 call to Net::DNS::RR::BEGIN@43
44
45
46=head1 METHODS
47
48B<WARNING!!!> Do not assume the RR objects you receive from a query
49are of a particular type. You must always check the object type
50before calling any of its methods. If you call an unknown method,
51you will get an error message and execution will be terminated.
52
53=cut
54
55
# spent 353ms (62.4+291) within Net::DNS::RR::new which was called 1968 times, avg 179µs/call: # 1968 times (62.4ms+291ms) by Net::DNS::Packet::edns at line 242 of Net/DNS/Packet.pm, avg 179µs/call
sub new {
56 return eval {
57196821.3ms local $SIG{__DIE__};
58196825.7ms1968291ms scalar @_ > 2 ? &_new_hash : &_new_string;
# spent 291ms making 1968 calls to Net::DNS::RR::_new_hash, avg 148µs/call
59196829.0ms } || do {
60 my $class = shift || __PACKAGE__;
61 my @param = map defined($_) ? split /\s+/ : 'undef', @_;
62 my $stmnt = substr "new $class( @param )", 0, 80;
63 croak "${@}in $stmnt\n";
64 };
65}
66
67
68=head2 new (from string)
69
70 $a = new Net::DNS::RR('host.example.com. 86400 A 192.0.2.1');
71 $mx = new Net::DNS::RR('example.com. 7200 MX 10 mailhost.example.com.');
72 $cname = new Net::DNS::RR('www.example.com 300 IN CNAME host.example.com');
73 $txt = new Net::DNS::RR('txt.example.com 3600 HS TXT "text data"');
74
75Returns an object of the appropriate RR type, or a L<Net::DNS::RR> object
76if the type is not implemented. The attribute values are extracted from the
77string passed by the user. The syntax of the argument string follows the
78RFC1035 specification for zone files, and is compatible with the result
79returned by the string method.
80
81The owner and RR type are required; all other information is optional.
82Omitting the optional fields is useful for creating the empty RDATA
83sections required for certain dynamic update operations.
84See the L<Net::DNS::Update> manual page for additional examples.
85
86All names are interpreted as fully qualified domain names.
87The trailing dot (.) is optional.
88
89=cut
90
9112µsmy $PARSE_REGEX = q/("[^"]*")|;[^\n]*|[ \t\n\r\f()]/;
92
93sub _new_string {
94 my $base;
95 local $_;
96 ( $base, $_ ) = @_;
97 croak 'argument absent or undefined' unless defined $_;
98 croak 'non-scalar argument' if ref $_;
99
100 # parse into quoted strings, contiguous non-whitespace and (discarded) comments
101 s/\\\\/\\092/g; # disguise escaped escape
102 s/\\"/\\034/g; # disguise escaped quote
103 s/\\\(/\\040/g; # disguise escaped bracket
104 s/\\\)/\\041/g; # disguise escaped bracket
105 s/\\;/\\059/g; # disguise escaped semicolon
106 my ( $owner, @token ) = grep defined && length, split /$PARSE_REGEX/o;
107
108 croak 'unable to parse RR string' unless scalar @token;
109 my $t1 = uc $token[0];
110 my $t2 = uc $token[1] if $#token;
111
112 my ( $ttl, $class );
113 if ( not defined $t2 ) { # <owner> <type>
114 @token = ('ANY') if $classbyname{$t1}; # <owner> <class>
115 } elsif ( $classbyname{$t1} || $t1 =~ /^CLASS\d/ ) {
116 $class = shift @token; # <owner> <class> [<ttl>] <type>
117 $ttl = shift @token if $t2 =~ /^\d/;
118 } elsif ( $t1 =~ /^\d/ ) {
119 $ttl = shift @token; # <owner> <ttl> [<class>] <type>
120 $class = shift @token if $classbyname{$t2} || $t2 =~ /^CLASS\d/;
121 }
122
123 my $type = shift(@token);
124 my $populated = scalar @token;
125
126 my $self = $base->_subclass( $type, $populated ); # create RR object
127 $self->owner($owner);
128 $self->class($class) if defined $class; # specify CLASS
129 $self->ttl($ttl) if defined $ttl; # specify TTL
130
131 return $self unless $populated; # empty RR
132
133 if ( $#token && $token[0] =~ /^[\\]?#$/ ) {
134 shift @token; # RFC3597 hexadecimal format
135 my $rdlen = shift(@token) || 0;
136 my $rdata = pack 'H*', join( '', @token );
137 croak 'length and hexadecimal data inconsistent' unless $rdlen == length $rdata;
138 $self->rdata($rdata) if $rdlen; # unpack RDATA
139 return $self;
140 }
141
142 $self->_parse_rdata(@token); # parse arguments
143 return $self;
144}
145
146
147=head2 new (from hash)
148
149 $rr = new Net::DNS::RR(%hash);
150
151 $rr = new Net::DNS::RR(
152 owner => 'host.example.com',
153 ttl => 86400,
154 class => 'IN',
155 type => 'A',
156 address => '192.0.2.1'
157 );
158
159 $rr = new Net::DNS::RR(
160 owner => 'txt.example.com',
161 type => 'TXT',
162 txtdata => [ 'one', 'two' ]
163 );
164
165Returns an object of the appropriate RR type, or a L<Net::DNS::RR> object
166if the type is not implemented. Consult the relevant manual pages for the
167usage of type specific attributes.
168
169The owner and RR type are required; all other information is optional.
170Omitting optional attributes is useful for creating the empty RDATA
171sections required for certain dynamic update operations.
172
173=cut
174
17514µsmy @core = qw(owner name type class ttl rdlength);
176
177
# spent 291ms (159+131) within Net::DNS::RR::_new_hash which was called 1968 times, avg 148µs/call: # 1968 times (159ms+131ms) by Net::DNS::RR::new at line 58, avg 148µs/call
sub _new_hash {
17819684.19ms my $base = shift;
179
180196814.7ms my %attribute = ( owner => '.', type => 'NULL' );
181196819.0ms while ( my $key = shift ) {
18219685.11ms $attribute{lc $key} = shift;
183 }
184
18519689.38ms my ( $owner, $name, $type, $class, $ttl ) = @attribute{@core};
186196817.0ms delete @attribute{@core}; # leaving RDATA only
187
188196815.9ms196853.3ms my $self = $base->_subclass( $type, scalar %attribute );
# spent 53.3ms making 1968 calls to Net::DNS::RR::_subclass, avg 27µs/call
189196814.4ms196877.8ms $self->owner( $name ? $name : $owner );
# spent 77.8ms making 1968 calls to Net::DNS::RR::owner, avg 40µs/call
19019684.19ms $self->class($class) if defined $class; # specify CLASS
19119683.84ms $self->ttl($ttl) if defined $ttl; # specify TTL
192
19319687.25ms eval {
19419689.70ms while ( my ( $attribute, $value ) = each %attribute ) {
195 $self->$attribute( ref($value) eq 'ARRAY' ? @$value : $value );
196 }
197 };
19819683.49ms die ref($self) eq __PACKAGE__ ? "type $type not implemented" : () if $@;
199
200196825.3ms return $self;
201}
202
203
204=head2 decode
205
206 ( $rr, $next ) = decode Net::DNS::RR( \$data, $offset, @opaque );
207
208Decodes a DNS resource record at the specified location within a
209DNS packet.
210
211The argument list consists of a reference to the buffer containing
212the packet data and offset indicating where resource record begins.
213Remaining arguments, if any, are passed as opaque data to
214subordinate decoders.
215
216Returns a C<Net::DNS::RR> object and the offset of the next record
217in the packet.
218
219An exception is raised if the data buffer contains insufficient or
220corrupt data.
221
222Any remaining arguments are passed as opaque data to subordinate
223decoders and do not form part of the published interface.
224
225=cut
226
22724.48ms3375µs
# spent 206µs (37+169) within Net::DNS::RR::BEGIN@227 which was called: # once (37µs+169µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 227
use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4;
# spent 206µs making 1 call to Net::DNS::RR::BEGIN@227 # spent 163µs making 1 call to constant::import # spent 6µs making 1 call to Net::DNS::RR::CORE:pack
228
229sub decode {
230 my $base = shift;
231 my ( $data, $offset, @opaque ) = @_;
232
233 my ( $owner, $fixed ) = decode Net::DNS::DomainName1035(@_);
234
235 my $index = $fixed + RRFIXEDSZ;
236 die 'corrupt wire-format data' if length $$data < $index;
237 my $self = $base->_subclass( unpack "\@$fixed n", $$data );
238 $self->{owner} = $owner;
239 @{$self}{qw(class ttl rdlength)} = unpack "\@$fixed x2 n N n", $$data;
240
241 my $next = $index + $self->{rdlength};
242 die 'corrupt wire-format data' if length $$data < $next;
243
244 $self->{offset} = $offset || 0;
245 $self->_decode_rdata( $data, $index, @opaque ) if $next > $index or $self->type eq 'OPT';
246 delete $self->{offset};
247
248 return wantarray ? ( $self, $next ) : $self;
249}
250
251
252=head2 encode
253
254 $data = $rr->encode( $offset, @opaque );
255
256Returns the C<Net::DNS::RR> in binary format suitable for inclusion
257in a DNS packet buffer.
258
259The offset indicates the intended location within the packet data
260where the C<Net::DNS::RR> is to be stored.
261
262Any remaining arguments are opaque data which are passed intact to
263subordinate encoders.
264
265=cut
266
267sub encode {
268 my $self = shift;
269 my ( $offset, @opaque ) = scalar(@_) ? @_ : ( 0x4000, {} );
270
271 my $owner = $self->{owner}->encode( $offset, @opaque );
272 my $type = $self->{type};
273 my $class = $self->{class} || 1;
274 my $index = $offset + length($owner) + RRFIXEDSZ;
275 my $rdata = eval { $self->_empty ? '' : $self->_encode_rdata( $index, @opaque ); } || '';
276 return pack 'a* n2 N n a*', $owner, $type, $class, $self->ttl, length $rdata, $rdata;
277}
278
279
280=head2 canonical
281
282 $data = $rr->canonical;
283
284Returns the C<Net::DNS::RR> in canonical binary format suitable for
285DNSSEC signature validation.
286
287The absence of the associative array argument signals to subordinate
288encoders that the canonical uncompressed lower case form of embedded
289domain names is to be used.
290
291=cut
292
293sub canonical {
294 my $self = shift;
295
296 my $owner = $self->{owner}->canonical;
297 my $type = $self->{type};
298 my $class = $self->{class} || 1;
299 my $index = RRFIXEDSZ + length $owner;
300 my $rdata = eval { $self->_empty ? '' : $self->_encode_rdata($index); } || '';
301 pack 'a* n2 N n a*', $owner, $type, $class, $self->ttl, length $rdata, $rdata;
302}
303
304
305=head2 print
306
307 $rr->print;
308
309Prints the record to the standard output. Calls the string method
310to get the formatted RR representation.
311
312=cut
313
314sub print {
315 print shift->string, "\n";
316}
317
318
319=head2 string
320
321 print $rr->string, "\n";
322
323Returns a string representation of the RR using the zone file format
324described in RFC1035. All domain names are fully qualified with
325trailing dot. This differs from RR attribute methods, which omit
326the trailing dot.
327
328=cut
329
330sub string {
331 my $self = shift;
332
333 my $name = $self->{owner}->string;
334 my @ttl = grep defined, $self->{ttl};
335 my @core = ( $name, @ttl, $self->class, $self->type );
336
337 my $empty = $self->_empty;
338 my @rdata = eval { $empty ? () : $self->_format_rdata; };
339 carp $@ if $@;
340
341 my $tab = length($name) < 72 ? "\t" : ' ';
342 $self->_annotation('no data') if $empty;
343
344 my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' );
345
346 my $last = pop(@line); # last or only line
347 $last = join $tab, @core, "@rdata" unless scalar(@line);
348
349 return join "\n\t", @line, _wrap( $last, map "; $_", $self->_annotation );
350}
351
352
353=head2 plain
354
355 $plain = $rr->plain;
356
357Returns a simplified single line representation of the RR using the
358zone file format defined in RFC1035. This facilitates interaction
359with programs like nsupdate which have rudimentary RR parsers.
360
361=cut
362
363sub plain {
364 join ' ', shift->token;
365}
366
367
368=head2 token
369
370 @token = $rr->token;
371
372Returns a token list representation of the RR zone file string.
373
374=cut
375
376sub token {
377 my $self = shift;
378
379 my @ttl = grep defined, $self->{ttl};
380 my @core = ( $self->{owner}->string, @ttl, $self->class, $self->type );
381
382 my @rdata = eval { $self->_empty ? () : $self->_format_rdata; };
383
384 # parse into quoted strings, contiguous non-whitespace and (discarded) comments
385 my @parse = map { s/\\\\/\\092/g; s/\\"/\\034/g; split /$PARSE_REGEX/o; } @rdata;
386 my @token = ( @core, grep defined && length, @parse );
387}
388
389
390=head2 generic
391
392 $generic = $rr->generic;
393
394Returns the generic RR representation defined in RFC3597. This facilitates
395creation of zone files containing RRs unrecognised by outdated nameservers
396and provisioning software.
397
398=cut
399
400sub generic {
401 my $self = shift;
402
403 my @ttl = grep defined, $self->{ttl};
404 my @class = map "CLASS$_", grep defined, $self->{class};
405 my @core = ( $self->{owner}->string, @ttl, @class, "TYPE$self->{type}" );
406 my $data = $self->rdata;
407 my @data = ( '\\#', length($data), split /(\S{32})/, unpack 'H*', $data );
408 my @line = _wrap( "@core (", @data, ')' );
409 return join "\n\t", @line if scalar(@line) > 1;
410 join ' ', @core, @data;
411}
412
413
414=head2 owner name
415
416 $name = $rr->owner;
417
418Returns the owner name of the record.
419
420=cut
421
422
# spent 77.8ms (36.4+41.4) within Net::DNS::RR::owner which was called 1968 times, avg 40µs/call: # 1968 times (36.4ms+41.4ms) by Net::DNS::RR::_new_hash at line 189, avg 40µs/call
sub owner {
42319684.17ms my $self = shift;
424196816.2ms196841.4ms $self->{owner} = new Net::DNS::DomainName1035(shift) if scalar @_;
# spent 41.4ms making 1968 calls to Net::DNS::Domain::new, avg 21µs/call
425196816.5ms $self->{owner}->name if defined wantarray;
426}
427
428sub name { &owner; } ## historical
429
430
431=head2 type
432
433 $type = $rr->type;
434
435Returns the record type.
436
437=cut
438
439sub type {
440 my $self = shift;
441 croak 'not possible to change RR->type' if scalar @_;
442 typebyval( $self->{type} );
443}
444
445
446=head2 class
447
448 $class = $rr->class;
449
450Resource record class.
451
452=cut
453
454sub class {
455 my $self = shift;
456 return $self->{class} = classbyname(shift) if scalar @_;
457 defined $self->{class} ? classbyval( $self->{class} ) : 'IN';
458}
459
460
461=head2 ttl
462
463 $ttl = $rr->ttl;
464 $ttl = $rr->ttl(3600);
465
466Resource record time to live in seconds.
467
468=cut
469
470# The following time units are recognised, but are not part of the
471# published API. These are required for parsing BIND zone files but
472# should not be used in other contexts.
47315µsmy %unit = ( W => 604800, D => 86400, H => 3600, M => 60, S => 1 );
474
475sub ttl {
476 my ( $self, $time ) = @_;
477
478 return $self->{ttl} || 0 unless defined $time; # avoid defining rr->{ttl}
479
480 my $ttl = 0;
481 my %time = reverse split /(\D)\D*/, $time . 'S';
482 while ( my ( $u, $t ) = each %time ) {
483 my $scale = $unit{uc $u} || die qq(bad time: $t$u);
484 $ttl += $t * $scale;
485 }
486 $self->{ttl} = $ttl;
487}
488
489
490################################################################################
491##
492## Default implementation for unknown RR type
493##
494################################################################################
495
496sub _decode_rdata { ## decode rdata from wire-format octet string
497 my ( $self, $data, $offset ) = @_;
498 $self->{rdata} = substr $$data, $offset, $self->{rdlength};
499}
500
501
502sub _encode_rdata { ## encode rdata as wire-format octet string
503 my $rdata = shift->{rdata};
504}
505
506
507sub _format_rdata { ## format rdata portion of RR string
508 my $data = shift->rdata;
509 my $size = length($data); # RFC3597 unknown RR format
510 my @data = ( '\\#', $size, split /(\S{32})/, unpack 'H*', $data );
511}
512
513
514sub _parse_rdata { ## parse RR attributes in argument list
515 my $self = shift;
516 die join ' ', 'type', $self->type, 'not implemented' if ref($self) eq __PACKAGE__;
517 die join ' ', 'no zone file representation defined for', $self->type;
518}
519
520
521111µs
# spent 6µs within Net::DNS::RR::_defaults which was called: # once (6µs+0s) by Net::DNS::RR::_subclass at line 701
sub _defaults { } ## set attribute default values
522
523
524sub dump { ## print internal data structure
525 require Data::Dumper; # uncoverable pod
526 local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 6;
527 local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1;
528 print Data::Dumper::Dumper(@_);
529}
530
531sub rdatastr { ## historical RR subtype method
532 &rdstring; # uncoverable pod
533}
534
535
536=head2 rdata
537
538 $rr = new Net::DNS::RR( type => NULL, rdata => 'arbitrary' );
539
540Resource record data section when viewed as opaque octets.
541
542=cut
543
544sub rdata {
545 my $self = shift;
546
547 return eval { $self->_empty ? '' : $self->_encode_rdata( 0x4000, {} ); } || '' unless @_;
548
549 my $rdata = shift || '';
550 my $rdlen = $self->{rdlength} = length $rdata;
551 my $hash = {};
552 $self->_decode_rdata( \$rdata, 0, $hash ) if $rdlen;
553 croak 'unexpected compression pointer in rdata' if keys %$hash;
554}
555
556
557=head2 rdstring
558
559 $rdstring = $rr->rdstring;
560
561Returns a string representation of the RR-specific data.
562
563=cut
564
565sub rdstring {
566 my $self = shift;
567
568 my @rdata = eval { $self->_empty ? () : $self->_format_rdata; };
569 carp $@ if $@;
570
571 join "\n\t", _wrap(@rdata);
572}
573
574
575=head2 rdlength
576
577 $rdlength = $rr->rdlength;
578
579Returns the uncompressed length of the encoded RR-specific data.
580
581=cut
582
583sub rdlength {
584 length shift->rdata;
585}
586
587
588###################################################################################
589
590=head1 Sorting of RR arrays
591
592Sorting of RR arrays is done by Net::DNS::rrsort(), see documentation
593for L<Net::DNS>. This package provides class methods to set the
594comparator function used for a particular RR based on its attributes.
595
596
597=head2 set_rrsort_func
598
599 my $function = sub { ## numerically ascending order
600 $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'};
601 };
602
603 Net::DNS::RR::MX->set_rrsort_func( 'preference', $function );
604
605 Net::DNS::RR::MX->set_rrsort_func( 'default_sort', $function );
606
607set_rrsort_func() must be called as a class method. The first argument is
608the attribute name on which the sorting is to take place. If you specify
609"default_sort" then that is the sort algorithm that will be used when
610get_rrsort_func() is called without an RR attribute as argument.
611
612The second argument is a reference to a comparator function that uses the
613global variables $a and $b in the Net::DNS package. During sorting, the
614variables $a and $b will contain references to objects of the class whose
615set_rrsort_func() was called. The above sorting function will only be
616applied to Net::DNS::RR::MX objects.
617
618The above example is the sorting function implemented in MX.
619
620=cut
621
622our %rrsortfunct;
623
624sub set_rrsort_func {
625 my $class = shift;
626 my $attribute = shift;
627 my $function = shift;
628
629 my ($type) = $class =~ m/::([^:]+)$/;
630 $rrsortfunct{$type}{$attribute} = $function;
631}
632
633
634=head2 get_rrsort_func
635
636 $function = Net::DNS::RR::MX->get_rrsort_func('preference');
637 $function = Net::DNS::RR::MX->get_rrsort_func();
638
639get_rrsort_func() returns a reference to the comparator function.
640
641=cut
642
64316µsmy $default = sub { $Net::DNS::a->canonical() cmp $Net::DNS::b->canonical(); };
644
645sub get_rrsort_func {
646 my $class = shift;
647 my $attribute = shift || 'default_sort';
648
649 my ($type) = $class =~ m/::([^:]+)$/;
650
651 $rrsortfunct{$type}{$attribute} || $default;
652}
653
654
655################################################################################
656#
657# Net::DNS::RR->_subclass($rrname)
658# Net::DNS::RR->_subclass($rrname, $default)
659#
660# Create a new object blessed into appropriate RR subclass, after
661# loading the subclass module (if necessary). A subclass with no
662# corresponding module will be regarded as unknown and blessed
663# into the RR base class.
664#
665# The optional second argument indicates that default values are
666# to be copied into the newly created object.
667
66815µsour %_MINIMAL = ( 'ANY' => bless ['type' => 255], __PACKAGE__ );
66914µsour %_LOADED = %_MINIMAL;
670
671
# spent 53.3ms (47.6+5.76) within Net::DNS::RR::_subclass which was called 1968 times, avg 27µs/call: # 1968 times (47.6ms+5.76ms) by Net::DNS::RR::_new_hash at line 188, avg 27µs/call
sub _subclass {
67219684.55ms my ( $class, $rrname, $default ) = @_;
673
67419685.20ms unless ( $_LOADED{$rrname} ) {
67517µs18µs my $rrtype = typebyname($rrname);
# spent 8µs making 1 call to Net::DNS::Parameters::typebyname
676
67714µs unless ( $_LOADED{$rrtype} ) { # load once only
67817µs local @INC = LIB;
679
680110µs111µs my $identifier = typebyval($rrtype);
# spent 11µs making 1 call to Net::DNS::Parameters::typebyval
681123µs13µs $identifier =~ s/\W/_/g; # kosher Perl identifier
# spent 3µs making 1 call to Net::DNS::RR::CORE:subst
682
68314µs my $subclass = join '::', __PACKAGE__, $identifier;
684
6851126µs unless ( eval "require $subclass" ) {
# spent 482µs executing statements in string eval
686 push @INC, sub {
687 Net::DNS::Parameters::_typespec("$rrtype.RRTYPE");
688 };
689
690 $subclass = join '::', __PACKAGE__, "TYPE$rrtype";
691 eval "require $subclass";
692 }
693
69412µs $subclass = __PACKAGE__ if $@;
695
696 # cache pre-built minimal and populated default object images
69716µs my @base = ( 'type' => $rrtype );
698110µs $_MINIMAL{$rrtype} = bless [@base], $subclass;
699
70018µs my $object = bless {@base}, $subclass;
701115µs16µs $object->_defaults;
# spent 6µs making 1 call to Net::DNS::RR::_defaults
702125µs $_LOADED{$rrtype} = bless [%$object], $subclass;
703 }
704
70514µs $_MINIMAL{$rrname} = $_MINIMAL{$rrtype};
70614µs $_LOADED{$rrname} = $_LOADED{$rrtype};
707 }
708
70919685.05ms my $prebuilt = $default ? $_LOADED{$rrname} : $_MINIMAL{$rrname};
710196831.5ms bless {@$prebuilt}, ref($prebuilt); # create object
711}
712
713
714sub _annotation {
715 my $self = shift;
716 $self->{annotation} = ["@_"] if scalar @_;
717 return @{$self->{annotation} || []} if wantarray;
718}
719
720
721112µsmy %ignore = map( ( $_ => 1 ), @core, 'annotation', '#' );
722
723sub _empty {
724 ( $_[0]->{'#'} ||= scalar grep !$ignore{$_}, keys %{$_[0]} ) == 0;
725}
726
727
728sub _wrap {
729 my @text = @_;
730 my $cols = 80;
731 my $coln = 0;
732
733 my ( @line, @fill );
734 foreach (@text) {
735 if ( ( $coln += 1 + length ) > $cols ) { # start new line
736 push @line, join ' ', @fill if scalar @fill;
737 $coln = length;
738 @fill = ();
739 }
740 $coln = $cols if chomp; # force line break
741 push( @fill, $_ );
742 }
743 push @line, join ' ', @fill;
744 return @line;
745}
746
747
748################################################################################
749
750our $AUTOLOAD;
751
752sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup)
753
754sub AUTOLOAD { ## Default method
755 my $self = shift;
756 my $oref = ref($self);
757
7582414µs2136µs
# spent 80µs (25+55) within Net::DNS::RR::BEGIN@758 which was called: # once (25µs+55µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 758
no strict q/refs/;
# spent 80µs making 1 call to Net::DNS::RR::BEGIN@758 # spent 55µs making 1 call to strict::unimport
759 my ($method) = reverse split /::/, $AUTOLOAD;
760 *{$AUTOLOAD} = sub {undef}; ## suppress repetition and deep recursion
761 croak "$self has no class method '$method'" unless $oref;
762
763 my $string = $self->string;
764 my @object = grep defined($_), $oref, $oref->VERSION;
765 my $module = join '::', __PACKAGE__, $self->type;
766 eval("require $module") if $oref eq __PACKAGE__;
767
768 @_ = ( <<"END", $@, "@object" );
769*** FATAL PROGRAM ERROR!! Unknown instance method '$method'
770*** which the program has attempted to call for the object:
771***
772$string
773***
774*** THIS IS A BUG IN THE CALLING SOFTWARE, which incorrectly assumes
775*** that the object would be of a particular type. The type of an
776*** object should be checked before calling any of its methods.
777***
778END
779 goto &{'Carp::confess'};
780}
781
782
783123µs1;
784__END__
 
# spent 6µs within Net::DNS::RR::CORE:pack which was called: # once (6µs+0s) by Net::DNS::RR::BEGIN@227 at line 227
sub Net::DNS::RR::CORE:pack; # opcode
# spent 3µs within Net::DNS::RR::CORE:subst which was called: # once (3µs+0s) by Net::DNS::RR::_subclass at line 681
sub Net::DNS::RR::CORE:subst; # 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.