← 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/Question.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sNet::DNS::Question::::BEGIN@106Net::DNS::Question::BEGIN@106
0000s0sNet::DNS::Question::::BEGIN@27Net::DNS::Question::BEGIN@27
0000s0sNet::DNS::Question::::BEGIN@28Net::DNS::Question::BEGIN@28
0000s0sNet::DNS::Question::::BEGIN@3Net::DNS::Question::BEGIN@3
0000s0sNet::DNS::Question::::BEGIN@30Net::DNS::Question::BEGIN@30
0000s0sNet::DNS::Question::::BEGIN@31Net::DNS::Question::BEGIN@31
0000s0sNet::DNS::Question::::BEGIN@32Net::DNS::Question::BEGIN@32
0000s0sNet::DNS::Question::::BEGIN@4Net::DNS::Question::BEGIN@4
0000s0sNet::DNS::Question::::CORE:packNet::DNS::Question::CORE:pack (opcode)
0000s0sNet::DNS::Question::::__ANON__Net::DNS::Question::__ANON__ (xsub)
0000s0sNet::DNS::Question::::_dns_addrNet::DNS::Question::_dns_addr
0000s0sNet::DNS::Question::::classNet::DNS::Question::class
0000s0sNet::DNS::Question::::decodeNet::DNS::Question::decode
0000s0sNet::DNS::Question::::encodeNet::DNS::Question::encode
0000s0sNet::DNS::Question::::nameNet::DNS::Question::name
0000s0sNet::DNS::Question::::newNet::DNS::Question::new
0000s0sNet::DNS::Question::::printNet::DNS::Question::print
0000s0sNet::DNS::Question::::qclassNet::DNS::Question::qclass
0000s0sNet::DNS::Question::::qnameNet::DNS::Question::qname
0000s0sNet::DNS::Question::::qtypeNet::DNS::Question::qtype
0000s0sNet::DNS::Question::::stringNet::DNS::Question::string
0000s0sNet::DNS::Question::::typeNet::DNS::Question::type
0000s0sNet::DNS::Question::::zclassNet::DNS::Question::zclass
0000s0sNet::DNS::Question::::znameNet::DNS::Question::zname
0000s0sNet::DNS::Question::::ztypeNet::DNS::Question::ztype
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::Question;
2
3use strict;
4use warnings;
5
6our $VERSION = (qw$Id: Question.pm 1812 2020-10-07 18:09:53Z willem $)[2];
7
8
9=head1 NAME
10
11Net::DNS::Question - DNS question record
12
13=head1 SYNOPSIS
14
15 use Net::DNS::Question;
16
17 $question = Net::DNS::Question->new('example.com', 'AAAA', 'IN');
18
19=head1 DESCRIPTION
20
21A Net::DNS::Question object represents a record in the question
22section of a DNS packet.
23
24=cut
25
26
27use integer;
28use Carp;
29
30use Net::DNS::Parameters qw(%classbyname %typebyname :class :type);
31use Net::DNS::Domain;
32use Net::DNS::DomainName;
33
34
35=head1 METHODS
36
37=head2 new
38
39 $question = Net::DNS::Question->new('example.com', 'AAAA', 'IN');
40 $question = Net::DNS::Question->new('example.com', 'A', 'IN');
41 $question = Net::DNS::Question->new('example.com');
42
43 $question = Net::DNS::Question->new('2001::DB8::dead:beef', 'PTR', 'IN');
44 $question = Net::DNS::Question->new('2001::DB8::dead:beef');
45
46Creates a question object from the domain, type, and class passed as
47arguments. One or both type and class arguments may be omitted and
48will assume the default values shown above.
49
50RFC4291 and RFC4632 IP address/prefix notation is supported for
51queries in both in-addr.arpa and ip6.arpa namespaces.
52
53=cut
54
55sub new {
56 my $self = bless {}, shift;
57 my $qname = shift;
58 my $qtype = shift || '';
59 my $qclass = shift || '';
60
61 # tolerate (possibly unknown) type and class in zone file order
62 unless ( exists $classbyname{$qclass} ) {
63 ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $classbyname{$qtype};
64 ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qtype =~ /CLASS/;
65 }
66 unless ( exists $typebyname{$qtype} ) {
67 ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $typebyname{$qclass};
68 ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qclass =~ /TYPE/;
69 }
70
71 # if argument is an IP address, do appropriate reverse lookup
72 if ( defined $qname and $qname =~ m/:|\d$/ ) {
73 if ( my $reverse = _dns_addr($qname) ) {
74 $qname = $reverse;
75 $qtype ||= 'PTR';
76 }
77 }
78
79 $self->{qname} = Net::DNS::DomainName1035->new($qname);
80 $self->{qtype} = typebyname( $qtype || 'A' );
81 $self->{qclass} = classbyname( $qclass || 'IN' );
82
83 return $self;
84}
85
86
87=head2 decode
88
89 $question = Net::DNS::Question->decode(\$data, $offset);
90
91 ($question, $offset) = Net::DNS::Question->decode(\$data, $offset);
92
93Decodes the question record at the specified location within a DNS
94wire-format packet. The first argument is a reference to the buffer
95containing the packet data. The second argument is the offset of
96the start of the question record.
97
98Returns a Net::DNS::Question object and the offset of the next
99location in the packet.
100
101An exception is raised if the object cannot be created
102(e.g., corrupt or insufficient data).
103
104=cut
105
106use constant QFIXEDSZ => length pack 'n2', (0) x 2;
107
108sub decode {
109 my $self = bless {}, shift;
110 my ( $data, $offset ) = @_;
111
112 ( $self->{qname}, $offset ) = Net::DNS::DomainName1035->decode(@_);
113
114 my $next = $offset + QFIXEDSZ;
115 die 'corrupt wire-format data' if length $$data < $next;
116 @{$self}{qw(qtype qclass)} = unpack "\@$offset n2", $$data;
117
118 return wantarray ? ( $self, $next ) : $self;
119}
120
121
122=head2 encode
123
124 $data = $question->encode( $offset, $hash );
125
126Returns the Net::DNS::Question in binary format suitable for
127inclusion in a DNS packet buffer.
128
129The optional arguments are the offset within the packet data where
130the Net::DNS::Question is to be stored and a reference to a hash
131table used to index compressed names within the packet.
132
133=cut
134
135sub encode {
136 my $self = shift;
137
138 return pack 'a* n2', $self->{qname}->encode(@_), @{$self}{qw(qtype qclass)};
139}
140
141
142=head2 string
143
144 print "string = ", $question->string, "\n";
145
146Returns a string representation of the question record.
147
148=cut
149
150sub string {
151 my $self = shift;
152
153 return join "\t", $self->{qname}->string, $self->qclass, $self->qtype;
154}
155
156
157=head2 print
158
159 $object->print;
160
161Prints the record to the standard output. Calls the string() method
162to get the string representation.
163
164=cut
165
166sub print {
167 print &string, "\n";
168 return;
169}
170
171
172=head2 name
173
174 $name = $question->name;
175
176Internationalised domain name corresponding to the qname attribute.
177
178Decoding non-ASCII domain names is computationally expensive and
179undesirable for names which are likely to be used to construct
180further queries.
181
182When required to communicate with humans, the 'proper' domain name
183should be extracted from a query or reply packet.
184
185 $query = Net::DNS::Packet->new( $example, 'SOA' );
186 $reply = $resolver->send($query) or die;
187 ($question) = $reply->question;
188 $name = $question->name;
189
190=cut
191
192sub name {
193 my $self = shift;
194
195 croak 'immutable object: argument invalid' if scalar @_;
196 return $self->{qname}->xname;
197}
198
199
200=head2 qname, zname
201
202 $qname = $question->qname;
203 $zname = $question->zname;
204
205Fully qualified domain name in the form required for a query
206transmitted to a nameserver. In dynamic update packets, this
207attribute is known as zname() and refers to the zone name.
208
209=cut
210
211sub qname {
212 my $self = shift;
213
214 croak 'immutable object: argument invalid' if scalar @_;
215 return $self->{qname}->name;
216}
217
218sub zname { return &qname; }
219
220
221=head2 qtype, ztype, type
222
223 $qtype = $question->type;
224 $qtype = $question->qtype;
225 $ztype = $question->ztype;
226
227Returns the question type attribute. In dynamic update packets,
228this attribute is known as ztype() and refers to the zone type.
229
230=cut
231
232sub type {
233 my $self = shift;
234
235 croak 'immutable object: argument invalid' if scalar @_;
236 return typebyval( $self->{qtype} );
237}
238
239sub qtype { return &type; }
240sub ztype { return &type; }
241
242
243=head2 qclass, zclass, class
244
245 $qclass = $question->class;
246 $qclass = $question->qclass;
247 $zclass = $question->zclass;
248
249Returns the question class attribute. In dynamic update packets,
250this attribute is known as zclass() and refers to the zone class.
251
252=cut
253
254sub class {
255 my $self = shift;
256
257 croak 'immutable object: argument invalid' if scalar @_;
258 return classbyval( $self->{qclass} );
259}
260
261sub qclass { return &class; }
262sub zclass { return &class; }
263
264
265########################################
266
267sub _dns_addr { ## Map IP address into reverse lookup namespace
268 local $_ = shift;
269
270 # IP address must contain address characters only
271 s/[%].+$//; # discard RFC4007 scopeid
272 return unless m#^[a-fA-F0-9:./]+$#;
273
274 my ( $address, $pfxlen ) = split m#/#;
275
276 # map IPv4 address to in-addr.arpa space
277 if (m#^\d*[.\d]*\d(/\d+)?$#) {
278 my @parse = split /\./, $address;
279 $pfxlen = scalar(@parse) << 3 unless $pfxlen;
280 my $last = $pfxlen > 24 ? 3 : ( $pfxlen - 1 ) >> 3;
281 return join '.', reverse( ( @parse, (0) x 3 )[0 .. $last] ), 'in-addr.arpa.';
282 }
283
284 # map IPv6 address to ip6.arpa space
285 return unless m#^[:\w]+:([.\w]*)(/\d+)?$#;
286 my $rhs = $1 || '0';
287 return _dns_addr($rhs) if m#^[:0]*:0*:[fF]{4}:[^:]+$#; # IPv4
288 $rhs = sprintf '%x%0.2x:%x%0.2x', map { $_ || 0 } split( /\./, $rhs, 4 ) if /\./;
289 $address =~ s/:[^:]*$/:0$rhs/;
290 my @parse = split /:/, ( reverse "0$address" ), 9;
291 my @xpand = map { /./ ? $_ : ('0') x ( 9 - @parse ) } @parse; # expand ::
292 $pfxlen = ( scalar(@xpand) << 4 ) unless $pfxlen; # implicit length if unspecified
293 my $len = $pfxlen > 124 ? 32 : ( $pfxlen + 3 ) >> 2;
294 my $hex = pack 'A4' x 8, map { $_ . '000' } ('0') x ( 8 - @xpand ), @xpand;
295 return join '.', split( //, substr( $hex, -$len ) ), 'ip6.arpa.';
296}
297
298
2991;
300__END__