File Coverage

blib/lib/Net/DNS/Resolver/Programmable.pm
Criterion Covered Total %
statement 48 51 94.1
branch 10 16 62.5
condition 7 12 58.3
subroutine 8 8 100.0
pod 2 2 100.0
total 75 89 84.2


line stmt bran cond sub pod time code
1             #
2             # Net::DNS::Resolver::Programmable
3             # A Net::DNS::Resolver descendant class for offline emulation of DNS
4             #
5             # (C) 2006-2007 Julian Mehnle
6             # Maintained from 2017 by David Precious (BIGPRESH)
7              
8             #
9             ##############################################################################
10              
11             package Net::DNS::Resolver::Programmable;
12              
13             =head1 NAME
14              
15             Net::DNS::Resolver::Programmable - programmable DNS resolver class for offline
16             emulation of DNS
17              
18              
19             =cut
20              
21              
22             our $VERSION;
23             $VERSION = '0.007';
24              
25 1     1   25870 use warnings;
  1         4  
  1         47  
26 1     1   9 use strict;
  1         4  
  1         32  
27              
28 1     1   719 use Net::DNS;
  1         110766  
  1         188  
29 1     1   17 use base 'Net::DNS::Resolver';
  1         3  
  1         98  
30              
31              
32 1     1   8 use constant TRUE => (0 == 0);
  1         4  
  1         141  
33 1     1   11 use constant FALSE => not TRUE;
  1         4  
  1         584  
34              
35             my %rcode = map { $_ => 1 } qw(NOERROR FORMERR SERVFAIL NXDOMAIN NOTIMP
36             REFUSED YXDOMAIN YXRRSET NXRRSET NOTAUTH NOTZONE BADVERS
37             BADSIG BADKEY BADTIME BADMODE BADNAME BADALG BADTRUNC);
38              
39              
40             # Interface:
41             ##############################################################################
42              
43             =head1 SYNOPSIS
44              
45             use Net::DNS::Resolver::Programmable;
46             use Net::DNS::RR;
47            
48             my $resolver = Net::DNS::Resolver::Programmable->new(
49             records => {
50             'example.com' => [
51             Net::DNS::RR->new('example.com. NS ns.example.org.'),
52             Net::DNS::RR->new('example.com. A 192.168.0.1')
53             ],
54             'ns.example.org' => [
55             Net::DNS::RR->new('ns.example.org. A 192.168.1.1')
56             ]
57             },
58            
59             resolver_code => sub {
60             my ($domain, $rr_type, $class) = @_;
61             ...
62             return ($result, $aa, @rrs);
63             }
64             );
65              
66             =cut
67              
68             # Implementation:
69             ##############################################################################
70              
71             =head1 DESCRIPTION
72              
73             B is a B descendant
74             class that allows a virtual DNS to be emulated instead of querying the real
75             DNS. A set of static DNS records may be supplied, or arbitrary code may be
76             specified as a means for retrieving DNS records, or even generating them on the
77             fly.
78              
79             =head2 Constructor
80              
81             The following constructor is provided:
82              
83             =over
84              
85             =item B: returns I
86              
87             Creates a new programmed DNS resolver object.
88              
89             %options is a list of key/value pairs representing any of the following
90             options:
91              
92             =over
93              
94             =item B
95              
96             A reference to a hash of arrays containing a static set of I
97             objects. The hash entries must be indexed by fully qualified domain names
98             (lower-case, without any trailing dots), and the entries themselves must be
99             arrays of the RR objects pertaining to these domain names. For example:
100              
101             records => {
102             'example.com' => [
103             Net::DNS::RR->new('example.com. NS ns.example.org.'),
104             Net::DNS::RR->new('example.com. A 192.168.0.1')
105             ],
106             'www.example.com' => [
107             Net::DNS::RR->new('www.example.com. A 192.168.0.2')
108             ],
109             'ns.example.org' => [
110             Net::DNS::RR->new('ns.example.org. A 192.168.1.1')
111             ]
112             }
113              
114             If this option is specified, the resolver retrieves requested RRs from this
115             data structure.
116              
117             =item B
118              
119             A code reference used as a call-back for dynamically retrieving requested RRs.
120              
121             The code must take the following query parameters as arguments: the I,
122             I, and I.
123              
124             It must return a list composed of: the response's I (by name, as
125             returned by L<< Net::DNS::Header->rcode|Net::DNS::Header/rcode >>), the
126             I<< C (authoritative answer) flag >> (I, use B if you don't
127             care), and the I. If an error string is returned
128             instead of a valid RCODE, a I object is not constructed but
129             an error condition for the resolver is signaled instead.
130              
131             For example:
132              
133             resolver_code => sub {
134             my ($domain, $rr_type, $class) = @_;
135             ...
136             return ($result, $aa, @rrs);
137             }
138              
139             If both this and the C option are specified, then statically
140             programmed records are used in addition to any that are returned by the
141             configured resolver code.
142              
143             =item B
144              
145             =item B
146              
147             =item B
148              
149             =item B
150              
151             =item B
152              
153             These Net::DNS::Resolver options are also meaningful with
154             Net::DNS::Resolver::Programmable. See L for their
155             descriptions.
156              
157             =back
158              
159             =cut
160              
161             sub new {
162 1     1 1 3441 my ($class, %options) = @_;
163            
164             # Create new object:
165 1         24 my $self = $class->SUPER::new(%options);
166            
167 1         408 $self->{records} = $options{records};
168 1         3 $self->{resolver_code} = $options{resolver_code};
169            
170 1         4 return $self;
171             }
172              
173             =back
174              
175             =head2 Instance methods
176              
177             The following instance methods of I are also supported by
178             I:
179              
180             =over
181              
182             =item B: returns I
183              
184             =item B: returns I
185              
186             =item B: returns I
187              
188             Performs an offline DNS query, using the statically programmed DNS RRs and/or
189             the configured dynamic resolver code. See the L constructor's C
190             and C options. See the descriptions of L
191             send|Net::DNS::Resolver/search> for details about the calling syntax of these
192             methods.
193              
194             =cut
195              
196             sub send {
197 4     4 1 5474 my $self = shift;
198            
199             # We could be passed a Net::DNS::Packet object, or a set of strings; handle
200             # both
201 4         11 my ($packet, $question);
202 4 100 66     41 if (Scalar::Util::blessed($_[0]) && $_[0]->isa('Net::DNS::Packet')) {
203 1         3 $packet = $_[0];
204             # TODO: is it a safe assumption that a packet we're passed will only
205             # contain one Question object?
206 1         5 ($question) = $packet->question;
207             } else {
208 3         24 $question = Net::DNS::Question->new(@_);
209             }
210 4         270 my $domain = lc($question->qname);
211 4         162 my $rr_type = $question->qtype;
212 4         58 my $class = $question->qclass;
213            
214 4         67 $self->_reset_errorstring;
215            
216 4         24 my ($result, $aa, @answer_rrs);
217            
218 4 50       20 if (defined(my $resolver_code = $self->{resolver_code})) {
219 0         0 ($result, $aa, @answer_rrs) = $resolver_code->($domain, $rr_type, $class);
220             }
221            
222 4 50 33     17 if ( not defined($result) or defined($rcode{$result}) ) {
223             # Valid RCODE, return a packet:
224            
225 4 50       14 $aa = TRUE if not defined($aa);
226 4 50       13 $result = 'NOERROR' if not defined($result);
227            
228 4 50       13 if (defined(my $records = $self->{records})) {
229 4 50       22 if (ref(my $rrs_for_domain = $records->{$domain}) eq 'ARRAY') {
230 4         17 foreach my $rr (@$rrs_for_domain) {
231 7 100 66     177 push(@answer_rrs, $rr)
      66        
232             if $rr->name eq $domain
233             and $rr->type eq $rr_type
234             and $rr->class eq $class;
235             }
236             }
237             }
238            
239 4         231 my $response_packet = Net::DNS::Packet->new($domain, $rr_type, $class);
240 4         267 $response_packet->header->qr(TRUE);
241 4         111 $response_packet->header->rcode($result);
242 4         5172 $response_packet->header->aa($aa);
243 4         81 $response_packet->push(answer => @answer_rrs);
244            
245 4         92 return $response_packet;
246             }
247             else {
248             # Invalid RCODE, signal error condition by not returning a packet:
249 0           $self->errorstring($result);
250 0           return undef;
251             }
252             }
253              
254             =item B
255              
256             =item B: returns I
257              
258             =item B: returns I of I
259              
260             =item B: returns I
261              
262             =item B: returns I
263              
264             =item B: returns I
265              
266             =item B: returns I
267              
268             =item B: returns I
269              
270             =item B: returns I
271              
272             See L.
273              
274             =back
275              
276             Currently the following methods of I are B supported:
277             B, B, B, B, B, B,
278             B, B, B, B, B, B, B,
279             B, B, B, B, B,
280             B, B, B, B, B.
281             The effects of using these on I objects are
282             undefined.
283              
284             =head1 SEE ALSO
285              
286             L
287              
288             For availability, support, and license information, see the README file
289             included with Net::DNS::Resolver::Programmable.
290              
291             =head1 AUTHORS
292              
293             David Precious (BIGPRESH) C<< >> took on maintainership
294             in July 2017
295              
296             Original author Julian Mehnle C<< >>
297              
298             =head1 ACKNOWLEDGEMENTS
299              
300             Dick Franks (rwfranks)
301              
302             (This section was added by BIGPRESH in July 2017, so currently omits
303             acknowledgements for those who contributed things in the past; I may
304             retrospectively add them in future.)
305              
306              
307              
308             =cut
309              
310             TRUE;
311              
312             # vim:sts=4 sw=4 et