File Coverage

blib/lib/Net/DNS/Question.pm
Criterion Covered Total %
statement 102 102 100.0
branch 42 42 100.0
condition 15 15 100.0
subroutine 23 23 100.0
pod 14 14 100.0
total 196 196 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::Question;
2              
3 93     93   72231 use strict;
  93         216  
  93         2813  
4 93     93   490 use warnings;
  93         224  
  93         4349  
5              
6             our $VERSION = (qw$Id: Question.pm 1895 2023-01-16 13:38:08Z willem $)[2];
7              
8              
9             =head1 NAME
10              
11             Net::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              
21             A Net::DNS::Question object represents a record in the question
22             section of a DNS packet.
23              
24             =cut
25              
26              
27 93     93   1047 use integer;
  93         204  
  93         460  
28 93     93   1900 use Carp;
  93         184  
  93         6438  
29              
30 93     93   1091 use Net::DNS::Parameters qw(%classbyname %typebyname :class :type);
  93         250  
  93         12628  
31 93     93   2137 use Net::DNS::Domain;
  93         228  
  93         2907  
32 93     93   2114 use Net::DNS::DomainName;
  93         299  
  93         29633  
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              
46             Creates a question object from the domain, type, and class passed as
47             arguments. One or both type and class arguments may be omitted and
48             will assume the default values shown above.
49              
50             RFC4291 and RFC4632 IP address/prefix notation is supported for
51             queries in both in-addr.arpa and ip6.arpa namespaces.
52              
53             =cut
54              
55             sub new {
56 314     314 1 56464 my $self = bless {}, shift;
57 314         613 my $qname = shift;
58 314   100     965 my $qtype = shift || '';
59 314   100     1049 my $qclass = shift || '';
60              
61             # tolerate (possibly unknown) type and class in zone file order
62 314 100       932 unless ( exists $classbyname{$qclass} ) {
63 251 100       621 ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $classbyname{$qtype};
64 251 100       658 ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qtype =~ /CLASS/;
65             }
66 314 100       907 unless ( exists $typebyname{$qtype} ) {
67 140 100       301 ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $typebyname{$qclass};
68 140 100       310 ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qclass =~ /TYPE/;
69             }
70              
71             # if argument is an IP address, do appropriate reverse lookup
72 314 100 100     2315 if ( defined $qname and $qname =~ m/:|\d$/ ) {
73 84 100       196 if ( my $reverse = _dns_addr($qname) ) {
74 82         127 $qname = $reverse;
75 82   100     256 $qtype ||= 'PTR';
76             }
77             }
78              
79 314         1320 $self->{qname} = Net::DNS::DomainName1035->new($qname);
80 312   100     1400 $self->{qtype} = typebyname( $qtype || 'A' );
81 312   100     1375 $self->{qclass} = classbyname( $qclass || 'IN' );
82              
83 312         1033 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              
93             Decodes the question record at the specified location within a DNS
94             wire-format packet. The first argument is a reference to the buffer
95             containing the packet data. The second argument is the offset of
96             the start of the question record.
97              
98             Returns a Net::DNS::Question object and the offset of the next
99             location in the packet.
100              
101             An exception is raised if the object cannot be created
102             (e.g., corrupt or insufficient data).
103              
104             =cut
105              
106 93     93   731 use constant QFIXEDSZ => length pack 'n2', (0) x 2;
  93         217  
  93         124957  
107              
108             sub decode {
109 173     173 1 1096 my ( $class, @argument ) = @_;
110 173         451 my ( $data, $offset ) = @argument;
111 173         470 my $self = bless {}, $class;
112              
113 173         1151 ( $self->{qname}, $offset ) = Net::DNS::DomainName1035->decode(@argument);
114              
115 160         501 my $next = $offset + QFIXEDSZ;
116 160 100       607 die 'corrupt wire-format data' if length $$data < $next;
117 155         670 @{$self}{qw(qtype qclass)} = unpack "\@$offset n2", $$data;
  155         615  
118              
119 155 100       809 return wantarray ? ( $self, $next ) : $self;
120             }
121              
122              
123             =head2 encode
124              
125             $data = $question->encode( $offset, $hash );
126              
127             Returns the Net::DNS::Question in binary format suitable for
128             inclusion in a DNS packet buffer.
129              
130             The optional arguments are the offset within the packet data where
131             the Net::DNS::Question is to be stored and a reference to a hash
132             table used to index compressed names within the packet.
133              
134             =cut
135              
136             sub encode {
137 243     243 1 679 my ( $self, @opaque ) = @_;
138 243         1344 return pack 'a* n2', $self->{qname}->encode(@opaque), @{$self}{qw(qtype qclass)};
  243         1452  
139             }
140              
141              
142             =head2 string
143              
144             print "string = ", $question->string, "\n";
145              
146             Returns a string representation of the question record.
147              
148             =cut
149              
150             sub string {
151 84     84 1 793 my $self = shift;
152 84         212 return join "\t", $self->{qname}->string, $self->qclass, $self->qtype;
153             }
154              
155              
156             =head2 print
157              
158             $object->print;
159              
160             Prints the record to the standard output. Calls the string() method
161             to get the string representation.
162              
163             =cut
164              
165             sub print {
166 1     1 1 189 print &string, "\n";
167 1         5 return;
168             }
169              
170              
171             =head2 name
172              
173             $name = $question->name;
174              
175             Internationalised domain name corresponding to the qname attribute.
176              
177             Decoding non-ASCII domain names is computationally expensive and
178             undesirable for names which are likely to be used to construct
179             further queries.
180              
181             When required to communicate with humans, the 'proper' domain name
182             should be extracted from a query or reply packet.
183              
184             $query = Net::DNS::Packet->new( $example, 'SOA' );
185             $reply = $resolver->send($query) or die;
186             ($question) = $reply->question;
187             $name = $question->name;
188              
189             =cut
190              
191             sub name {
192 2     2 1 7 my ( $self, @argument ) = @_;
193 2         7 for (@argument) { croak 'immutable object: argument invalid' }
  1         70  
194 1         8 return $self->{qname}->xname;
195             }
196              
197              
198             =head2 qname, zname
199              
200             $qname = $question->qname;
201             $zname = $question->zname;
202              
203             Fully qualified domain name in the form required for a query
204             transmitted to a nameserver. In dynamic update packets, this
205             attribute is known as zname() and refers to the zone name.
206              
207             =cut
208              
209             sub qname {
210 185     185 1 969 my ( $self, @argument ) = @_;
211 185         438 for (@argument) { croak 'immutable object: argument invalid' }
  1         95  
212 184         658 return $self->{qname}->name;
213             }
214              
215 3     3 1 14 sub zname { return &qname; }
216              
217              
218             =head2 qtype, ztype, type
219              
220             $qtype = $question->type;
221             $qtype = $question->qtype;
222             $ztype = $question->ztype;
223              
224             Returns the question type attribute. In dynamic update packets,
225             this attribute is known as ztype() and refers to the zone type.
226              
227             =cut
228              
229             sub type {
230 94     94 1 160 my ( $self, @argument ) = @_;
231 94         147 for (@argument) { croak 'immutable object: argument invalid' }
  1         75  
232 93         192 return typebyval( $self->{qtype} );
233             }
234              
235 91     91 1 159 sub qtype { return &type; }
236 2     2 1 8 sub ztype { return &type; }
237              
238              
239             =head2 qclass, zclass, class
240              
241             $qclass = $question->class;
242             $qclass = $question->qclass;
243             $zclass = $question->zclass;
244              
245             Returns the question class attribute. In dynamic update packets,
246             this attribute is known as zclass() and refers to the zone class.
247              
248             =cut
249              
250             sub class {
251 184     184 1 310 my ( $self, @argument ) = @_;
252 184         336 for (@argument) { croak 'immutable object: argument invalid' }
  1         75  
253 183         397 return classbyval( $self->{qclass} );
254             }
255              
256 86     86 1 165 sub qclass { return &class; }
257 97     97 1 202 sub zclass { return &class; }
258              
259              
260             ########################################
261              
262             sub _dns_addr { ## Map IP address into reverse lookup namespace
263 85     85   152 local $_ = shift;
264              
265             # IP address must contain address characters only
266 85         174 s/[%].+$//; # discard RFC4007 scopeid
267 85 100       335 return unless m#^[a-fA-F0-9:./]+$#;
268              
269 84         289 my ( $address, $pfxlen ) = split m#/#;
270              
271             # map IPv4 address to in-addr.arpa space
272 84 100       355 if (m#^\d*[.\d]*\d(/\d+)?$#) {
273 22         90 my @parse = split /\./, $address;
274 22 100       52 $pfxlen = scalar(@parse) << 3 unless $pfxlen;
275 22 100       72 my $last = $pfxlen > 24 ? 3 : ( $pfxlen - 1 ) >> 3;
276 22         139 return join '.', reverse( ( @parse, (0) x 3 )[0 .. $last] ), 'in-addr.arpa.';
277             }
278              
279             # map IPv6 address to ip6.arpa space
280 62 100       265 return unless m#^[:\w]+:([.\w]*)(/\d+)?$#;
281 61   100     219 my $rhs = $1 || '0';
282 61 100       155 return _dns_addr($rhs) if m#^[:0]*:0*:[fF]{4}:[^:]+$#; # IPv4
283 60 100       129 $rhs = sprintf '%x%0.2x:%x%0.2x', map { $_ || 0 } split( /\./, $rhs, 4 ) if /\./;
  4 100       19  
284 60         364 $address =~ s/:[^:]*$/:0$rhs/;
285 60         245 my @parse = split /:/, ( reverse "0$address" ), 9;
286 60 100       124 my @xpand = map { /./ ? $_ : ('0') x ( 9 - @parse ) } @parse; # expand ::
  368         940  
287 60 100       170 $pfxlen = ( scalar(@xpand) << 4 ) unless $pfxlen; # implicit length if unspecified
288 60 100       138 my $len = $pfxlen > 124 ? 32 : ( $pfxlen + 3 ) >> 2;
289 60         114 my $hex = pack 'A4' x 8, map { $_ . '000' } ('0') x ( 8 - @xpand ), @xpand;
  480         897  
290 60         698 return join '.', split( //, substr( $hex, -$len ) ), 'ip6.arpa.';
291             }
292              
293              
294             1;
295             __END__