File Coverage

blib/lib/Mail/DKIM/DNS.pm
Criterion Covered Total %
statement 60 80 75.0
branch 16 34 47.0
condition 4 6 66.6
subroutine 7 11 63.6
pod 2 4 50.0
total 89 135 65.9


line stmt bran cond sub pod time code
1             package Mail::DKIM::DNS;
2 15     15   151 use strict;
  15         30  
  15         448  
3 15     15   84 use warnings;
  15         29  
  15         674  
4             our $VERSION = '1.20230212'; # VERSION
5             # ABSTRACT: performs DNS queries for Mail::DKIM
6              
7             # Copyright 2007, 2012 Messiah College. All rights reserved.
8             # Jason Long
9              
10              
11             # This class contains a method to perform synchronous DNS queries.
12             # Hopefully some day it will have a method to perform
13             # asynchronous DNS queries.
14              
15 15     15   7926 use Net::DNS;
  15         1221061  
  15         15838  
16             our $TIMEOUT = 10;
17             our $RESOLVER;
18              
19             sub resolver {
20 187 50   187 1 2812 if (@_) {
21 187         478 $RESOLVER = $_[0];
22             }
23 187         345 return $RESOLVER;
24             }
25              
26             sub enable_EDNS0 {
27              
28             # enable EDNS0, set acceptable UDP packet size to a
29             # conservative payload size that should fit into a single
30             # packet (MTU less the IP header size) in most cases;
31             # See also draft-andrews-dnsext-udp-fragmentation
32             # and RFC 3542 section 11.3.
33              
34 0     0 1 0 my $res = Net::DNS::Resolver->new();
35 0         0 $res->udppacketsize( 1280 - 40 );
36 0         0 resolver($res);
37             }
38              
39             # query- returns a list of RR objects
40             # or an empty list if the domain record does not exist
41             # (e.g. in the case of NXDOMAIN or NODATA)
42             # or throws an error on a DNS query time-out or other transient error
43             # (e.g. SERVFAIL)
44             #
45             # if an empty list is returned, $@ is also set to a string explaining
46             # why no records were returned (e.g. "NXDOMAIN").
47             #
48             sub query {
49 302     302 0 596 my ( $domain, $type ) = @_;
50              
51 302 50       687 if ( !$RESOLVER ) {
52 0 0       0 $RESOLVER = Net::DNS::Resolver->new()
53             or die "Internal error: can't create DNS resolver";
54             }
55              
56 302         393 my $rslv = $RESOLVER;
57              
58             #
59             # perform the DNS query
60             # if the query takes too long, we should generate an error
61             #
62 302         421 my $resp;
63 302         2174 my $remaining_time = alarm(0); # check time left, stop the timer
64 302         697 my $deadline = time + $remaining_time;
65 302         397 my $E;
66             eval {
67 302         1069 local $SIG{__DIE__};
68              
69             # set a timeout, 10 seconds by default
70 302     0   5079 local $SIG{ALRM} = sub { die "DNS query timeout for $domain\n" };
  0         0  
71 302         1909 alarm $TIMEOUT;
72              
73             # the query itself could cause an exception, which would prevent
74             # us from resetting the alarm before leaving the eval {} block
75             # so we wrap the query in a nested eval {} block
76 302         575 my $E2;
77             eval {
78 302         1135 local $SIG{__DIE__};
79 302         1283 $resp = $rslv->send( $domain, $type );
80 302         223285 1;
81 302 50       496 } or do {
82 0         0 $E2 = $@;
83             };
84 302         2076 alarm 0;
85 302 50       875 if ($E2) { chomp $E2; die "$E2\n" } # no line number here
  0         0  
  0         0  
86 302         4898 1;
87 302 50       432 } or do {
88 0         0 $E = $@; # the $@ only makes sense if eval returns a false
89             };
90 302         1529 alarm 0;
91              
92             # restart the timer if it was active
93 302 50       819 if ( $remaining_time > 0 ) {
94 0         0 my $dt = $deadline - time;
95              
96             # make sure the timer expiration will trigger a signal,
97             # even at the expense of stretching the interval by one second
98 0 0       0 alarm( $dt < 1 ? 1 : $dt );
99             }
100 302 50       562 if ($E) { chomp $E; die $E } # ensure a line number
  0         0  
  0         0  
101              
102             # RFC 2308: NODATA is indicated by an answer with the RCODE set to NOERROR
103             # and no relevant answers in the answer section. The authority section
104             # will contain an SOA record, or there will be no NS records there.
105             # NODATA responses have to be algorithmically determined from the
106             # response's contents as there is no RCODE value to indicate NODATA.
107             # In some cases to determine with certainty that NODATA is the correct
108             # response it can be necessary to send another query.
109              
110 302 50       644 if ($resp) {
111 302         1062 my $header = $resp->header;
112 302 50       2029 if ($header) {
113              
114             # NOERROR, NXDOMAIN, SERVFAIL, FORMERR, REFUSED, ...
115 302         866 my $rcode = $header->rcode;
116              
117 302         37316 $@ = $rcode;
118 302 100       725 if ( $rcode eq 'NOERROR' ) {
    50          
119              
120             # may or may not contain RRs in the answer sect
121 301         776 my @result = grep { lc $_->type eq lc $type } $resp->answer;
  298         2282  
122 301 100       3682 $@ = 'NODATA' if !@result;
123 301         2102 return @result; # possibly empty
124             }
125             elsif ( $rcode eq 'NXDOMAIN' ) {
126 1         18 return; # empty list, rcode in $@
127             }
128             }
129             }
130 0 0       0 if ( $rslv->errorstring eq 'NOERROR' ) {
131 0         0 return;
132             }
133 0 0       0 if ( $rslv->errorstring =~ /\bno error\b/ ) {
134 0         0 return;
135             }
136 0         0 die 'DNS error: ' . $rslv->errorstring . "\n";
137             }
138              
139             # query_async() - perform a DNS query asynchronously
140             #
141             # my $waiter = query_async('example.org', 'TXT',
142             # Callbacks => {
143             # Success => \&on_success,
144             # Error => \&on_error,
145             # },
146             # );
147             # my $result = $waiter->();
148             #
149             sub query_async {
150 418     418 0 1153 my ( $domain, $type, %prms ) = @_;
151              
152 418   50     932 my $callbacks = $prms{Callbacks} || {};
153 418   50 0   845 my $on_success = $callbacks->{Success} || sub { $_[0] };
  0            
154 418   100 0   833 my $on_error = $callbacks->{Error} || sub { die $_[0] };
  0            
155              
156             my $waiter = sub {
157 366     366   593 my @resp;
158             my $rcode;
159             eval {
160 366         1315 local $SIG{__DIE__};
161 366         996 @resp = query( $domain, $type );
162 364         2689 $rcode = $@;
163 364         1299 1;
164 366 100       584 } or do {
165 2         40 return $on_error->($@);
166             };
167 364         682 $@ = $rcode;
168 364         1057 return $on_success->(@resp);
169 418         1535 };
170 418         1213 return $waiter;
171             }
172              
173             1;
174              
175             __END__