File Coverage

blib/lib/Mail/DKIM/DNS.pm
Criterion Covered Total %
statement 61 80 76.2
branch 18 34 52.9
condition 4 6 66.6
subroutine 7 11 63.6
pod 2 4 50.0
total 92 135 68.1


line stmt bran cond sub pod time code
1             package Mail::DKIM::DNS;
2 15     15   118 use strict;
  15         31  
  15         441  
3 15     15   75 use warnings;
  15         36  
  15         632  
4             our $VERSION = '1.20230630'; # 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   7588 use Net::DNS;
  15         1240840  
  15         15040  
16             our $TIMEOUT = 10;
17             our $RESOLVER;
18              
19             sub resolver {
20 187 50   187 1 2976 if (@_) {
21 187         479 $RESOLVER = $_[0];
22             }
23 187         294 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 303     303 0 746 my ( $domain, $type ) = @_;
50              
51 303 100       658 if ( !$RESOLVER ) {
52 1 50       21 $RESOLVER = Net::DNS::Resolver->new()
53             or die "Internal error: can't create DNS resolver";
54             }
55              
56 303         1169 my $rslv = $RESOLVER;
57              
58             #
59             # perform the DNS query
60             # if the query takes too long, we should generate an error
61             #
62 303         457 my $resp;
63 303         2266 my $remaining_time = alarm(0); # check time left, stop the timer
64 303         849 my $deadline = time + $remaining_time;
65 303         433 my $E;
66             eval {
67 303         1198 local $SIG{__DIE__};
68              
69             # set a timeout, 10 seconds by default
70 303     0   5192 local $SIG{ALRM} = sub { die "DNS query timeout for $domain\n" };
  0         0  
71 303         1874 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 303         612 my $E2;
77             eval {
78 303         1158 local $SIG{__DIE__};
79 303         1242 $resp = $rslv->send( $domain, $type );
80 303         536456 1;
81 303 50       469 } or do {
82 0         0 $E2 = $@;
83             };
84 303         1957 alarm 0;
85 303 50       1283 if ($E2) { chomp $E2; die "$E2\n" } # no line number here
  0         0  
  0         0  
86 303         5170 1;
87 303 50       454 } or do {
88 0         0 $E = $@; # the $@ only makes sense if eval returns a false
89             };
90 303         1474 alarm 0;
91              
92             # restart the timer if it was active
93 303 50       843 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 303 50       539 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 303 50       661 if ($resp) {
111 303         1100 my $header = $resp->header;
112 303 50       1988 if ($header) {
113              
114             # NOERROR, NXDOMAIN, SERVFAIL, FORMERR, REFUSED, ...
115 303         899 my $rcode = $header->rcode;
116              
117 303         40470 $@ = $rcode;
118 303 100       715 if ( $rcode eq 'NOERROR' ) {
    50          
119              
120             # may or may not contain RRs in the answer sect
121 301         723 my @result = grep { lc $_->type eq lc $type } $resp->answer;
  298         2339  
122 301 100       3983 $@ = 'NODATA' if !@result;
123 301         1985 return @result; # possibly empty
124             }
125             elsif ( $rcode eq 'NXDOMAIN' ) {
126 2         49 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 424     424 0 1095 my ( $domain, $type, %prms ) = @_;
151              
152 424   50     976 my $callbacks = $prms{Callbacks} || {};
153 424   50 0   857 my $on_success = $callbacks->{Success} || sub { $_[0] };
  0            
154 424   100 0   887 my $on_error = $callbacks->{Error} || sub { die $_[0] };
  0            
155              
156             my $waiter = sub {
157 372     372   654 my @resp;
158             my $rcode;
159             eval {
160 372         1326 local $SIG{__DIE__};
161 372         991 @resp = query( $domain, $type );
162 369         2867 $rcode = $@;
163 369         1308 1;
164 372 100       616 } or do {
165 3         276 return $on_error->($@);
166             };
167 369         627 $@ = $rcode;
168 369         1023 return $on_success->(@resp);
169 424         1447 };
170 424         1215 return $waiter;
171             }
172              
173             1;
174              
175             __END__