Filename | /usr/local/lib/perl5/site_perl/Net/DNS/RR.pm |
Statements | Executed 47277 statements in 316ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1968 | 1 | 1 | 160ms | 300ms | _new_hash | Net::DNS::RR::
1968 | 1 | 1 | 61.1ms | 361ms | new | Net::DNS::RR::
1968 | 1 | 1 | 50.2ms | 88.5ms | owner | Net::DNS::RR::
1968 | 1 | 1 | 45.7ms | 51.8ms | _subclass | Net::DNS::RR::
1 | 1 | 1 | 17.0ms | 25.8ms | BEGIN@42 | Net::DNS::RR::
1 | 1 | 1 | 11.8ms | 11.9ms | BEGIN@37 | Net::DNS::RR::
1 | 1 | 1 | 5.95ms | 8.41ms | BEGIN@41 | Net::DNS::RR::
1 | 1 | 1 | 1.89ms | 3.02ms | BEGIN@43 | Net::DNS::RR::
1 | 1 | 1 | 56µs | 65µs | BEGIN@34 | Net::DNS::RR::
1 | 1 | 1 | 43µs | 268µs | BEGIN@227 | Net::DNS::RR::
1 | 1 | 1 | 30µs | 84µs | BEGIN@758 | Net::DNS::RR::
1 | 1 | 1 | 26µs | 298µs | BEGIN@39 | Net::DNS::RR::
1 | 1 | 1 | 22µs | 56µs | BEGIN@35 | Net::DNS::RR::
1 | 1 | 1 | 22µs | 39µs | BEGIN@36 | Net::DNS::RR::
1 | 1 | 1 | 6µs | 6µs | CORE:pack (opcode) | Net::DNS::RR::
1 | 1 | 1 | 5µs | 5µs | _defaults | Net::DNS::RR::
1 | 1 | 1 | 3µs | 3µs | CORE:subst (opcode) | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | AUTOLOAD | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | DESTROY | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | __ANON__[:643] | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | __ANON__[:688] | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | __ANON__[:760] | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _annotation | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _decode_rdata | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _empty | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _encode_rdata | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _format_rdata | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _new_string | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _parse_rdata | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | _wrap | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | canonical | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | class | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | decode | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | dump | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | encode | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | generic | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | get_rrsort_func | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | name | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | plain | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | |
0 | 0 | 0 | 0s | 0s | rdata | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | rdatastr | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | rdlength | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | rdstring | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | set_rrsort_func | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | string | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | token | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | ttl | Net::DNS::RR::
0 | 0 | 0 | 0s | 0s | type | Net::DNS::RR::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Net::DNS::RR; | ||||
2 | |||||
3 | # | ||||
4 | # $Id: RR.pm 1597 2017-09-22 08:04:02Z willem $ | ||||
5 | # | ||||
6 | 1 | 2µs | our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; | ||
7 | |||||
8 | |||||
9 | =head1 NAME | ||||
10 | |||||
11 | Net::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 | |||||
28 | Net::DNS::RR is the base class for DNS Resource Record (RR) objects. | ||||
29 | See also the manual pages for each specific RR type. | ||||
30 | |||||
31 | =cut | ||||
32 | |||||
33 | |||||
34 | 2 | 59µs | 2 | 73µs | # spent 65µs (56+9) within Net::DNS::RR::BEGIN@34 which was called:
# once (56µs+9µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 34 # spent 65µs making 1 call to Net::DNS::RR::BEGIN@34
# spent 9µs making 1 call to strict::import |
35 | 2 | 68µs | 2 | 90µs | # spent 56µs (22+34) within Net::DNS::RR::BEGIN@35 which was called:
# once (22µs+34µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 35 # spent 56µs making 1 call to Net::DNS::RR::BEGIN@35
# spent 34µs making 1 call to warnings::import |
36 | 2 | 83µs | 2 | 57µs | # spent 39µs (22+18) within Net::DNS::RR::BEGIN@36 which was called:
# once (22µs+18µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 36 # spent 39µs making 1 call to Net::DNS::RR::BEGIN@36
# spent 18µs making 1 call to integer::import |
37 | 2 | 105µs | 2 | 12.1ms | # spent 11.9ms (11.8+184µs) within Net::DNS::RR::BEGIN@37 which was called:
# once (11.8ms+184µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 37 # spent 11.9ms making 1 call to Net::DNS::RR::BEGIN@37
# spent 184µs making 1 call to Exporter::import |
38 | |||||
39 | 2 | 92µs | 2 | 569µs | # spent 298µs (26+272) within Net::DNS::RR::BEGIN@39 which was called:
# once (26µs+272µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 39 # spent 298µs making 1 call to Net::DNS::RR::BEGIN@39
# spent 272µs making 1 call to constant::import |
40 | |||||
41 | 2 | 357µs | 2 | 9.12ms | # spent 8.41ms (5.95+2.46) within Net::DNS::RR::BEGIN@41 which was called:
# once (5.95ms+2.46ms) by Net::DNS::Resolver::Base::BEGIN@56 at line 41 # spent 8.41ms making 1 call to Net::DNS::RR::BEGIN@41
# spent 712µs making 1 call to Exporter::import |
42 | 2 | 387µs | 1 | 25.8ms | # spent 25.8ms (17.0+8.80) within Net::DNS::RR::BEGIN@42 which was called:
# once (17.0ms+8.80ms) by Net::DNS::Resolver::Base::BEGIN@56 at line 42 # spent 25.8ms making 1 call to Net::DNS::RR::BEGIN@42 |
43 | 2 | 1.82ms | 1 | 3.02ms | # spent 3.02ms (1.89+1.12) within Net::DNS::RR::BEGIN@43 which was called:
# once (1.89ms+1.12ms) by Net::DNS::Resolver::Base::BEGIN@56 at line 43 # spent 3.02ms making 1 call to Net::DNS::RR::BEGIN@43 |
44 | |||||
45 | |||||
46 | =head1 METHODS | ||||
47 | |||||
48 | B<WARNING!!!> Do not assume the RR objects you receive from a query | ||||
49 | are of a particular type. You must always check the object type | ||||
50 | before calling any of its methods. If you call an unknown method, | ||||
51 | you will get an error message and execution will be terminated. | ||||
52 | |||||
53 | =cut | ||||
54 | |||||
55 | # spent 361ms (61.1+300) within Net::DNS::RR::new which was called 1968 times, avg 184µs/call:
# 1968 times (61.1ms+300ms) by Net::DNS::Packet::edns at line 242 of Net/DNS/Packet.pm, avg 184µs/call | ||||
56 | return eval { | ||||
57 | 1968 | 17.5ms | local $SIG{__DIE__}; | ||
58 | 1968 | 25.8ms | 1968 | 300ms | scalar @_ > 2 ? &_new_hash : &_new_string; # spent 300ms making 1968 calls to Net::DNS::RR::_new_hash, avg 153µs/call |
59 | 1968 | 25.8ms | } || 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 | |||||
75 | Returns an object of the appropriate RR type, or a L<Net::DNS::RR> object | ||||
76 | if the type is not implemented. The attribute values are extracted from the | ||||
77 | string passed by the user. The syntax of the argument string follows the | ||||
78 | RFC1035 specification for zone files, and is compatible with the result | ||||
79 | returned by the string method. | ||||
80 | |||||
81 | The owner and RR type are required; all other information is optional. | ||||
82 | Omitting the optional fields is useful for creating the empty RDATA | ||||
83 | sections required for certain dynamic update operations. | ||||
84 | See the L<Net::DNS::Update> manual page for additional examples. | ||||
85 | |||||
86 | All names are interpreted as fully qualified domain names. | ||||
87 | The trailing dot (.) is optional. | ||||
88 | |||||
89 | =cut | ||||
90 | |||||
91 | 1 | 2µs | my $PARSE_REGEX = q/("[^"]*")|;[^\n]*|[ \t\n\r\f()]/; | ||
92 | |||||
93 | sub _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 | |||||
165 | Returns an object of the appropriate RR type, or a L<Net::DNS::RR> object | ||||
166 | if the type is not implemented. Consult the relevant manual pages for the | ||||
167 | usage of type specific attributes. | ||||
168 | |||||
169 | The owner and RR type are required; all other information is optional. | ||||
170 | Omitting optional attributes is useful for creating the empty RDATA | ||||
171 | sections required for certain dynamic update operations. | ||||
172 | |||||
173 | =cut | ||||
174 | |||||
175 | 1 | 10µs | my @core = qw(owner name type class ttl rdlength); | ||
176 | |||||
177 | # spent 300ms (160+140) within Net::DNS::RR::_new_hash which was called 1968 times, avg 153µs/call:
# 1968 times (160ms+140ms) by Net::DNS::RR::new at line 58, avg 153µs/call | ||||
178 | 1968 | 4.09ms | my $base = shift; | ||
179 | |||||
180 | 1968 | 15.1ms | my %attribute = ( owner => '.', type => 'NULL' ); | ||
181 | 1968 | 16.5ms | while ( my $key = shift ) { | ||
182 | 1968 | 5.87ms | $attribute{lc $key} = shift; | ||
183 | } | ||||
184 | |||||
185 | 1968 | 10.4ms | my ( $owner, $name, $type, $class, $ttl ) = @attribute{@core}; | ||
186 | 1968 | 13.5ms | delete @attribute{@core}; # leaving RDATA only | ||
187 | |||||
188 | 1968 | 16.7ms | 1968 | 51.8ms | my $self = $base->_subclass( $type, scalar %attribute ); # spent 51.8ms making 1968 calls to Net::DNS::RR::_subclass, avg 26µs/call |
189 | 1968 | 14.9ms | 1968 | 88.5ms | $self->owner( $name ? $name : $owner ); # spent 88.5ms making 1968 calls to Net::DNS::RR::owner, avg 45µs/call |
190 | 1968 | 3.76ms | $self->class($class) if defined $class; # specify CLASS | ||
191 | 1968 | 3.75ms | $self->ttl($ttl) if defined $ttl; # specify TTL | ||
192 | |||||
193 | 1968 | 7.29ms | eval { | ||
194 | 1968 | 9.76ms | while ( my ( $attribute, $value ) = each %attribute ) { | ||
195 | $self->$attribute( ref($value) eq 'ARRAY' ? @$value : $value ); | ||||
196 | } | ||||
197 | }; | ||||
198 | 1968 | 3.52ms | die ref($self) eq __PACKAGE__ ? "type $type not implemented" : () if $@; | ||
199 | |||||
200 | 1968 | 20.1ms | return $self; | ||
201 | } | ||||
202 | |||||
203 | |||||
204 | =head2 decode | ||||
205 | |||||
206 | ( $rr, $next ) = decode Net::DNS::RR( \$data, $offset, @opaque ); | ||||
207 | |||||
208 | Decodes a DNS resource record at the specified location within a | ||||
209 | DNS packet. | ||||
210 | |||||
211 | The argument list consists of a reference to the buffer containing | ||||
212 | the packet data and offset indicating where resource record begins. | ||||
213 | Remaining arguments, if any, are passed as opaque data to | ||||
214 | subordinate decoders. | ||||
215 | |||||
216 | Returns a C<Net::DNS::RR> object and the offset of the next record | ||||
217 | in the packet. | ||||
218 | |||||
219 | An exception is raised if the data buffer contains insufficient or | ||||
220 | corrupt data. | ||||
221 | |||||
222 | Any remaining arguments are passed as opaque data to subordinate | ||||
223 | decoders and do not form part of the published interface. | ||||
224 | |||||
225 | =cut | ||||
226 | |||||
227 | 2 | 4.87ms | 3 | 492µs | # spent 268µs (43+224) within Net::DNS::RR::BEGIN@227 which was called:
# once (43µs+224µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 227 # spent 268µs making 1 call to Net::DNS::RR::BEGIN@227
# spent 218µs making 1 call to constant::import
# spent 6µs making 1 call to Net::DNS::RR::CORE:pack |
228 | |||||
229 | sub 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 | |||||
256 | Returns the C<Net::DNS::RR> in binary format suitable for inclusion | ||||
257 | in a DNS packet buffer. | ||||
258 | |||||
259 | The offset indicates the intended location within the packet data | ||||
260 | where the C<Net::DNS::RR> is to be stored. | ||||
261 | |||||
262 | Any remaining arguments are opaque data which are passed intact to | ||||
263 | subordinate encoders. | ||||
264 | |||||
265 | =cut | ||||
266 | |||||
267 | sub 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 | |||||
284 | Returns the C<Net::DNS::RR> in canonical binary format suitable for | ||||
285 | DNSSEC signature validation. | ||||
286 | |||||
287 | The absence of the associative array argument signals to subordinate | ||||
288 | encoders that the canonical uncompressed lower case form of embedded | ||||
289 | domain names is to be used. | ||||
290 | |||||
291 | =cut | ||||
292 | |||||
293 | sub 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 | |||||
309 | Prints the record to the standard output. Calls the string method | ||||
310 | to get the formatted RR representation. | ||||
311 | |||||
312 | =cut | ||||
313 | |||||
314 | sub print { | ||||
315 | print shift->string, "\n"; | ||||
316 | } | ||||
317 | |||||
318 | |||||
319 | =head2 string | ||||
320 | |||||
321 | print $rr->string, "\n"; | ||||
322 | |||||
323 | Returns a string representation of the RR using the zone file format | ||||
324 | described in RFC1035. All domain names are fully qualified with | ||||
325 | trailing dot. This differs from RR attribute methods, which omit | ||||
326 | the trailing dot. | ||||
327 | |||||
328 | =cut | ||||
329 | |||||
330 | sub 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 | |||||
357 | Returns a simplified single line representation of the RR using the | ||||
358 | zone file format defined in RFC1035. This facilitates interaction | ||||
359 | with programs like nsupdate which have rudimentary RR parsers. | ||||
360 | |||||
361 | =cut | ||||
362 | |||||
363 | sub plain { | ||||
364 | join ' ', shift->token; | ||||
365 | } | ||||
366 | |||||
367 | |||||
368 | =head2 token | ||||
369 | |||||
370 | @token = $rr->token; | ||||
371 | |||||
372 | Returns a token list representation of the RR zone file string. | ||||
373 | |||||
374 | =cut | ||||
375 | |||||
376 | sub 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 | |||||
394 | Returns the generic RR representation defined in RFC3597. This facilitates | ||||
395 | creation of zone files containing RRs unrecognised by outdated nameservers | ||||
396 | and provisioning software. | ||||
397 | |||||
398 | =cut | ||||
399 | |||||
400 | sub 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 | |||||
418 | Returns the owner name of the record. | ||||
419 | |||||
420 | =cut | ||||
421 | |||||
422 | # spent 88.5ms (50.2+38.3) within Net::DNS::RR::owner which was called 1968 times, avg 45µs/call:
# 1968 times (50.2ms+38.3ms) by Net::DNS::RR::_new_hash at line 189, avg 45µs/call | ||||
423 | 1968 | 4.30ms | my $self = shift; | ||
424 | 1968 | 18.3ms | 1968 | 38.3ms | $self->{owner} = new Net::DNS::DomainName1035(shift) if scalar @_; # spent 38.3ms making 1968 calls to Net::DNS::Domain::new, avg 19µs/call |
425 | 1968 | 14.8ms | $self->{owner}->name if defined wantarray; | ||
426 | } | ||||
427 | |||||
428 | sub name { &owner; } ## historical | ||||
429 | |||||
430 | |||||
431 | =head2 type | ||||
432 | |||||
433 | $type = $rr->type; | ||||
434 | |||||
435 | Returns the record type. | ||||
436 | |||||
437 | =cut | ||||
438 | |||||
439 | sub 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 | |||||
450 | Resource record class. | ||||
451 | |||||
452 | =cut | ||||
453 | |||||
454 | sub 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 | |||||
466 | Resource 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. | ||||
473 | 1 | 6µs | my %unit = ( W => 604800, D => 86400, H => 3600, M => 60, S => 1 ); | ||
474 | |||||
475 | sub 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 | |||||
496 | sub _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 | |||||
502 | sub _encode_rdata { ## encode rdata as wire-format octet string | ||||
503 | my $rdata = shift->{rdata}; | ||||
504 | } | ||||
505 | |||||
506 | |||||
507 | sub _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 | |||||
514 | sub _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 | |||||
521 | 1 | 10µs | # spent 5µs within Net::DNS::RR::_defaults which was called:
# once (5µs+0s) by Net::DNS::RR::_subclass at line 701 | ||
522 | |||||
523 | |||||
524 | sub 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 | |||||
531 | sub 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 | |||||
540 | Resource record data section when viewed as opaque octets. | ||||
541 | |||||
542 | =cut | ||||
543 | |||||
544 | sub 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 | |||||
561 | Returns a string representation of the RR-specific data. | ||||
562 | |||||
563 | =cut | ||||
564 | |||||
565 | sub 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 | |||||
579 | Returns the uncompressed length of the encoded RR-specific data. | ||||
580 | |||||
581 | =cut | ||||
582 | |||||
583 | sub rdlength { | ||||
584 | length shift->rdata; | ||||
585 | } | ||||
586 | |||||
587 | |||||
588 | ################################################################################### | ||||
589 | |||||
590 | =head1 Sorting of RR arrays | ||||
591 | |||||
592 | Sorting of RR arrays is done by Net::DNS::rrsort(), see documentation | ||||
593 | for L<Net::DNS>. This package provides class methods to set the | ||||
594 | comparator 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 | |||||
607 | set_rrsort_func() must be called as a class method. The first argument is | ||||
608 | the 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 | ||||
610 | get_rrsort_func() is called without an RR attribute as argument. | ||||
611 | |||||
612 | The second argument is a reference to a comparator function that uses the | ||||
613 | global variables $a and $b in the Net::DNS package. During sorting, the | ||||
614 | variables $a and $b will contain references to objects of the class whose | ||||
615 | set_rrsort_func() was called. The above sorting function will only be | ||||
616 | applied to Net::DNS::RR::MX objects. | ||||
617 | |||||
618 | The above example is the sorting function implemented in MX. | ||||
619 | |||||
620 | =cut | ||||
621 | |||||
622 | our %rrsortfunct; | ||||
623 | |||||
624 | sub 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 | |||||
639 | get_rrsort_func() returns a reference to the comparator function. | ||||
640 | |||||
641 | =cut | ||||
642 | |||||
643 | 1 | 6µs | my $default = sub { $Net::DNS::a->canonical() cmp $Net::DNS::b->canonical(); }; | ||
644 | |||||
645 | sub 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 | |||||
668 | 1 | 6µs | our %_MINIMAL = ( 'ANY' => bless ['type' => 255], __PACKAGE__ ); | ||
669 | 1 | 8µs | our %_LOADED = %_MINIMAL; | ||
670 | |||||
671 | # spent 51.8ms (45.7+6.11) within Net::DNS::RR::_subclass which was called 1968 times, avg 26µs/call:
# 1968 times (45.7ms+6.11ms) by Net::DNS::RR::_new_hash at line 188, avg 26µs/call | ||||
672 | 1968 | 4.51ms | my ( $class, $rrname, $default ) = @_; | ||
673 | |||||
674 | 1968 | 4.98ms | unless ( $_LOADED{$rrname} ) { | ||
675 | 1 | 7µs | 1 | 11µs | my $rrtype = typebyname($rrname); # spent 11µs making 1 call to Net::DNS::Parameters::typebyname |
676 | |||||
677 | 1 | 4µs | unless ( $_LOADED{$rrtype} ) { # load once only | ||
678 | 1 | 8µs | local @INC = LIB; | ||
679 | |||||
680 | 1 | 9µs | 1 | 11µs | my $identifier = typebyval($rrtype); # spent 11µs making 1 call to Net::DNS::Parameters::typebyval |
681 | 1 | 15µs | 1 | 3µs | $identifier =~ s/\W/_/g; # kosher Perl identifier # spent 3µs making 1 call to Net::DNS::RR::CORE:subst |
682 | |||||
683 | 1 | 4µs | my $subclass = join '::', __PACKAGE__, $identifier; | ||
684 | |||||
685 | 1 | 106µs | unless ( eval "require $subclass" ) { # spent 382µ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 | |||||
694 | 1 | 2µs | $subclass = __PACKAGE__ if $@; | ||
695 | |||||
696 | # cache pre-built minimal and populated default object images | ||||
697 | 1 | 5µs | my @base = ( 'type' => $rrtype ); | ||
698 | 1 | 8µs | $_MINIMAL{$rrtype} = bless [@base], $subclass; | ||
699 | |||||
700 | 1 | 4µs | my $object = bless {@base}, $subclass; | ||
701 | 1 | 12µs | 1 | 5µs | $object->_defaults; # spent 5µs making 1 call to Net::DNS::RR::_defaults |
702 | 1 | 17µs | $_LOADED{$rrtype} = bless [%$object], $subclass; | ||
703 | } | ||||
704 | |||||
705 | 1 | 4µs | $_MINIMAL{$rrname} = $_MINIMAL{$rrtype}; | ||
706 | 1 | 3µs | $_LOADED{$rrname} = $_LOADED{$rrtype}; | ||
707 | } | ||||
708 | |||||
709 | 1968 | 5.23ms | my $prebuilt = $default ? $_LOADED{$rrname} : $_MINIMAL{$rrname}; | ||
710 | 1968 | 40.7ms | bless {@$prebuilt}, ref($prebuilt); # create object | ||
711 | } | ||||
712 | |||||
713 | |||||
714 | sub _annotation { | ||||
715 | my $self = shift; | ||||
716 | $self->{annotation} = ["@_"] if scalar @_; | ||||
717 | return @{$self->{annotation} || []} if wantarray; | ||||
718 | } | ||||
719 | |||||
720 | |||||
721 | 1 | 12µs | my %ignore = map( ( $_ => 1 ), @core, 'annotation', '#' ); | ||
722 | |||||
723 | sub _empty { | ||||
724 | ( $_[0]->{'#'} ||= scalar grep !$ignore{$_}, keys %{$_[0]} ) == 0; | ||||
725 | } | ||||
726 | |||||
727 | |||||
728 | sub _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 | |||||
750 | our $AUTOLOAD; | ||||
751 | |||||
752 | sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) | ||||
753 | |||||
754 | sub AUTOLOAD { ## Default method | ||||
755 | my $self = shift; | ||||
756 | my $oref = ref($self); | ||||
757 | |||||
758 | 2 | 455µs | 2 | 139µs | # spent 84µs (30+54) within Net::DNS::RR::BEGIN@758 which was called:
# once (30µs+54µs) by Net::DNS::Resolver::Base::BEGIN@56 at line 758 # spent 84µs making 1 call to Net::DNS::RR::BEGIN@758
# spent 54µ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 | *** | ||||
778 | END | ||||
779 | goto &{'Carp::confess'}; | ||||
780 | } | ||||
781 | |||||
782 | |||||
783 | 1 | 32µs | 1; | ||
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 | |||||
# spent 3µs within Net::DNS::RR::CORE:subst which was called:
# once (3µs+0s) by Net::DNS::RR::_subclass at line 681 |