File Coverage

blib/lib/Mail/SpamAssassin/Dns.pm
Criterion Covered Total %
statement 136 343 39.6
branch 27 150 18.0
condition 7 50 14.0
subroutine 27 42 64.2
pod 0 26 0.0
total 197 611 32.2


line stmt bran cond sub pod time code
1             # <@LICENSE>
2             # Licensed to the Apache Software Foundation (ASF) under one or more
3             # contributor license agreements. See the NOTICE file distributed with
4             # this work for additional information regarding copyright ownership.
5             # The ASF licenses this file to you under the Apache License, Version 2.0
6             # (the "License"); you may not use this file except in compliance with
7             # the License. You may obtain a copy of the License at:
8             #
9             # http://www.apache.org/licenses/LICENSE-2.0
10             #
11             # Unless required by applicable law or agreed to in writing, software
12             # distributed under the License is distributed on an "AS IS" BASIS,
13             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14             # See the License for the specific language governing permissions and
15             # limitations under the License.
16             # </@LICENSE>
17              
18 40     40   257 use strict; # make Test::Perl::Critic happy
  40         95  
  40         1941  
19             package Mail::SpamAssassin::Dns; 1;
20              
21             package Mail::SpamAssassin::PerMsgStatus;
22              
23 40     40   237 use strict;
  40         83  
  40         896  
24 40     40   244 use warnings;
  40         84  
  40         1386  
25             # use bytes;
26 40     40   269 use re 'taint';
  40         73  
  40         1325  
27              
28 40     40   243 use Mail::SpamAssassin::Conf;
  40         78  
  40         1008  
29 40     40   244 use Mail::SpamAssassin::PerMsgStatus;
  40         98  
  40         949  
30 40     40   259 use Mail::SpamAssassin::AsyncLoop;
  40         76  
  40         1176  
31 40     40   229 use Mail::SpamAssassin::Constants qw(:ip);
  40         87  
  40         4704  
32 40     40   299 use Mail::SpamAssassin::Util qw(untaint_var am_running_on_windows);
  40         77  
  40         2213  
33              
34 40     40   276 use File::Spec;
  40         88  
  40         1110  
35 40     40   3482 use IO::Socket;
  40         52227  
  40         440  
36 40     40   25589 use POSIX ":sys_wait_h";
  40         84  
  40         369  
37              
38              
39             our $KNOWN_BAD_DIALUP_RANGES; # Nothing uses this var???
40             our $LAST_DNS_CHECK;
41              
42             # use very well-connected domains (fast DNS response, many DNS servers,
43             # geographical distribution is a plus, TTL of at least 3600s)
44             our @EXISTING_DOMAINS = qw{
45             adelphia.net
46             akamai.com
47             apache.org
48             cingular.com
49             colorado.edu
50             comcast.net
51             doubleclick.com
52             ebay.com
53             gmx.net
54             google.com
55             intel.com
56             kernel.org
57             linux.org
58             mit.edu
59             motorola.com
60             msn.com
61             sourceforge.net
62             sun.com
63             w3.org
64             yahoo.com
65             };
66              
67             our $IS_DNS_AVAILABLE = undef;
68              
69             #Removed $VERSION per BUG 6422
70             #$VERSION = 'bogus'; # avoid CPAN.pm picking up razor ver
71              
72             ###########################################################################
73              
74             BEGIN {
75             # some trickery. Load these modules right here, if possible; that way, if
76             # the module exists, we'll get it loaded now. Very useful to avoid attempted
77             # loads later (which will happen). If we do a fork(), we could wind up
78             # attempting to load these modules in *every* subprocess.
79             #
80             # # We turn off strict and warnings, because Net::DNS and Razor both contain
81             # # crud that -w complains about (perl 5.6.0). Not that this seems to work,
82             # # mind ;)
83             # no strict;
84             # local ($^W) = 0;
85              
86 40     40   9255 no warnings;
  40         98  
  40         3280  
87 40     40   129 eval {
88 40         20827 require Net::DNS;
89 40         2033411 require Net::DNS::Resolver;
90             };
91 40         419 eval {
92 40         472 require MIME::Base64;
93             };
94 40         328 eval {
95 40         182204 require IO::Socket::UNIX;
96             };
97             };
98              
99             ###########################################################################
100              
101             sub do_rbl_lookup {
102 0     0 0 0 my ($self, $rule, $set, $type, $host, $subtest) = @_;
103              
104 0         0 $host =~ s/\.\z//s; # strip a redundant trailing dot
105 0         0 my $key = "dns:$type:$host";
106 0         0 my $existing_ent = $self->{async}->get_lookup($key);
107              
108             # only make a specific query once
109 0 0       0 if (!$existing_ent) {
110 0         0 my $ent = {
111             key => $key,
112             zone => $host, # serves to fetch other per-zone settings
113             type => "DNSBL-".$type,
114             sets => [ ], # filled in below
115             rules => [ ], # filled in below
116             # id is filled in after we send the query below
117             };
118             $existing_ent = $self->{async}->bgsend_and_start_lookup(
119             $host, $type, undef, $ent,
120 0     0   0 sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) },
  0         0  
121 0         0 master_deadline => $self->{master_deadline} );
122             }
123              
124 0 0       0 if ($existing_ent) {
125             # always add set
126 0         0 push @{$existing_ent->{sets}}, $set;
  0         0  
127              
128             # sometimes match or always match
129 0 0       0 if (defined $subtest) {
130 0         0 $self->{dnspost}->{$set}->{$subtest} = $rule;
131             } else {
132 0         0 push @{$existing_ent->{rules}}, $rule;
  0         0  
133             }
134              
135 0         0 $self->{rule_to_rblkey}->{$rule} = $key;
136             }
137             }
138              
139             # TODO: these are constant so they should only be added once at startup
140             sub register_rbl_subtest {
141 0     0 0 0 my ($self, $rule, $set, $subtest) = @_;
142              
143 0 0       0 if ($subtest =~ /^sb:/) {
144 0         0 warn("dns: ignored $rule, SenderBase rules are deprecated\n");
145 0         0 return 0;
146             }
147              
148 0         0 $self->{dnspost}->{$set}->{$subtest} = $rule;
149             }
150              
151             sub do_dns_lookup {
152 0     0 0 0 my ($self, $rule, $type, $host) = @_;
153              
154 0         0 $host =~ s/\.\z//s; # strip a redundant trailing dot
155 0         0 my $key = "dns:$type:$host";
156              
157 0         0 my $ent = {
158             key => $key,
159             zone => $host, # serves to fetch other per-zone settings
160             type => "DNSBL-".$type,
161             rules => [ $rule ],
162             # id is filled in after we send the query below
163             };
164             $ent = $self->{async}->bgsend_and_start_lookup(
165             $host, $type, undef, $ent,
166 0     0   0 sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) },
  0         0  
167 0         0 master_deadline => $self->{master_deadline} );
168 0         0 $ent;
169             }
170              
171             ###########################################################################
172              
173             sub dnsbl_hit {
174 0     0 0 0 my ($self, $rule, $question, $answer) = @_;
175              
176 0         0 my $log = "";
177 0 0       0 if (substr($rule, 0, 2) eq "__") {
    0          
178             # don't bother with meta rules
179             } elsif ($answer->type eq 'TXT') {
180             # txtdata returns a non- zone-file-format encoded result, unlike rdstring;
181             # avoid space-separated RDATA <character-string> fields if possible,
182             # txtdata provides a list of strings in a list context since Net::DNS 0.69
183 0         0 $log = join('',$answer->txtdata);
184 0         0 local $1;
185 0         0 $log =~ s{ (?<! [<(\[] ) (https? : // \S+)}{<$1>}xgi;
186             } else { # assuming $answer->type eq 'A'
187 0         0 local($1,$2,$3,$4,$5);
188 0 0       0 if ($question->string =~ m/^((?:[0-9a-fA-F]\.){32})(\S+\w)/) {
    0          
189 0         0 $log = ' listed in ' . lc($2);
190 0         0 my $ipv6addr = join('', reverse split(/\./, lc $1));
191 0         0 $ipv6addr =~ s/\G(....)/$1:/g; chop $ipv6addr;
  0         0  
192 0         0 $ipv6addr =~ s/:0{1,3}/:/g;
193 0         0 $log = $ipv6addr . $log;
194             } elsif ($question->string =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)\.(\S+\w)/) {
195 0         0 $log = "$4.$3.$2.$1 listed in " . lc($5);
196             } else {
197 0         0 $log = 'listed in ' . $question->string;
198             }
199             }
200              
201             # TODO: this may result in some log messages appearing under the
202             # wrong rules, since we could see this sequence: { test one hits,
203             # test one's message is logged, test two hits, test one fires again
204             # on another IP, test one's message is logged for that other IP --
205             # but under test two's heading }. Right now though it's better
206             # than just not logging at all.
207              
208 0   0     0 $self->{already_logged} ||= { };
209 0 0 0     0 if ($log && !$self->{already_logged}->{$log}) {
210 0         0 $self->test_log($log);
211 0         0 $self->{already_logged}->{$log} = 1;
212             }
213              
214 0 0       0 if (!$self->{tests_already_hit}->{$rule}) {
215 0         0 $self->got_hit($rule, "RBL: ", ruletype => "dnsbl");
216             }
217             }
218              
219             sub dnsbl_uri {
220 0     0 0 0 my ($self, $question, $answer) = @_;
221              
222 0         0 my $qname = $question->qname;
223              
224             # txtdata returns a non- zone-file-format encoded result, unlike rdstring;
225             # avoid space-separated RDATA <character-string> fields if possible,
226             # txtdata provides a list of strings in a list context since Net::DNS 0.69
227             #
228             # rdatastr() is historical/undocumented, use rdstring() since Net::DNS 0.69
229 0 0       0 my $rdatastr = $answer->UNIVERSAL::can('txtdata') ? join('',$answer->txtdata)
    0          
230             : $answer->UNIVERSAL::can('rdstring') ? $answer->rdstring
231             : $answer->rdatastr;
232 0 0 0     0 if (defined $qname && defined $rdatastr) {
233 0         0 my $qclass = $question->qclass;
234 0         0 my $qtype = $question->qtype;
235 0         0 my @vals;
236 0 0       0 push(@vals, "class=$qclass") if $qclass ne "IN";
237 0 0       0 push(@vals, "type=$qtype") if $qtype ne "A";
238 0 0       0 my $uri = "dns:$qname" . (@vals ? "?" . join(";", @vals) : "");
239 0         0 push @{ $self->{dnsuri}->{$uri} }, $rdatastr;
  0         0  
240              
241 0         0 dbg("dns: hit <$uri> $rdatastr");
242             }
243             }
244              
245             # called as a completion routine to bgsend by DnsResolver::poll_responses;
246             # returns 1 on successful packet processing
247             sub process_dnsbl_result {
248 0     0 0 0 my ($self, $ent, $pkt) = @_;
249              
250 0 0       0 return if !$pkt;
251 0         0 my $question = ($pkt->question)[0];
252 0 0       0 return if !$question;
253              
254 0   0     0 my $sets = $ent->{sets} || [];
255 0         0 my $rules = $ent->{rules};
256              
257             # NO_DNS_FOR_FROM
258 0 0 0     0 if ($self->{sender_host} &&
      0        
      0        
      0        
259             # fishy, qname should have been "RFC 1035 zone format" -decoded first
260             lc($question->qname) eq lc($self->{sender_host}) &&
261             $question->qtype =~ /^(?:A|MX)$/ &&
262             $pkt->header->rcode =~ /^(?:NXDOMAIN|SERVFAIL)$/ &&
263             ++$self->{sender_host_fail} == 2)
264             {
265 0         0 for my $rule (@{$rules}) {
  0         0  
266 0         0 $self->got_hit($rule, "DNS: ", ruletype => "dns");
267             }
268             }
269              
270             # DNSBL tests are here
271 0         0 foreach my $answer ($pkt->answer) {
272 0 0       0 next if !$answer;
273             # track all responses
274 0         0 $self->dnsbl_uri($question, $answer);
275 0         0 my $answ_type = $answer->type;
276             # TODO: there are some CNAME returns that might be useful
277 0 0 0     0 next if ($answ_type ne 'A' && $answ_type ne 'TXT');
278 0 0       0 if ($answ_type eq 'A') {
279             # Net::DNS::RR::A::address() is available since Net::DNS 0.69
280 0 0       0 my $ip_address = $answer->UNIVERSAL::can('address') ? $answer->address
281             : $answer->rdatastr;
282             # skip any A record that isn't on 127.0.0.0/8
283 0 0       0 next if $ip_address !~ /^127\./;
284             }
285 0         0 for my $rule (@{$rules}) {
  0         0  
286 0         0 $self->dnsbl_hit($rule, $question, $answer);
287             }
288 0         0 for my $set (@{$sets}) {
  0         0  
289 0 0       0 if ($self->{dnspost}->{$set}) {
290 0         0 $self->process_dnsbl_set($set, $question, $answer);
291             }
292             }
293             }
294 0         0 return 1;
295             }
296              
297             sub process_dnsbl_set {
298 0     0 0 0 my ($self, $set, $question, $answer) = @_;
299              
300             # txtdata returns a non- zone-file-format encoded result, unlike rdstring;
301             # avoid space-separated RDATA <character-string> fields if possible,
302             # txtdata provides a list of strings in a list context since Net::DNS 0.69
303             #
304             # rdatastr() is historical/undocumented, use rdstring() since Net::DNS 0.69
305 0 0       0 my $rdatastr = $answer->UNIVERSAL::can('txtdata') ? join('',$answer->txtdata)
    0          
306             : $answer->UNIVERSAL::can('rdstring') ? $answer->rdstring
307             : $answer->rdatastr;
308              
309 0         0 while (my ($subtest, $rule) = each %{ $self->{dnspost}->{$set} }) {
  0         0  
310 0 0       0 next if $self->{tests_already_hit}->{$rule};
311              
312 0 0       0 if ($subtest =~ /^\d+\.\d+\.\d+\.\d+$/) {
    0          
313             # test for exact equality, not a regexp (an IPv4 address)
314 0 0       0 $self->dnsbl_hit($rule, $question, $answer) if $subtest eq $rdatastr;
315             }
316             # bitmask
317             elsif ($subtest =~ /^\d+$/) {
318             # Bug 6803: response should be within 127.0.0.0/8, ignore otherwise
319 0 0 0     0 if ($rdatastr =~ m/^127\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ &&
320             Mail::SpamAssassin::Util::my_inet_aton($rdatastr) & $subtest)
321             {
322 0         0 $self->dnsbl_hit($rule, $question, $answer);
323             }
324             }
325             # regular expression
326             else {
327 0         0 my $test = qr/$subtest/;
328 0 0       0 if ($rdatastr =~ /$test/) {
329 0         0 $self->dnsbl_hit($rule, $question, $answer);
330             }
331             }
332             }
333             }
334              
335             sub harvest_until_rule_completes {
336 0     0 0 0 my ($self, $rule) = @_;
337              
338 0         0 dbg("dns: harvest_until_rule_completes");
339 0         0 my $result = 0;
340              
341 0         0 for (my $first=1; ; $first=0) {
342             # complete_lookups() may call completed_callback(), which may
343             # call start_lookup() again (like in Plugin::URIDNSBL)
344             my ($alldone,$anydone) =
345 0 0       0 $self->{async}->complete_lookups($first ? 0 : 1.0, 1);
346              
347 0 0       0 $result = 1 if $self->is_rule_complete($rule);
348 0 0 0     0 last if $result || $alldone;
349              
350 0         0 dbg("dns: harvest_until_rule_completes - check_tick");
351 0         0 $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
352             }
353              
354 0         0 return $result;
355             }
356              
357             sub harvest_dnsbl_queries {
358 96     96 0 298 my ($self) = @_;
359              
360 96         328 dbg("dns: harvest_dnsbl_queries");
361              
362 96         246 for (my $first=1; ; $first=0) {
363             # complete_lookups() may call completed_callback(), which may
364             # call start_lookup() again (like in Plugin::URIDNSBL)
365              
366             # the first time around we specify a 0 timeout, which gives
367             # complete_lookups a chance to ripe any available results and
368             # abort overdue requests, without needlessly waiting for more
369              
370             my ($alldone,$anydone) =
371 96 50       493 $self->{async}->complete_lookups($first ? 0 : 1.0, 1);
372              
373 96 50       468 last if $alldone;
374              
375 0         0 dbg("dns: harvest_dnsbl_queries - check_tick");
376 0         0 $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
377             }
378              
379             # explicitly abort anything left
380 96         586 $self->{async}->abort_remaining_lookups();
381 96         512 $self->{async}->log_lookups_timing();
382 96         542 $self->mark_all_async_rules_complete();
383 96         247 1;
384             }
385              
386             # collect and process whatever DNS responses have already arrived,
387             # don't waste time waiting for more, don't poll too often.
388             # don't abort any queries even if overdue,
389             sub harvest_completed_queries {
390 3096     3096 0 5575 my ($self) = @_;
391              
392             # don't bother collecting responses too often
393 3096         8677 my $last_poll_time = $self->{async}->last_poll_responses_time();
394 3096 100 66     7270 return if defined $last_poll_time && time - $last_poll_time < 0.1;
395              
396 3063         7025 my ($alldone,$anydone) = $self->{async}->complete_lookups(0, 0);
397 3063 100       7862 if ($anydone) {
398 3         10 dbg("dns: harvested completed queries");
399             # $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
400             }
401             }
402              
403             sub set_rbl_tag_data {
404 96     96 0 242 my ($self) = @_;
405              
406             # DNS URIs
407 96         273 my $rbl_tag = $self->{tag_data}->{RBL}; # just in case, should be empty
408 96 50       283 $rbl_tag = '' if !defined $rbl_tag;
409 96         220 while (my ($dnsuri, $answers) = each %{ $self->{dnsuri} }) {
  96         615  
410             # when parsing, look for elements of \".*?\" or \S+ with ", " as separator
411 0         0 $rbl_tag .= "<$dnsuri>" . " [" . join(", ", @{ $answers }) . "]\n";
  0         0  
412             }
413 96 50 33     892 if (defined $rbl_tag && $rbl_tag ne '') {
414 0         0 chomp $rbl_tag;
415 0         0 $self->set_tag('RBL', $rbl_tag);
416             }
417             }
418              
419             ###########################################################################
420              
421             sub rbl_finish {
422 96     96 0 208 my ($self) = @_;
423              
424 96         366 $self->set_rbl_tag_data();
425              
426 96         211 delete $self->{dnspost};
427 96         320 delete $self->{dnsuri};
428             }
429              
430             ###########################################################################
431              
432             sub load_resolver {
433 1     1 0 2 my ($self) = @_;
434 1         3 $self->{resolver} = $self->{main}->{resolver};
435 1         4 return $self->{resolver}->load_resolver();
436             }
437              
438             sub clear_resolver {
439 1     1 0 4 my ($self) = @_;
440 1         5 dbg("dns: clear_resolver");
441 1         15 $self->{main}->{resolver}->{res} = undef;
442 1         3 return 0;
443             }
444              
445             sub lookup_ns {
446 0     0 0 0 my ($self, $dom) = @_;
447              
448 0 0       0 return unless $self->load_resolver();
449 0 0       0 return if ($self->server_failed_to_respond_for_domain ($dom));
450              
451 0         0 my $nsrecords;
452 0         0 dbg("dns: looking up NS for '$dom'");
453              
454             eval {
455 0         0 my $query = $self->{resolver}->send($dom, 'NS');
456 0         0 my @nses;
457 0 0       0 if ($query) {
458 0         0 foreach my $rr ($query->answer) {
459 0 0       0 if ($rr->type eq "NS") { push (@nses, $rr->nsdname); }
  0         0  
460             }
461             }
462 0         0 $nsrecords = [ @nses ];
463 0         0 1;
464 0 0       0 } or do {
465 0 0       0 my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
  0         0  
466 0         0 dbg("dns: NS lookup failed horribly, perhaps bad resolv.conf setting? (%s)", $eval_stat);
467 0         0 return;
468             };
469              
470 0         0 $nsrecords;
471             }
472              
473             sub is_dns_available {
474 336     336 0 657 my ($self) = @_;
475 336         802 my $dnsopt = $self->{conf}->{dns_available};
476 336   50     912 my $dnsint = $self->{conf}->{dns_test_interval} || 600;
477 336         501 my @domains;
478              
479 336   100     826 $LAST_DNS_CHECK ||= 0;
480 336         914 my $diff = time() - $LAST_DNS_CHECK;
481              
482             # undef $IS_DNS_AVAILABLE if we should be testing for
483             # working DNS and our check interval time has passed
484 336 50 33     843 if ($dnsopt eq "test" && $diff > $dnsint) {
485 0         0 $IS_DNS_AVAILABLE = undef;
486 0         0 dbg("dns: is_dns_available() last checked %.1f seconds ago; re-checking",
487             $diff);
488             }
489              
490 336 100       1904 return $IS_DNS_AVAILABLE if (defined $IS_DNS_AVAILABLE);
491 8         27 $LAST_DNS_CHECK = time();
492              
493 8         16 $IS_DNS_AVAILABLE = 0;
494 8 50       29 if ($dnsopt eq "no") {
495 0         0 dbg("dns: dns_available set to no in config file, skipping test");
496 0         0 return $IS_DNS_AVAILABLE;
497             }
498              
499             # Even if "dns_available" is explicitly set to "yes", we want to ignore
500             # DNS if we're only supposed to be looking at local tests.
501 8 100       61 goto done if ($self->{main}->{local_tests_only});
502              
503             # Check version numbers - runtime check only
504 1 50       3 if (defined $Net::DNS::VERSION) {
505 1 50       5 if (am_running_on_windows()) {
506 0 0       0 if ($Net::DNS::VERSION < 0.46) {
507 0         0 warn("dns: Net::DNS version is $Net::DNS::VERSION, but need 0.46 for Win32");
508 0         0 return $IS_DNS_AVAILABLE;
509             }
510             }
511             else {
512 1 50       4 if ($Net::DNS::VERSION < 0.34) {
513 0         0 warn("dns: Net::DNS version is $Net::DNS::VERSION, but need 0.34");
514 0         0 return $IS_DNS_AVAILABLE;
515             }
516             }
517             }
518              
519 1         21 $self->clear_resolver();
520 1 50       4 goto done unless $self->load_resolver();
521              
522 1 50       6 if ($dnsopt eq "yes") {
523             # optionally shuffle the list of nameservers to distribute the load
524 1 50       5 if ($self->{conf}->{dns_options}->{rotate}) {
525 0         0 my @nameservers = $self->{resolver}->available_nameservers();
526 0         0 Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers);
527 0         0 dbg("dns: shuffled NS list: " . join(", ", @nameservers));
528 0         0 $self->{resolver}->available_nameservers(@nameservers);
529             }
530 1         3 $IS_DNS_AVAILABLE = 1;
531 1         4 dbg("dns: dns_available set to yes in config file, skipping test");
532 1         5 return $IS_DNS_AVAILABLE;
533             }
534              
535 0 0       0 if ($dnsopt =~ /^test:\s*(\S.*)$/) {
536 0         0 @domains = split (/\s+/, $1);
537 0         0 dbg("dns: looking up NS records for user specified domains: %s",
538             join(", ", @domains));
539             } else {
540 0         0 @domains = @EXISTING_DOMAINS;
541 0         0 dbg("dns: looking up NS records for built-in domains");
542             }
543              
544             # do the test with a full set of configured nameservers
545 0         0 my @nameservers = $self->{resolver}->configured_nameservers();
546              
547             # optionally shuffle the list of nameservers to distribute the load
548 0 0       0 if ($self->{conf}->{dns_options}->{rotate}) {
549 0         0 Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers);
550 0         0 dbg("dns: shuffled NS list, testing: " . join(", ", @nameservers));
551             } else {
552 0         0 dbg("dns: testing resolver nameservers: " . join(", ", @nameservers));
553             }
554              
555             # Try the different nameservers here and collect a list of working servers
556 0         0 my @good_nameservers;
557 0         0 foreach my $ns (@nameservers) {
558 0         0 $self->{resolver}->available_nameservers($ns); # try just this one
559 0   0     0 for (my $retry = 3; $retry > 0 && @domains; $retry--) {
560 0         0 my $domain = splice(@domains, rand(@domains), 1);
561 0         0 dbg("dns: trying ($retry) $domain, server $ns ...");
562 0         0 my $result = $self->lookup_ns($domain);
563 0         0 $self->{resolver}->finish_socket();
564 0 0       0 if (!$result) {
    0          
565 0         0 dbg("dns: NS lookup of $domain using $ns failed horribly, ".
566             "may not be a valid nameserver");
567 0         0 last;
568             } elsif (!@$result) {
569 0         0 dbg("dns: NS lookup of $domain using $ns failed, no results found");
570             } else {
571 0         0 dbg("dns: NS lookup of $domain using $ns succeeded => DNS available".
572             " (set dns_available to override)");
573 0         0 push(@good_nameservers, $ns);
574 0         0 last;
575             }
576             }
577             }
578              
579 0 0       0 if (!@good_nameservers) {
580 0         0 dbg("dns: all NS queries failed => DNS unavailable ".
581             "(set dns_available to override)");
582             } else {
583 0         0 $IS_DNS_AVAILABLE = 1;
584 0         0 dbg("dns: NS list: ".join(", ", @good_nameservers));
585 0         0 $self->{resolver}->available_nameservers(@good_nameservers);
586             }
587              
588 7         40 done:
589             # jm: leaving this in!
590             dbg("dns: is DNS available? " . $IS_DNS_AVAILABLE);
591 7         48 return $IS_DNS_AVAILABLE;
592             }
593              
594             ###########################################################################
595              
596             sub server_failed_to_respond_for_domain {
597 0     0 0 0 my ($self, $dom) = @_;
598 0 0       0 if ($self->{dns_server_too_slow}->{$dom}) {
599 0         0 dbg("dns: server for '$dom' failed to reply previously, not asking again");
600 0         0 return 1;
601             }
602 0         0 return 0;
603             }
604              
605             sub set_server_failed_to_respond_for_domain {
606 0     0 0 0 my ($self, $dom) = @_;
607 0         0 dbg("dns: server for '$dom' failed to reply, marking as bad");
608 0         0 $self->{dns_server_too_slow}->{$dom} = 1;
609             }
610              
611             ###########################################################################
612              
613             sub enter_helper_run_mode {
614 4     4 0 10 my ($self) = @_;
615              
616 4         12 dbg("dns: entering helper-app run mode");
617 4         14 $self->{old_slash} = $/; # Razor pollutes this
618 4         11 %{$self->{old_env}} = ();
  4         14  
619 4 50       16 if ( %ENV ) {
620             # undefined values in %ENV can result due to autovivification elsewhere,
621             # this prevents later possible warnings when we restore %ENV
622 4         40 while (my ($key, $value) = each %ENV) {
623 136 50       763 $self->{old_env}->{$key} = $value if defined $value;
624             }
625             }
626              
627 4         25 Mail::SpamAssassin::Util::clean_path_in_taint_mode();
628              
629 4         8 my $newhome;
630 4 50       14 if ($self->{main}->{home_dir_for_helpers}) {
631 0         0 $newhome = $self->{main}->{home_dir_for_helpers};
632             } else {
633             # use spamd -u user's home dir
634 4         19 $newhome = (Mail::SpamAssassin::Util::portable_getpwuid ($>))[7];
635             }
636              
637 4 50       38 if ($newhome) {
638 4         26 $ENV{'HOME'} = Mail::SpamAssassin::Util::untaint_file_path ($newhome);
639             }
640              
641             # enforce SIGCHLD as DEFAULT; IGNORE causes spurious kernel warnings
642             # on Red Hat NPTL kernels (bug 1536), and some users of the
643             # Mail::SpamAssassin modules set SIGCHLD to be a fatal signal
644             # for some reason! (bug 3507)
645 4         27 $self->{old_sigchld_handler} = $SIG{CHLD};
646 4         120 $SIG{CHLD} = 'DEFAULT';
647             }
648              
649             sub leave_helper_run_mode {
650 4     4 0 12 my ($self) = @_;
651              
652 4         17 dbg("dns: leaving helper-app run mode");
653 4         17 $/ = $self->{old_slash};
654 4         7 %ENV = %{$self->{old_env}};
  4         443  
655              
656 4 100       29 if (defined $self->{old_sigchld_handler}) {
657 3         52 $SIG{CHLD} = $self->{old_sigchld_handler};
658             } else {
659             # if SIGCHLD has never been explicitly set, it's returned as undef.
660             # however, when *setting* SIGCHLD, using undef(%) or assigning to an
661             # undef value produces annoying 'Use of uninitialized value in scalar
662             # assignment' warnings. That's silly. workaround:
663 1         82 $SIG{CHLD} = 'DEFAULT';
664             }
665             }
666              
667             # note: this must be called before leave_helper_run_mode() is called,
668             # as the SIGCHLD signal must be set to DEFAULT for it to work.
669             sub cleanup_kids {
670 0     0 0 0 my ($self, $pid) = @_;
671            
672 0 0 0     0 if ($SIG{CHLD} && $SIG{CHLD} ne 'IGNORE') { # running from spamd
673 0         0 waitpid ($pid, 0);
674             }
675             }
676              
677             ###########################################################################
678              
679             sub register_async_rule_start {
680 135     135 0 249 my ($self, $rule) = @_;
681 135         377 dbg("dns: $rule lookup start");
682 135         395 $self->{rule_to_rblkey}->{$rule} = '*ASYNC_START';
683             }
684              
685             sub register_async_rule_finish {
686 42     42 0 95 my ($self, $rule) = @_;
687 42         146 dbg("dns: $rule lookup finished");
688 42         321 delete $self->{rule_to_rblkey}->{$rule};
689             }
690              
691             sub mark_all_async_rules_complete {
692 96     96 0 227 my ($self) = @_;
693 96         434 $self->{rule_to_rblkey} = { };
694             }
695              
696             sub is_rule_complete {
697 0     0 0 0 my ($self, $rule) = @_;
698              
699 0         0 my $key = $self->{rule_to_rblkey}->{$rule};
700 0 0       0 if (!defined $key) {
701             # dbg("dns: $rule lookup complete, not in list");
702 0         0 return 1;
703             }
704              
705 0 0       0 if ($key eq '*ASYNC_START') {
706 0         0 dbg("dns: $rule lookup not yet complete");
707 0         0 return 0; # not yet complete
708             }
709              
710 0         0 my $ent = $self->{async}->get_lookup($key);
711 0 0       0 if (!defined $ent) {
712 0         0 dbg("dns: $rule lookup complete, $key no longer pending");
713 0         0 return 1;
714             }
715              
716 0         0 dbg("dns: $rule lookup not yet complete");
717 0         0 return 0; # not yet complete
718             }
719              
720             ###########################################################################
721              
722             # interface called by SPF plugin
723             sub check_for_from_dns {
724 8     8 0 18 my ($self, $pms) = @_;
725 8 50       53 if (defined $pms->{sender_host_fail}) {
726 0           return ($pms->{sender_host_fail} == 2); # both MX and A need to fail
727             }
728             }
729              
730             1;