File Coverage

blib/lib/Acme/DNS/Correct.pm
Criterion Covered Total %
statement 26 30 86.6
branch 6 8 75.0
condition 3 7 42.8
subroutine 7 7 100.0
pod 2 2 100.0
total 44 54 81.4


line stmt bran cond sub pod time code
1             package Acme::DNS::Correct;
2             #
3             # $Id: Correct.pm,v 1.6 2003/09/28 04:05:42 ctriv Exp $
4             #
5 2     2   94630 use strict;
  2         5  
  2         111  
6 2     2   10 use vars qw($VERSION @ISA $ROOT_OF_EVIL $BE_SNEAKY);
  2         4  
  2         163  
7 2     2   1936 use Net::DNS;
  2         299122  
  2         1147  
8              
9             $VERSION = 0.4;
10             @ISA = qw(Net::DNS::Resolver);
11              
12             $ROOT_OF_EVIL ||= $ENV{'ROOT_OF_EVIL'} || '64.94.110.11';
13              
14             sub import {
15 3     3   989 my ($class, @args) = @_;
16            
17 3         19 for (@args) {
18 2 50       10 if ($_ eq 'sneaky') {
19 2         21 $BE_SNEAKY++;
20             }
21             }
22             }
23              
24             sub send {
25 6     6 1 3749 my $self = shift;
26 6   50     28 my $ans = $self->SUPER::send(@_) || return;
27            
28 6         27 _remove_evil($ans);
29            
30 6         46 return $ans
31             }
32              
33              
34             sub _remove_evil {
35 17     17   38 my ($packet) = @_;
36            
37 17         82 my @ans = $packet->answer;
38            
39 17 100       163 if (@ans == 1) {
40 3         7 my $rr = $ans[0];
41            
42 3 50 33     21 if ($rr->type eq 'A' and $rr->address eq $ROOT_OF_EVIL) {
43 0         0 $packet->pop('answer') while $packet->answer;
44 0         0 $packet->pop('authority') while $packet->authority;
45 0         0 $packet->pop('additional') while $packet->additional;
46            
47 0         0 $packet->header->rcode('NXDOMAIN');
48             }
49             }
50             }
51            
52              
53             package Net::DNS::Resolver;
54              
55             sub send {
56 22     22 1 21290 my $self = shift;
57 22   50     129 my $ans = $self->SUPER::send(@_) || return;
58            
59 22 100       1977650 Acme::DNS::Correct::_remove_evil($ans) if $Acme::DNS::Correct::BE_SNEAKY;
60            
61 22         158 return $ans
62             }
63            
64            
65            
66              
67             =head1 NAME
68              
69             Acme::DNS::Correct - Fix the DNS System
70              
71             =head1 DESCRIPTION
72              
73             Acme::DNS::Correct is a subclass of L,
74             adding functionality that returns sanity to the DNS system. Consult the
75             Net::DNS manpages for comprehensive documentation on using this module.
76              
77             =head1 SYNOPSIS
78              
79             my $res = Acme::DNS::Correct->new;
80            
81             # use $res just like a Net::DNS::Resolver object, but the answers it
82             # returns will make sense, and be correct.
83            
84             # Give Net::DNS::Resolver objects sanity:
85             use Acme::DNS::Correct 'sneaky';
86            
87             # $res now gives sane answers
88             my $res = Net::DNS::Resolver->new;
89            
90              
91             =head1 CONFIGURATION
92              
93             This module strips out answers of C<64.94.110.11>, a place of evil that you
94             should keep far far away from your poor defenseless computer.
95              
96             If you would rather avoid another root of evil, set the C
97             envirement variable, or the C<$Acme::DNS::Correct::ROOT_OF_EVIL> variable.
98              
99             =head1 TODO
100              
101             Check that the root of evil is really an IP address.
102              
103             Allow for more than one root of evil.
104              
105             Zone transfers are not safe from evil.
106              
107             =head1 AUTHOR
108              
109             Chris Reinhardt Ectriv@dyndns.orgE
110              
111             =head1 COPYRIGHT
112              
113             Copyright (c) 2003 Chris Reinhardt Ectriv@dyndns.orgE. All rights
114             reserved. This program is free software; you can redistribute it and/or
115             modify it under the same terms as Perl itself.
116              
117             =head1 SEE ALSO
118              
119             L
120              
121             =cut
122            
123            
124             1;
125             __END__