← 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/RR.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sNet::DNS::RR::::AUTOLOADNet::DNS::RR::AUTOLOAD
0000s0sNet::DNS::RR::::BEGIN@225Net::DNS::RR::BEGIN@225
0000s0sNet::DNS::RR::::BEGIN@3Net::DNS::RR::BEGIN@3
0000s0sNet::DNS::RR::::BEGIN@34Net::DNS::RR::BEGIN@34
0000s0sNet::DNS::RR::::BEGIN@35Net::DNS::RR::BEGIN@35
0000s0sNet::DNS::RR::::BEGIN@37Net::DNS::RR::BEGIN@37
0000s0sNet::DNS::RR::::BEGIN@39Net::DNS::RR::BEGIN@39
0000s0sNet::DNS::RR::::BEGIN@4Net::DNS::RR::BEGIN@4
0000s0sNet::DNS::RR::::BEGIN@40Net::DNS::RR::BEGIN@40
0000s0sNet::DNS::RR::::BEGIN@775Net::DNS::RR::BEGIN@775
0000s0sNet::DNS::RR::::CORE:packNet::DNS::RR::CORE:pack (opcode)
0000s0sNet::DNS::RR::::DESTROYNet::DNS::RR::DESTROY
0000s0sNet::DNS::RR::::__ANON__Net::DNS::RR::__ANON__ (xsub)
0000s0sNet::DNS::RR::::__ANON__[:644]Net::DNS::RR::__ANON__[:644]
0000s0sNet::DNS::RR::::__ANON__[:689]Net::DNS::RR::__ANON__[:689]
0000s0sNet::DNS::RR::::__ANON__[:776]Net::DNS::RR::__ANON__[:776]
0000s0sNet::DNS::RR::::_annotationNet::DNS::RR::_annotation
0000s0sNet::DNS::RR::::_decode_rdataNet::DNS::RR::_decode_rdata
0000s0sNet::DNS::RR::::_defaultsNet::DNS::RR::_defaults
0000s0sNet::DNS::RR::::_deprecateNet::DNS::RR::_deprecate
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_hashNet::DNS::RR::_new_hash
0000s0sNet::DNS::RR::::_new_stringNet::DNS::RR::_new_string
0000s0sNet::DNS::RR::::_parse_rdataNet::DNS::RR::_parse_rdata
0000s0sNet::DNS::RR::::_post_parseNet::DNS::RR::_post_parse
0000s0sNet::DNS::RR::::_subclassNet::DNS::RR::_subclass
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::::newNet::DNS::RR::new
0000s0sNet::DNS::RR::::ownerNet::DNS::RR::owner
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
3use strict;
4use warnings;
5
6our $VERSION = (qw$Id: RR.pm 1834 2021-03-28 09:34:49Z willem $)[2];
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 = Net::DNS::RR->new('example.com IN AAAA 2001:DB8::1');
18
19 $rr = Net::DNS::RR->new(
20 owner => 'example.com',
21 type => 'AAAA',
22 address => '2001:DB8::1'
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
34use integer;
35use Carp;
36
37use constant LIB => grep { $_ ne '.' } grep { !ref($_) } @INC;
38
39use Net::DNS::Parameters qw(%classbyname :class :type);
40use Net::DNS::DomainName;
41
42
43=head1 METHODS
44
45B<WARNING!!!> Do not assume the RR objects you receive from a query
46are of a particular type. You must always check the object type
47before calling any of its methods. If you call an unknown method,
48you will get an error message and execution will be terminated.
49
50=cut
51
52sub new {
53 return eval {
54 local $SIG{__DIE__};
55 scalar @_ > 2 ? &_new_hash : &_new_string;
56 } || do {
57 my $class = shift || __PACKAGE__;
58 my @param = map { defined($_) ? split /\s+/ : 'undef' } @_;
59 my $stmnt = substr "$class->new( @param )", 0, 80;
60 croak "${@}in $stmnt\n";
61 };
62}
63
64
65=head2 new (from string)
66
67 $aaaa = Net::DNS::RR->new('host.example.com. 86400 AAAA 2001:DB8::1');
68 $mx = Net::DNS::RR->new('example.com. 7200 MX 10 mailhost.example.com.');
69 $cname = Net::DNS::RR->new('www.example.com 300 IN CNAME host.example.com');
70 $txt = Net::DNS::RR->new('txt.example.com 3600 HS TXT "text data"');
71
72Returns an object of the appropriate RR type, or a L<Net::DNS::RR> object
73if the type is not implemented. The attribute values are extracted from the
74string passed by the user. The syntax of the argument string follows the
75RFC1035 specification for zone files, and is compatible with the result
76returned by the string method.
77
78The owner and RR type are required; all other information is optional.
79Omitting the optional fields is useful for creating the empty RDATA
80sections required for certain dynamic update operations.
81See the L<Net::DNS::Update> manual page for additional examples.
82
83All names are interpreted as fully qualified domain names.
84The trailing dot (.) is optional.
85
86=cut
87
88my $PARSE_REGEX = q/("[^"]*")|;[^\n]*|[ \t\n\r\f()]/; # NB: *not* \s (matches Unicode white space)
89
90sub _new_string {
91 my $base;
92 local $_;
93 ( $base, $_ ) = @_;
94 croak 'argument absent or undefined' unless defined $_;
95 croak 'non-scalar argument' if ref $_;
96
97 # parse into quoted strings, contiguous non-whitespace and (discarded) comments
98 s/\\\\/\\092/g; # disguise escaped escape
99 s/\\"/\\034/g; # disguise escaped quote
100 s/\\\(/\\040/g; # disguise escaped bracket
101 s/\\\)/\\041/g; # disguise escaped bracket
102 s/\\;/\\059/g; # disguise escaped semicolon
103 my ( $owner, @token ) = grep { defined && length } split /$PARSE_REGEX/o;
104
105 croak 'unable to parse RR string' unless scalar @token;
106 my $t1 = uc $token[0];
107 my $t2 = $token[1];
108
109 my ( $ttl, $class );
110 if ( not defined $t2 ) { # <owner> <type>
111 @token = ('ANY') if $classbyname{$t1}; # <owner> <class>
112 } elsif ( $t1 =~ /^\d/ ) {
113 $ttl = shift @token; # <owner> <ttl> [<class>] <type>
114 $class = shift @token if $classbyname{uc $t2} || $t2 =~ /^CLASS\d/i;
115 } elsif ( $classbyname{$t1} || $t1 =~ /^CLASS\d/ ) {
116 $class = shift @token; # <owner> <class> [<ttl>] <type>
117 $ttl = shift @token if $t2 =~ /^\d/;
118 }
119
120 my $type = shift(@token);
121 my $populated = scalar @token;
122
123 my $self = $base->_subclass( $type, $populated ); # create RR object
124 $self->owner($owner);
125 $self->class($class) if defined $class; # specify CLASS
126 $self->ttl($ttl) if defined $ttl; # specify TTL
127
128 return $self unless $populated; # empty RR
129
130 if ( $#token && $token[0] =~ /^[\\]?#$/ ) {
131 shift @token; # RFC3597 hexadecimal format
132 my $rdlen = shift(@token) || 0;
133 my $rdata = pack 'H*', join( '', @token );
134 croak 'length and hexadecimal data inconsistent' unless $rdlen == length $rdata;
135 $self->rdata($rdata); # unpack RDATA
136 } else {
137 $self->_parse_rdata(@token); # parse arguments
138 }
139
140 $self->_post_parse();
141 return $self;
142}
143
144
145=head2 new (from hash)
146
147 $rr = Net::DNS::RR->new(%hash);
148
149 $rr = Net::DNS::RR->new(
150 owner => 'host.example.com',
151 ttl => 86400,
152 class => 'IN',
153 type => 'AAAA',
154 address => '2001:DB8::1'
155 );
156
157 $rr = Net::DNS::RR->new(
158 owner => 'txt.example.com',
159 type => 'TXT',
160 txtdata => [ 'one', 'two' ]
161 );
162
163Returns an object of the appropriate RR type, or a L<Net::DNS::RR> object
164if the type is not implemented. Consult the relevant manual pages for the
165usage of type specific attributes.
166
167The owner and RR type are required; all other information is optional.
168Omitting optional attributes is useful for creating the empty RDATA
169sections required for certain dynamic update operations.
170
171=cut
172
173my @core = qw(owner name type class ttl rdlength);
174
175sub _new_hash {
176 my $base = shift;
177
178 my %attribute = ( owner => '.', type => 'NULL' );
179 while ( my $key = shift ) {
180 $attribute{lc $key} = shift;
181 }
182
183 my ( $owner, $name, $type, $class, $ttl ) = delete @attribute{@core};
184
185 my $self = $base->_subclass( $type, scalar(%attribute) );
186 $self->owner( $name ? $name : $owner );
187 $self->class($class) if defined $class; # optional CLASS
188 $self->ttl($ttl) if defined $ttl; # optional TTL
189
190 eval {
191 while ( my ( $attribute, $value ) = each %attribute ) {
192 $self->$attribute( ref($value) eq 'ARRAY' ? @$value : $value );
193 }
194 };
195 die ref($self) eq __PACKAGE__ ? "type $type not implemented" : () if $@;
196
197 $self->_post_parse();
198 return $self;
199}
200
201
202=head2 decode
203
204 ( $rr, $next ) = decode Net::DNS::RR( \$data, $offset, @opaque );
205
206Decodes a DNS resource record at the specified location within a
207DNS packet.
208
209The argument list consists of a reference to the buffer containing
210the packet data and offset indicating where resource record begins.
211Remaining arguments, if any, are passed as opaque data to
212subordinate decoders.
213
214Returns a C<Net::DNS::RR> object and the offset of the next record
215in the packet.
216
217An exception is raised if the data buffer contains insufficient or
218corrupt data.
219
220Any remaining arguments are passed as opaque data to subordinate
221decoders and do not form part of the published interface.
222
223=cut
224
225use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4;
226
227sub decode {
228 my $base = shift;
229 my ( $data, $offset, @opaque ) = @_;
230
231 my ( $owner, $fixed ) = decode Net::DNS::DomainName1035(@_);
232
233 my $index = $fixed + RRFIXEDSZ;
234 die 'corrupt wire-format data' if length $$data < $index;
235 my $self = $base->_subclass( unpack "\@$fixed n", $$data );
236 $self->{owner} = $owner;
237 @{$self}{qw(class ttl rdlength)} = unpack "\@$fixed x2 n N n", $$data;
238
239 my $next = $index + $self->{rdlength};
240 die 'corrupt wire-format data' if length $$data < $next;
241
242 $self->{offset} = $offset || 0;
243 $self->_decode_rdata( $data, $index, @opaque ) if $next > $index or $self->type eq 'OPT';
244 delete $self->{offset};
245
246 return wantarray ? ( $self, $next ) : $self;
247}
248
249
250=head2 encode
251
252 $data = $rr->encode( $offset, @opaque );
253
254Returns the C<Net::DNS::RR> in binary format suitable for inclusion
255in a DNS packet buffer.
256
257The offset indicates the intended location within the packet data
258where the C<Net::DNS::RR> is to be stored.
259
260Any remaining arguments are opaque data which are passed intact to
261subordinate encoders.
262
263=cut
264
265sub encode {
266 my $self = shift;
267 my ( $offset, @opaque ) = scalar(@_) ? @_ : ( 0x4000, {} );
268
269 my $owner = $self->{owner}->encode( $offset, @opaque );
270 my ( $type, $class, $ttl ) = @{$self}{qw(type class ttl)};
271 my $rdata = $self->_empty ? '' : $self->_encode_rdata( $offset + length($owner) + RRFIXEDSZ, @opaque );
272 return pack 'a* n2 N n a*', $owner, $type, $class || 1, $ttl || 0, length $rdata, $rdata;
273}
274
275
276=head2 canonical
277
278 $data = $rr->canonical;
279
280Returns the C<Net::DNS::RR> in canonical binary format suitable for
281DNSSEC signature validation.
282
283The absence of the associative array argument signals to subordinate
284encoders that the canonical uncompressed lower case form of embedded
285domain names is to be used.
286
287=cut
288
289sub canonical {
290 my $self = shift;
291
292 my $owner = $self->{owner}->canonical;
293 my ( $type, $class, $ttl ) = @{$self}{qw(type class ttl)};
294 my $rdata = $self->_empty ? '' : $self->_encode_rdata( length($owner) + RRFIXEDSZ );
295 return pack 'a* n2 N n a*', $owner, $type, $class || 1, $ttl || 0, length $rdata, $rdata;
296}
297
298
299=head2 print
300
301 $rr->print;
302
303Prints the resource record to the currently selected output filehandle.
304Calls the string method to get the formatted RR representation.
305
306=cut
307
308sub print {
309 print shift->string, "\n";
310 return;
311}
312
313
314=head2 string
315
316 print $rr->string, "\n";
317
318Returns a string representation of the RR using the master file format
319mandated by RFC1035.
320All domain names are fully qualified with trailing dot.
321This differs from RR attribute methods, which omit the trailing dot.
322
323=cut
324
325sub string {
326 my $self = shift;
327
328 my $name = $self->{owner}->string;
329 my @ttl = grep {defined} $self->{ttl};
330 my @core = ( $name, @ttl, $self->class, $self->type );
331
332 my $empty = $self->_empty;
333 my @rdata = $empty ? () : eval { $self->_format_rdata };
334 carp $@ if $@;
335
336 my $tab = length($name) < 72 ? "\t" : ' ';
337 $self->_annotation('no data') if $empty;
338
339 my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' );
340
341 my $last = pop(@line); # last or only line
342 $last = join $tab, @core, "@rdata" unless scalar(@line);
343
344 return join "\n\t", @line, _wrap( $last, map {"; $_"} $self->_annotation );
345}
346
347
348=head2 plain
349
350 $plain = $rr->plain;
351
352Returns a simplified single-line representation of the RR.
353This facilitates interaction with programs like nsupdate
354which have rudimentary parsers.
355
356=cut
357
358sub plain {
359 my $string = join ' ', shift->token;
360 $string =~ s/\\034/\\"/g; # unescape "
361 $string =~ s/\\092/\\\\/g; # unescape escape
362 return $string;
363}
364
365
366=head2 token
367
368 @token = $rr->token;
369
370Returns a token list representation of the RR zone file string.
371
372=cut
373
374sub token {
375 my $self = shift;
376
377 my @ttl = grep {defined} $self->{ttl};
378 my @core = ( $self->{owner}->string, @ttl, $self->class, $self->type );
379
380 my @rdata = $self->_empty ? () : eval { $self->_format_rdata };
381
382 # parse into quoted strings, contiguous non-whitespace and (discarded) comments
383 my @parse = map { split( /$PARSE_REGEX/o, $_ ) } @rdata;
384 return ( @core, grep { defined && length } @parse );
385}
386
387
388=head2 generic
389
390 $generic = $rr->generic;
391
392Returns the generic RR representation defined in RFC3597. This facilitates
393creation of zone files containing RRs unrecognised by outdated nameservers
394and provisioning software.
395
396=cut
397
398sub generic {
399 my $self = shift;
400
401 my @ttl = grep {defined} $self->{ttl};
402 my @class = map {"CLASS$_"} grep {defined} $self->{class};
403 my @core = ( $self->{owner}->string, @ttl, @class, "TYPE$self->{type}" );
404 my $data = $self->rdata;
405 my @data = ( '\\#', length($data), split /(\S{32})/, unpack 'H*', $data );
406 my @line = _wrap( "@core (", @data, ')' );
407 return join "\n\t", @line if scalar(@line) > 1;
408 return join ' ', @core, @data;
409}
410
411
412=head2 owner name
413
414 $name = $rr->owner;
415
416Returns the owner name of the record.
417
418=cut
419
420sub owner {
421 my $self = shift;
422 $self->{owner} = Net::DNS::DomainName1035->new(shift) if scalar @_;
423 return defined wantarray ? $self->{owner}->name : undef;
424}
425
426sub name { return &owner; } ## historical
427
428
429=head2 type
430
431 $type = $rr->type;
432
433Returns the record type.
434
435=cut
436
437sub type {
438 my $self = shift;
439 croak 'not possible to change RR->type' if scalar @_;
440 return typebyval( $self->{type} );
441}
442
443
444=head2 class
445
446 $class = $rr->class;
447
448Resource record class.
449
450=cut
451
452sub class {
453 my $self = shift;
454 return $self->{class} = classbyname(shift) if scalar @_;
455 return defined $self->{class} ? classbyval( $self->{class} ) : 'IN';
456}
457
458
459=head2 ttl
460
461 $ttl = $rr->ttl;
462 $ttl = $rr->ttl(3600);
463
464Resource record time to live in seconds.
465
466=cut
467
468# The following time units are recognised, but are not part of the
469# published API. These are required for parsing BIND zone files but
470# should not be used in other contexts.
471my %unit = ( W => 604800, D => 86400, H => 3600, M => 60, S => 1 );
472
473sub ttl {
474 my ( $self, $time ) = @_;
475
476 return $self->{ttl} || 0 unless defined $time; # avoid defining rr->{ttl}
477
478 my $ttl = 0;
479 my %time = reverse split /(\D)\D*/, $time . 'S';
480 while ( my ( $u, $t ) = each %time ) {
481 my $scale = $unit{uc $u} || die qq(bad time: $t$u);
482 $ttl += $t * $scale;
483 }
484 return $self->{ttl} = $ttl;
485}
486
487
488################################################################################
489##
490## Default implementation for unknown RR type
491##
492################################################################################
493
494sub _decode_rdata { ## decode rdata from wire-format octet string
495 my ( $self, $data, $offset ) = @_;
496 return $self->{rdata} = substr $$data, $offset, $self->{rdlength};
497}
498
499
500sub _encode_rdata { ## encode rdata as wire-format octet string
501 return shift->{rdata};
502}
503
504
505sub _format_rdata { ## format rdata portion of RR string
506 my $rdata = shift->rdata; # RFC3597 unknown RR format
507 return ( '\\#', length($rdata), split /(\S{32})/, unpack 'H*', $rdata );
508}
509
510
511sub _parse_rdata { ## parse RR attributes in argument list
512 my $self = shift;
513 die join ' ', 'type', $self->type, 'not implemented' if ref($self) eq __PACKAGE__;
514 die join ' ', 'no zone file representation defined for', $self->type;
515}
516
517
518sub _post_parse { } ## parser post processing
519
520
521sub _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 return print Data::Dumper::Dumper(@_);
529}
530
531sub rdatastr { ## historical RR subtype method
532 return &rdstring; # uncoverable pod
533}
534
535
536=head2 rdata
537
538 $rr = Net::DNS::RR->new( 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 $self->_empty ? '' : eval { $self->_encode_rdata( 0x4000, {} ) } unless @_;
548
549 my $data = shift || '';
550 my $hash = {};
551 $self->_decode_rdata( \$data, 0, $hash ) if ( $self->{rdlength} = length $data );
552 croak 'compression pointer in rdata' if keys %$hash;
553 return;
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 = $self->_empty ? () : eval { $self->_format_rdata };
569 carp $@ if $@;
570
571 return 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 return 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 return;
632}
633
634
635=head2 get_rrsort_func
636
637 $function = Net::DNS::RR::MX->get_rrsort_func('preference');
638 $function = Net::DNS::RR::MX->get_rrsort_func();
639
640get_rrsort_func() returns a reference to the comparator function.
641
642=cut
643
644my $default = sub { return $Net::DNS::a->canonical() cmp $Net::DNS::b->canonical(); };
645
646sub get_rrsort_func {
647 my $class = shift;
648 my $attribute = shift || 'default_sort';
649
650 my ($type) = $class =~ m/::([^:]+)$/;
651
652 return $rrsortfunct{$type}{$attribute} || return $default;
653}
654
655
656################################################################################
657#
658# Net::DNS::RR->_subclass($rrname)
659# Net::DNS::RR->_subclass($rrname, $default)
660#
661# Create a new object blessed into appropriate RR subclass, after
662# loading the subclass module (if necessary). A subclass with no
663# corresponding module will be regarded as unknown and blessed
664# into the RR base class.
665#
666# The optional second argument indicates that default values are
667# to be copied into the newly created object.
668
669our %_MINIMAL = ( 255 => bless ['type' => 255], __PACKAGE__ );
670our %_LOADED = %_MINIMAL;
671
672sub _subclass {
673 my ( $class, $rrname, $default ) = @_;
674
675 unless ( $_LOADED{$rrname} ) {
676 my $rrtype = typebyname($rrname);
677
678 unless ( $_LOADED{$rrtype} ) { # load once only
679 local @INC = LIB;
680
681 my $identifier = typebyval($rrtype);
682 $identifier =~ s/\W/_/g; # kosher Perl identifier
683
684 my $subclass = join '::', __PACKAGE__, $identifier;
685
686 unless ( eval "require $subclass" ) { ## no critic ProhibitStringyEval
687 push @INC, sub {
688 Net::DNS::Parameters::_typespec("$rrtype.RRTYPE");
689 };
690
691 $subclass = join '::', __PACKAGE__, "TYPE$rrtype";
692 eval "require $subclass"; ## no critic ProhibitStringyEval
693 }
694
695 $subclass = __PACKAGE__ if $@;
696
697 # cache pre-built minimal and populated default object images
698 my @base = ( 'type' => $rrtype );
699 $_MINIMAL{$rrtype} = bless [@base], $subclass;
700
701 my $object = bless {@base}, $subclass;
702 $object->_defaults;
703 $_LOADED{$rrtype} = bless [%$object], $subclass;
704 }
705
706 $_MINIMAL{$rrname} = $_MINIMAL{$rrtype};
707 $_LOADED{$rrname} = $_LOADED{$rrtype};
708 }
709
710 my $prebuilt = $default ? $_LOADED{$rrname} : $_MINIMAL{$rrname};
711 return bless {@$prebuilt}, ref($prebuilt); # create object
712}
713
714
715sub _annotation {
716 my $self = shift;
717 $self->{annotation} = ["@_"] if scalar @_;
718 return wantarray ? @{$self->{annotation} || []} : ();
719}
720
721
722my $warned;
723
724sub _deprecate {
725 carp join ' ', 'deprecated method;', pop(@_) unless $warned++;
726 return;
727}
728
729
730my %ignore = map { ( $_ => 1 ) } @core, 'annotation', '#';
731
732sub _empty {
733 my $self = shift;
734 return not( $self->{'#'} ||= scalar grep { !$ignore{$_} } keys %$self );
735}
736
737
738sub _wrap {
739 my @text = @_;
740 my $cols = 80;
741 my $coln = 0;
742
743 my ( @line, @fill );
744 foreach (@text) {
745 s/\\034/\\"/g; # unescape "
746 s/\\092/\\\\/g; # unescape escape
747 $coln += ( length || next ) + 1;
748 if ( $coln > $cols ) { # start new line
749 push( @line, join ' ', @fill ) if @fill;
750 $coln = length;
751 @fill = ();
752 }
753 $coln = $cols if chomp; # force line break
754 push( @fill, $_ ) if length;
755 }
756 push @line, join ' ', @fill;
757 return @line;
758}
759
760
761################################################################################
762
763our $AUTOLOAD;
764
765sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup)
766
767sub AUTOLOAD { ## Default method
768 my $self = shift;
769 my ($method) = reverse split /::/, $AUTOLOAD;
770
771 for ($method) { ## tolerate mixed-case attribute name
772 return $self->$_(@_) if tr [A-Z-] [a-z_];
773 }
774
775 no strict 'refs'; ## no critic ProhibitNoStrict
776 *{$AUTOLOAD} = sub {undef}; ## suppress repetition and deep recursion
777 my $oref = ref($self);
778 croak qq[$self has no class method "$method"] unless $oref;
779
780 my $string = $self->string;
781 my @object = grep { defined($_) } $oref, $oref->VERSION;
782 my $module = join '::', __PACKAGE__, $self->type;
783 eval("require $module") if $oref eq __PACKAGE__; ## no critic ProhibitStringyEval
784
785 @_ = ( <<"END", $@, "@object" );
786*** FATAL PROGRAM ERROR!! Unknown instance method "$method"
787*** which the program has attempted to call for the object:
788***
789$string
790***
791*** THIS IS A BUG IN THE CALLING SOFTWARE, which incorrectly assumes
792*** that the object would be of a particular type. The type of an
793*** object should be checked before calling any of its methods.
794***
795END
796 goto &{'Carp::confess'};
797}
798
799
8001;
801__END__