File Coverage

blib/lib/Test/DNS.pm
Criterion Covered Total %
statement 18 90 20.0
branch 0 20 0.0
condition 0 11 0.0
subroutine 6 21 28.5
pod 8 8 100.0
total 32 150 21.3


line stmt bran cond sub pod time code
1             package Test::DNS;
2             # ABSTRACT: Test DNS queries and zone configuration
3             $Test::DNS::VERSION = '0.203';
4 7     7   466582 use Moose;
  7         3035762  
  7         54  
5 7     7   53106 use Net::DNS;
  7         635246  
  7         1681  
6 7     7   4469 use Test::Deep 'cmp_bag';
  7         116336  
  7         56  
7 7     7   2292 use parent 'Test::Builder::Module';
  7         23  
  7         190  
8              
9             use constant {
10 7         8607 'MIN_HASH_ARGS' => 3,
11             'MAX_HASH_ARGS' => 4,
12 7     7   2071 };
  7         14  
13              
14             has 'nameservers' => (
15             'is' => 'ro',
16             'isa' => 'ArrayRef',
17             'predicate' => 'has_nameservers',
18             );
19              
20             has 'object' => (
21             'is' => 'ro',
22             'isa' => 'Net::DNS::Resolver',
23             'lazy' => 1,
24             'builder' => '_build_object',
25             );
26              
27             has 'follow_cname' => (
28             'is' => 'ro',
29             'isa' => 'Bool',
30             'default' => sub {0},
31             );
32              
33             has 'warnings' => (
34             'is' => 'ro',
35             'isa' => 'Bool',
36             'default' => sub {1},
37             );
38              
39             my $CLASS = __PACKAGE__;
40              
41             sub BUILD {
42 0     0 1   $Test::Builder::Level += 1;
43 0           return;
44             }
45              
46             sub _build_object {
47 0     0     my $self = shift;
48              
49 0           return Net::DNS::Resolver->new(
50             # Only pass nameservers if we have nameservers
51             ( 'nameservers' => $self->nameservers )x!! $self->has_nameservers,
52             );
53             }
54              
55             sub _is_hash_format {
56 0     0     my ( $self, $type, $hashref, $test_name, $extra ) = @_;
57              
58             # special hash construct
59             # $self, $type, $hashref
60             # OR
61             # $self, $type, $hashref, $test_name
62             return
63 0   0       @_ >= MIN_HASH_ARGS()
64             && @_ <= MAX_HASH_ARGS()
65             && ref $hashref eq 'HASH'
66             && !ref $test_name
67             && ref \$test_name eq 'SCALAR';
68             }
69              
70             sub _handle_record { ## no critic (Subroutines::RequireArgUnpacking);
71 0     0     my $self = shift;
72              
73 0 0         $self->_is_hash_format(@_)
74             and return $self->_handle_hash_format(@_);
75              
76 0           return $self->is_record(@_);
77             }
78              
79             sub _handle_hash_format {
80 0     0     my ( $self, $type, $hashref, $test_name, $extra ) = @_;
81              
82             # $hashref is hashref
83             # $test_name isn't a ref
84             # \$test_name is a SCALAR ref
85 0           my $all_passed = 1;
86 0           foreach my $domain ( keys %{$hashref} ) {
  0            
87 0           my $ips = $hashref->{$domain};
88 0 0         $self->is_record( $type, $domain, $ips, $test_name )
89             or $all_passed = 0;
90             }
91              
92 0           return $all_passed;
93             }
94              
95             # A -> IP
96             sub is_a {
97 0     0 1   my $self = shift;
98 0           return $self->_handle_record( 'A', @_ );
99             }
100              
101             # PTR -> A
102             sub is_ptr {
103 0     0 1   my $self = shift;
104 0           return $self->_handle_record( 'PTR', @_ );
105             }
106              
107             # Domain -> NS
108             sub is_ns {
109 0     0 1   my $self = shift;
110 0           return $self->_handle_record( 'NS', @_ );
111             }
112              
113             # Domain -> MX
114             sub is_mx {
115 0     0 1   my $self = shift;
116 0           return $self->_handle_record( 'MX', @_ );
117             }
118              
119             # Domain -> CNAME
120             sub is_cname {
121 0     0 1   my $self = shift;
122 0           return $self->_handle_record( 'CNAME', @_ );
123             }
124              
125             # Domain -> TXT
126             sub is_txt {
127 0     0 1   my $self = shift;
128 0           return $self->_handle_record( 'TXT', @_ );
129             }
130              
131             sub _get_method {
132 0     0     my ( $self, $type ) = @_;
133 0           my %method_by_type = (
134             'A' => 'address',
135             'NS' => 'nsdname',
136             'MX' => 'exchange',
137             'PTR' => 'ptrdname',
138             'CNAME' => 'cname',
139             'TXT' => 'txtdata',
140             );
141              
142 0   0       return $method_by_type{$type} || 0;
143             }
144              
145             sub _recurse_a_records {
146 0     0     my ( $self, $results, $rr ) = @_;
147 0           my $res = $self->object;
148              
149 0 0         if ( $rr->type eq 'CNAME' ) {
    0          
150 0           my $cname_method = $self->_get_method('CNAME');
151 0           my $cname = $rr->$cname_method;
152 0           my $query = $res->query( $cname, 'A' );
153              
154 0 0         if ($query) {
155 0           my @records = $query->answer;
156 0           foreach my $record (@records) {
157 0           $self->_recurse_a_records( $results, $record );
158             }
159             }
160             } elsif ( $rr->type eq 'A' ) {
161 0           my $a_method = $self->_get_method('A');
162 0           $results->{ $rr->$a_method } = 1;
163             }
164              
165 0           return;
166             }
167              
168             sub is_record {
169 0     0 1   my ( $self, $type, $input, $expected, $test_name ) = @_;
170              
171 0           my $res = $self->object;
172 0           my $tb = $CLASS->builder;
173 0           my $method = $self->_get_method($type);
174 0           my $query_res = $res->query( $input, $type );
175 0           my $results = {};
176              
177 0 0         ref $expected eq 'ARRAY'
178             or $expected = [$expected];
179              
180 0   0       $test_name ||= "[$type] $input -> " . join ', ', @{$expected};
  0            
181              
182 0 0         if (!$query_res) {
183 0           $self->_warn( $type, "'$input' has no query result" );
184 0           $tb->ok( 0, $test_name );
185 0           return;
186             }
187              
188 0           my @records = $query_res->answer;
189              
190 0           foreach my $rr (@records) {
191 0 0         if ( $rr->type ne $type ) {
192 0 0 0       if ( $rr->type eq 'CNAME' && $self->follow_cname ) {
193 0           $self->_recurse_a_records( $results, $rr );
194             } else {
195 0           $self->_warn( $type, 'got incorrect RR type: ' . $rr->type );
196             }
197             } else {
198 0           $results->{ $rr->$method } = 1;
199             }
200             }
201              
202 0           return cmp_bag( [ keys %{$results} ], $expected, $test_name );
  0            
203             }
204              
205             sub _warn {
206 0     0     my ( $self, $type, $msg ) = @_;
207              
208 0 0         $self->warnings
209             or return;
210              
211 0           chomp $msg;
212 0           my $tb = $CLASS->builder;
213 0           $tb->diag("!! Warning: [$type] $msg !!");
214              
215 0           return;
216             }
217              
218 7     7   56 no Moose;
  7         48  
  7         93  
219             __PACKAGE__->meta->make_immutable;
220              
221             1;
222              
223             __END__
224              
225             =pod
226              
227             =encoding UTF-8
228              
229             =head1 NAME
230              
231             Test::DNS - Test DNS queries and zone configuration
232              
233             =head1 VERSION
234              
235             version 0.203
236              
237             =head1 SYNOPSIS
238              
239             This module helps you write tests for DNS queries. You could test your domain
240             configuration in the world or on a specific DNS server, for example.
241              
242             use Test::DNS;
243             use Test::More tests => 4;
244              
245             my $dns = Test::DNS->new();
246              
247             $dns->is_ptr( '1.2.3.4' => 'single.ptr.record.com' );
248             $dns->is_ptr( '1.2.3.4' => [ 'one.ptr.record.com', 'two.ptr.record.com' ] );
249             $dns->is_ns( 'google.com' => [ map "ns$_.google.com", 1 .. 4 ] );
250             $dns->is_a( 'ns1.google.com' => '216.239.32.10' );
251              
252             ...
253              
254             =head1 DESCRIPTION
255              
256             Test::DNS allows you to run tests which translate as DNS queries. It's simple to
257             use and abstracts all the difficult query checks from you. It has a built-in
258             tests naming scheme so you don't have to name your tests (as shown in all
259             the examples) even though it supports the option.
260              
261             use Test::DNS;
262             use Test::More tests => 1;
263              
264             my $dns = Test::DNS->new( nameservers => [ 'my.dns.server' ] );
265             $dns->is_ptr( '1.1.1.1' => 'my_new.mail.server' );
266              
267             That was a complete test script that will fetch the PTR (if there is one), warns
268             if it's missing one (an option you can remove via the I<warnings> attribute) and
269             checks against the domain you gave. You could also give for each test an
270             arrayref of expected values. That's useful if you want to check multiple values.
271             For example:
272              
273             use Test::DNS;
274             use Test::More tests => 1;
275              
276             my $dns = Test::DNS->new();
277             $dns->is_ns( 'my.domain' => [ 'ns1.my.domain', 'ns2.my.domain' ] );
278             # or
279             $dns->is_ns( 'my.domain' => [ map "ns$_.my.domain", 1 .. 5 ] );
280              
281             You can set the I<follow_cname> option if your PTR returns a CNAME instead of an
282             A record and you want to test the A record instead of the CNAME. This happened
283             to me at least twice and fumbled my tests. I was expecting an A record, but got
284             a CNAME to an A record. This is obviously legal DNS practices, so using the
285             I<follow_cname> attribute listed below, the test went with flying colors. This
286             is a recursive CNAME to A record function so you could handle multiple CNAME
287             chaining if one has such an odd case.
288              
289             New in version 0.04 is the option to give a hashref as the testing values (not
290             including a test name as well), which makes things much easier to test if you
291             want to run multiple tests and don't want to write multiple lines. This helps
292             connect L<Test::DNS> with freshly-parsed data (YAML/JSON/XML/etc.).
293              
294             use Test::DNS;
295             use YAML 'LoadFile';
296             use Test::More tests => 2;
297              
298             my $dns = Test::DNS->new();
299             # running two DNS tests in one command!
300             $dns->is_ns( {
301             'first.domain' => [ map { "ns$_.first.domain" } 1 .. 4 ],
302             'second.domain' => [ map { "ns$_.second.domain" } 5, 6 ],
303             } );
304              
305             my $tests = LoadFile('tests.yaml');
306             $dns->is_a( $tests, delete $tests->{'name'} ); # $tests is a hashref
307              
308             =head1 EXPORT
309              
310             This module is completely Object Oriented, nothing is exported.
311              
312             =head1 ATTRIBUTES
313              
314             =head2 nameservers($arrayref)
315              
316             Same as in L<Net::DNS>. Sets the nameservers, accepts an arrayref.
317              
318             my $dns = Test::DNS->new(
319             'nameservers' => [ 'IP1', 'DOMAIN' ],
320             );
321              
322             =head2 warnings($boolean)
323              
324             Do you want to output warnings from the module (in valid TAP), such as when a
325             record doesn't a query result or incorrect types?
326              
327             This helps avoid common misconfigurations. You should probably keep it, but if
328             it bugs you, you can stop it using:
329              
330             my $dns = Test::DNS->new(
331             'warnings' => 0,
332             );
333              
334             Default: 1 (on).
335              
336             =head2 follow_cname($boolean)
337              
338             When fetching an A record of a domain, it may resolve to a CNAME instead of an A
339             record. That would result in a false-negative of sorts, in which you say "well,
340             yes, I meant the A record the CNAME record points to" but L<Test::DNS> doesn't
341             know that.
342              
343             If you want want Test::DNS to follow every CNAME recursively till it reaches the
344             actual A record and compare B<that> A record, use this option.
345              
346             my $dns = Test::DNS->new(
347             'follow_cname' => 1,
348             );
349              
350             Default: 0 (off).
351              
352             =head1 SUBROUTINES/METHODS
353              
354             =head2 is_a( $domain, $ips, [$test_name] )
355              
356             Check the A record resolving of domain or subdomain.
357              
358             C<$ip> can be an arrayref.
359              
360             C<$test_name> is not mandatory.
361              
362             $dns->is_a( 'domain' => 'IP' );
363              
364             $dns->is_a( 'domain', [ 'IP1', 'IP2' ] );
365              
366             Returns false if the assertion fails.
367              
368             =head2 is_ns( $domain, $ips, [$test_name] )
369              
370             Check the NS record resolving of a domain or subdomain.
371              
372             C<$ip> can be an arrayref.
373              
374             C<$test_name> is not mandatory.
375              
376             $dns->is_ns( 'domain' => 'IP' );
377              
378             $dns->is_ns( 'domain', [ 'IP1', 'IP2' ] );
379              
380             Returns false if the assertion fails.
381              
382             =head2 is_ptr( $ip, $domains, [$test_name] )
383              
384             Check the PTR records of an IP.
385              
386             C<$domains> can be an arrayref.
387              
388             C<$test_name> is not mandatory.
389              
390             $dns->is_ptr( 'IP' => 'ptr.records.domain' );
391              
392             $dns->is_ptr( 'IP', [ 'first.ptr.domain', 'second.ptr.domain' ] );
393              
394             Returns false if the assertion fails.
395              
396             =head2 is_mx( $domain, $domains, [$test_name] )
397              
398             Check the MX records of a domain.
399              
400             C<$domains> can be an arrayref.
401              
402             C<$test_name> is not mandatory.
403              
404             $dns->is_mx( 'domain' => 'mailer.domain' );
405              
406             $dns->is_ptr( 'domain', [ 'mailer1.domain', 'mailer2.domain' ] );
407              
408             Returns false if the assertion fails.
409              
410             =head2 is_cname( $domain, $domains, [$test_name] )
411              
412             Check the CNAME records of a domain.
413              
414             C<$domains> can be an arrayref.
415              
416             C<$test_name> is not mandatory.
417              
418             $dns->is_cname( 'domain' => 'sub.domain' );
419              
420             $dns->is_cname( 'domain', [ 'sub1.domain', 'sub2.domain' ] );
421              
422             Returns false if the assertion fails.
423              
424             =head2 is_txt( $domain, $txt, [$test_name] )
425              
426             Check the TXT records of a domain.
427              
428             C<$txt> can be an arrayref.
429              
430             C<$test_name> is not mandatory.
431              
432             $dns->is_txt( 'domain' => 'v=spf1 -all' );
433              
434             $dns->is_txt( 'domain', [ 'sub1.domain', 'sub2.domain' ] );
435              
436             Returns false if the assertion fails.
437              
438             =head2 is_record( $type, $input, $expected, [$test_name] )
439              
440             The general function all the other is_* functions run.
441              
442             C<$type> is the record type (CNAME, A, NS, PTR, MX, etc.).
443              
444             C<$input> is the domain or IP you're testing.
445              
446             C<$expected> can be an arrayref.
447              
448             C<$test_name> is not mandatory.
449              
450             $dns->is_record( 'CNAME', 'domain', 'sub.domain', 'test_name' );
451              
452             Returns false if the assertion fails.
453              
454             =head2 BUILD
455              
456             L<Moose> builder method. Do not call it or override it. :)
457              
458             =head1 HASH FORMAT
459              
460             The hash format option (since version 0.04) allows you to run the tests using a
461             single hashref with an optional parameter for the test_name. The count is no
462             longer 1 (as it is with single tests), but each key/value pair represents a test
463             case.
464              
465             # these are 2 tests
466             $dns->is_ns( {
467             'first.domain' => [ map { "ns$_.first.domain" } 1 .. 4 ],
468             'second.domain' => [ map { "ns$_.second.domain" } 5, 6 ],
469             } );
470              
471             # number of tests: keys %{$tests}, test name: $tests->{'name'}
472             $dns->is_a( $tests, delete $tests->{'name'} ); # $tests is a hashref
473              
474             =head1 DEPENDENCIES
475              
476             L<Moose>
477              
478             L<Net::DNS>
479              
480             L<Test::Deep>
481              
482             =head1 AUTHOR
483              
484             Sawyer X, C<< <xsawyerx at cpan.org> >>
485              
486             =head1 BUGS
487              
488             Please report any bugs or feature requests to C<bug-test-dns at rt.cpan.org>, or
489             through the web interface at
490             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-DNS>. I will be notified,
491             and then you'll automatically be notified of progress on your bug as I make
492             changes.
493              
494             =head1 SUPPORT
495              
496             You can find documentation for this module with the perldoc command.
497              
498             perldoc Test::DNS
499              
500             You can also look for information at:
501              
502             =over 4
503              
504             =item * Github
505              
506             L<http://github.com/xsawyerx/test-dns>
507              
508             =item * RT: CPAN's request tracker
509              
510             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-DNS>
511              
512             =item * AnnoCPAN: Annotated CPAN documentation
513              
514             L<http://annocpan.org/dist/Test-DNS>
515              
516             =item * CPAN Ratings
517              
518             L<http://cpanratings.perl.org/d/Test-DNS>
519              
520             =item * Search CPAN
521              
522             L<http://search.cpan.org/dist/Test-DNS/>
523              
524             =back
525              
526             =head1 ACKNOWLEDGEMENTS
527              
528             =head1 LICENSE AND COPYRIGHT
529              
530             Copyright 2019 Sawyer X.
531              
532             This program is free software; you can redistribute it and/or modify it
533             under the terms of either: the GNU General Public License as published
534             by the Free Software Foundation; or the Artistic License.
535              
536             See http://dev.perl.org/licenses/ for more information.
537              
538             =head1 AUTHOR
539              
540             Sawyer X <xsawyerx@cpan.org>
541              
542             =head1 COPYRIGHT AND LICENSE
543              
544             This software is Copyright (c) 2019 by Sawyer X.
545              
546             This is free software, licensed under:
547              
548             The MIT (X11) License
549              
550             =cut