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
18use strict;  # make Test::Perl::Critic happy
19package Mail::SpamAssassin::Dns; 1;
20
21package Mail::SpamAssassin::PerMsgStatus;
22
23use strict;
24use warnings;
25# use bytes;
26use re 'taint';
27
28use Mail::SpamAssassin::Conf;
29use Mail::SpamAssassin::PerMsgStatus;
30use Mail::SpamAssassin::AsyncLoop;
31use Mail::SpamAssassin::Constants qw(:ip);
32use Mail::SpamAssassin::Util qw(untaint_var am_running_on_windows compile_regexp);
33
34use File::Spec;
35use IO::Socket;
36use POSIX ":sys_wait_h";
37
38
39our $KNOWN_BAD_DIALUP_RANGES; # Nothing uses this var???
40our $LAST_DNS_CHECK = 0;
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# these MUST contain both A/AAAA records so we can test dns_options v6
45# Updated 8/2019 from https://ip6.nl/#!list?db=alexa500
46#
47our @EXISTING_DOMAINS = qw{
48  akamai.com
49  bing.com
50  cloudflare.com
51  digitalpoint.com
52  facebook.com
53  google.com
54  linkedin.com
55  netflix.com
56  php.net
57  wikipedia.org
58  yahoo.com
59};
60
61our $IS_DNS_AVAILABLE = undef;
62
63#Removed $VERSION per BUG 6422
64#$VERSION = 'bogus';     # avoid CPAN.pm picking up razor ver
65
66###########################################################################
67
68BEGIN {
69  # some trickery. Load these modules right here, if possible; that way, if
70  # the module exists, we'll get it loaded now.  Very useful to avoid attempted
71  # loads later (which will happen).  If we do a fork(), we could wind up
72  # attempting to load these modules in *every* subprocess.
73  #
74# # We turn off strict and warnings, because Net::DNS and Razor both contain
75# # crud that -w complains about (perl 5.6.0).  Not that this seems to work,
76# # mind ;)
77# no strict;
78# local ($^W) = 0;
79
80  no warnings;
81  eval {
82    require MIME::Base64;
83  };
84  eval {
85    require IO::Socket::UNIX;
86  };
87};
88
89###########################################################################
90
91sub do_rbl_lookup {
92  my ($self, $rule, $set, $type, $host, $subtest) = @_;
93
94  if (defined $subtest) {
95    if ($subtest =~ /^sb:/) {
96      info("dns: ignored $rule, SenderBase rules are deprecated");
97      return;
98    }
99    # Compile as regex if not pure ip/bitmask (same check in process_dnsbl_result)
100    if ($subtest !~ /^\d+(?:\.\d+\.\d+\.\d+)?$/) {
101      my ($rec, $err) = compile_regexp($subtest, 0);
102      if (!$rec) {
103        warn("dns: invalid rule $rule subtest regexp '$subtest': $err\n");
104        return;
105      }
106      $subtest = $rec;
107    }
108  }
109
110  dbg("dns: launching rule %s, set %s, type %s, %s", $rule, $set, $type,
111    defined $subtest ? "subtest $subtest" : 'no subtest');
112
113  my $ent = {
114    rulename => $rule,
115    type => "DNSBL",
116    set => $set,
117    subtest => $subtest,
118  };
119  $self->{async}->bgsend_and_start_lookup($host, $type, undef, $ent,
120    sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) },
121    master_deadline => $self->{master_deadline}
122  );
123}
124
125# Deprecated, was only used from DNSEval.pm?
126sub do_dns_lookup {
127  my ($self, $rule, $type, $host) = @_;
128
129  my $ent = {
130    rulename => $rule,
131    type => "DNSBL",
132  };
133  $self->{async}->bgsend_and_start_lookup($host, $type, undef, $ent,
134    sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) },
135    master_deadline => $self->{master_deadline}
136  );
137}
138
139###########################################################################
140
141sub dnsbl_hit {
142  my ($self, $rule, $question, $answer) = @_;
143
144  my $log = "";
145  if (substr($rule, 0, 2) eq "__") {
146    # don't bother with meta rules
147  } elsif ($answer->type eq 'TXT') {
148    # txtdata returns a non- zone-file-format encoded result, unlike rdstring;
149    # avoid space-separated RDATA <character-string> fields if possible,
150    # txtdata provides a list of strings in a list context since Net::DNS 0.69
151    $log = join('', $answer->txtdata);
152    utf8::encode($log)  if utf8::is_utf8($log);
153    local $1;
154    $log =~ s{ (?<! [<(\[] ) (https? : // \S+)}{<$1>}xgi;
155  } else {  # assuming $answer->type eq 'A'
156    local($1,$2,$3,$4,$5);
157    if ($question->string =~ /^((?:[0-9a-fA-F]\.){32})(\S+\w)/) {
158      $log = ' listed in ' . lc($2);
159      my $ipv6addr = join('', reverse split(/\./, lc $1));
160      $ipv6addr =~ s/\G(....)/$1:/g;  chop $ipv6addr;
161      $ipv6addr =~ s/:0{1,3}/:/g;
162      $log = $ipv6addr . $log;
163    } elsif ($question->string =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\.(\S+\w)/) {
164      $log = "$4.$3.$2.$1 listed in " . lc($5);
165    } elsif ($question->string =~ /^(\S+)(?<!\.)/) {
166      $log = "listed in ".lc($1);
167    }
168  }
169
170  if ($log) {
171    $self->test_log($log, $rule);
172  }
173
174  if (!$self->{tests_already_hit}->{$rule}) {
175    dbg("dns: rbl rule $rule hit");
176    $self->got_hit($rule, "RBL: ", ruletype => "dnsbl");
177  }
178}
179
180sub dnsbl_uri {
181  my ($self, $question, $answer) = @_;
182
183  my $rdatastr;
184  if ($answer->UNIVERSAL::can('txtdata')) {
185    # txtdata returns a non- zone-file-format encoded result, unlike rdstring;
186    # avoid space-separated RDATA <character-string> fields if possible,
187    # txtdata provides a list of strings in a list context since Net::DNS 0.69
188    $rdatastr = join('', $answer->txtdata);
189  } else {
190    $rdatastr = $answer->rdstring;
191    # encoded in a RFC 1035 zone file format (escaped), decode it
192    $rdatastr =~ s{ \\ ( [0-9]{3} | (?![0-9]{3}) . ) }
193                  { length($1)==3 && $1 <= 255 ? chr($1) : $1 }xgse;
194  }
195
196  # Bug 7236: Net::DNS attempts to decode text strings in a TXT record as
197  # UTF-8 since version 0.69, which is undesired: octets failing the UTF-8
198  # decoding are converted to a Unicode "replacement character" U+FFFD, and
199  # ASCII text is unnecessarily flagged as perl native characters.
200  utf8::encode($rdatastr)  if utf8::is_utf8($rdatastr);
201
202  my $qname = $question->qname;
203  if (defined $qname && defined $rdatastr) {
204    my $qclass = $question->qclass;
205    my $qtype = $question->qtype;
206    my @vals;
207    push(@vals, "class=$qclass") if $qclass ne "IN";
208    push(@vals, "type=$qtype") if $qtype ne "A";
209    my $uri = "dns:$qname" . (@vals ? "?" . join(";", @vals) : "");
210
211    $self->{dnsuri}{$uri}{$rdatastr} = 1;
212    dbg("dns: hit <$uri> $rdatastr");
213  }
214}
215
216# called as a completion routine to bgsend by DnsResolver::poll_responses;
217# returns 1 on successful packet processing
218sub process_dnsbl_result {
219  my ($self, $ent, $pkt) = @_;
220
221  return if !$pkt;
222  my $question = ($pkt->question)[0];
223  return if !$question;
224
225  # DNSBL tests are here
226  foreach my $answer ($pkt->answer) {
227    next if !$answer;
228    # track all responses
229    $self->dnsbl_uri($question, $answer);
230    my $answ_type = $answer->type;
231    # TODO: there are some CNAME returns that might be useful
232    next if $answ_type ne 'A' && $answ_type ne 'TXT';
233
234    my $rdatastr;
235    if ($answer->UNIVERSAL::can('txtdata')) {
236      # txtdata returns a non- zone-file-format encoded result, unlike rdstring;
237      # avoid space-separated RDATA <character-string> fields if possible,
238      # txtdata provides a list of strings in a list context since Net::DNS 0.69
239      $rdatastr = join('', $answer->txtdata);
240    } else {
241      $rdatastr = $answer->rdstring;
242      # encoded in a RFC 1035 zone file format (escaped), decode it
243      $rdatastr =~ s{ \\ ( [0-9]{3} | (?![0-9]{3}) . ) }
244                    { length($1)==3 && $1 <= 255 ? chr($1) : $1 }xgse;
245    }
246
247    # Bug 7236: Net::DNS attempts to decode text strings in a TXT record as
248    # UTF-8 since version 0.69, which is undesired: octets failing the UTF-8
249    # decoding are converted to a Unicode "replacement character" U+FFFD, and
250    # ASCII text is unnecessarily flagged as perl native characters.
251    utf8::encode($rdatastr)  if utf8::is_utf8($rdatastr);
252
253    # skip any A record that isn't on 127.0.0.0/8
254    next if $answ_type eq 'A' && $rdatastr !~ /^127\./;
255
256    # check_rbl tests
257    if (defined $ent->{subtest}) {
258      if ($self->check_subtest($rdatastr, $ent->{subtest})) {
259        $self->dnsbl_hit($ent->{rulename}, $question, $answer);
260      }
261    } else {
262      $self->dnsbl_hit($ent->{rulename}, $question, $answer);
263    }
264
265    # check_rbl_sub tests
266    if (defined $self->{rbl_subs}{$ent->{set}}) {
267      $self->process_dnsbl_set($ent->{set}, $question, $answer, $rdatastr);
268    }
269  }
270  return 1;
271}
272
273sub process_dnsbl_set {
274  my ($self, $set, $question, $answer, $rdatastr) = @_;
275
276  foreach my $args (@{$self->{rbl_subs}{$set}}) {
277    my $subtest = $args->[0];
278    my $rule = $args->[1];
279    next if $self->{tests_already_hit}->{$rule};
280    if ($self->check_subtest($rdatastr, $subtest)) {
281      $self->dnsbl_hit($rule, $question, $answer);
282    }
283  }
284}
285
286sub check_subtest {
287  my ($self, $rdatastr, $subtest) = @_;
288
289  # regular expression
290  if (ref($subtest) eq 'Regexp') {
291    if ($rdatastr =~ $subtest) {
292      return 1;
293    }
294  }
295  # bitmask
296  elsif ($subtest =~ /^\d+$/) {
297    # Bug 6803: response should be within 127.0.0.0/8, ignore otherwise
298    if ($rdatastr =~ m/^127\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ &&
299        Mail::SpamAssassin::Util::my_inet_aton($rdatastr) & $subtest)
300    {
301      return 1;
302    }
303  }
304  else {
305    # test for exact equality (an IPv4 address)
306    if ($subtest eq $rdatastr) {
307      return 1;
308    }
309  }
310
311  return 0;
312}
313
314# Deprecated since 4.0, meta rules do not depend on priorities anymore
315sub harvest_until_rule_completes {}
316
317sub harvest_dnsbl_queries {
318  my ($self) = @_;
319
320  dbg("dns: harvest_dnsbl_queries");
321
322  for (my $first=1;  ; $first=0) {
323    # complete_lookups() may call completed_callback(), which may
324    # call start_lookup() again (like in Plugin::URIDNSBL)
325
326    # the first time around we specify a 0 timeout, which gives
327    # complete_lookups a chance to ripe any available results and
328    # abort overdue requests, without needlessly waiting for more
329
330    my ($alldone,$anydone) =
331      $self->{async}->complete_lookups($first ? 0 : 1.0,  1);
332
333    last  if $alldone || $self->{deadline_exceeded} || $self->{shortcircuited};
334
335    dbg("dns: harvest_dnsbl_queries - check_tick");
336    $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
337  }
338
339  # explicitly abort anything left
340  $self->{async}->abort_remaining_lookups();
341  $self->{async}->log_lookups_timing();
342  1;
343}
344
345# collect and process whatever DNS responses have already arrived,
346# don't waste time waiting for more, don't poll too often.
347# don't abort any queries even if overdue,
348sub harvest_completed_queries {
349  my ($self) = @_;
350
351  # don't bother collecting responses too often
352  my $last_poll_time = $self->{async}->last_poll_responses_time();
353  return if defined $last_poll_time && time - $last_poll_time < 0.1;
354
355  my ($alldone,$anydone) = $self->{async}->complete_lookups(0, 0);
356  if ($anydone) {
357    dbg("dns: harvested completed queries");
358#   $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
359  }
360}
361
362sub set_rbl_tag_data {
363  my ($self) = @_;
364
365  return if !$self->{dnsuri};
366
367  # DNS URIs
368  my $rbl_tag = $self->{tag_data}->{RBL};  # just in case, should be empty
369  $rbl_tag = ''  if !defined $rbl_tag;
370  while (my ($dnsuri, $answers) = each %{$self->{dnsuri}}) {
371    # when parsing, look for elements of \".*?\" or \S+ with ", " as separator
372    $rbl_tag .= "<$dnsuri>" . " [" . join(", ", keys %$answers) . "]\n";
373  }
374  if (defined $rbl_tag && $rbl_tag ne '') {
375    chomp $rbl_tag;
376    $self->set_tag('RBL', $rbl_tag);
377  }
378}
379
380###########################################################################
381
382sub rbl_finish {
383  my ($self) = @_;
384
385  $self->set_rbl_tag_data();
386
387  delete $self->{rbl_subs};
388  delete $self->{dnsuri};
389}
390
391###########################################################################
392
393sub load_resolver {
394  my ($self) = @_;
395  $self->{resolver} = $self->{main}->{resolver};
396  return $self->{resolver}->load_resolver();
397}
398
399sub clear_resolver {
400  my ($self) = @_;
401  dbg("dns: clear_resolver");
402  $self->{main}->{resolver}->{res} = undef;
403  return 0;
404}
405
406# Deprecated since 4.0.0
407sub lookup_ns {
408  warn "dns: deprecated lookup_ns called, query ignored\n";
409  return;
410}
411
412sub test_dns_a_aaaa {
413  my ($self, $dom) = @_;
414
415  return if ($self->server_failed_to_respond_for_domain ($dom));
416
417  my ($a, $aaaa) = (0, 0);
418
419  if ($self->{conf}->{dns_options}->{v4}) {
420    eval {
421      my $query = $self->{resolver}->send($dom, 'A');
422      if ($query) {
423        foreach my $rr ($query->answer) {
424          if ($rr->type eq 'A') { $a = 1; last; }
425        }
426      }
427      1;
428    } or do {
429      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
430      dbg("dns: test A lookup failed horribly, perhaps bad resolv.conf setting? (%s)", $eval_stat);
431      return (undef, undef);
432    };
433    if (!$a) {
434      dbg("dns: test A lookup returned no results, use \"dns_options nov4\" if resolver doesn't support A queries");
435    }
436  } else {
437    $a = 1;
438  }
439
440  if ($self->{conf}->{dns_options}->{v6}) {
441    eval {
442      my $query = $self->{resolver}->send($dom, 'AAAA');
443      if ($query) {
444        foreach my $rr ($query->answer) {
445          if ($rr->type eq 'AAAA') { $aaaa = 1; last; }
446        }
447      }
448      1;
449    } or do {
450      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
451      dbg("dns: test AAAA lookup failed horribly, perhaps bad resolv.conf setting? (%s)", $eval_stat);
452      return (undef, undef);
453    };
454    if (!$aaaa) {
455      dbg("dns: test AAAA lookup returned no results, use \"dns_options nov6\" if resolver doesn't support AAAA queries");
456    }
457  } else {
458    $aaaa = 1;
459  }
460
461  return ($a, $aaaa);
462}
463
464sub is_dns_available {
465  my ($self) = @_;
466  my $dnsopt = $self->{conf}->{dns_available};
467
468  # Fast response for the most common cases
469  return 1 if $IS_DNS_AVAILABLE && $dnsopt eq "yes";
470  return 0 if defined $IS_DNS_AVAILABLE && $dnsopt eq "no";
471
472  # croak on misconfigured flags
473  if (!$self->{conf}->{dns_options}->{v4} &&
474      !$self->{conf}->{dns_options}->{v6})
475  {
476    warn 'dns: error: dns_options "nov4" and "nov6" are both set, '.
477         ' only use either, or use "dns_available no" to really disable DNS'.
478         "\n";
479    $IS_DNS_AVAILABLE = 0;
480    $self->{conf}->{dns_available} = "no";
481    return 0;
482  }
483
484  # undef $IS_DNS_AVAILABLE if we should be testing for
485  # working DNS and our check interval time has passed
486  if ($dnsopt eq "test") {
487    my $diff = time - $LAST_DNS_CHECK;
488    if ($diff > ($self->{conf}->{dns_test_interval}||600)) {
489      $IS_DNS_AVAILABLE = undef;
490      if ($LAST_DNS_CHECK) {
491        dbg("dns: is_dns_available() last checked %.1f seconds ago; re-checking", $diff);
492      } else {
493        dbg("dns: is_dns_available() initial check");
494      }
495    }
496    $LAST_DNS_CHECK = time;
497  }
498
499  return $IS_DNS_AVAILABLE if defined $IS_DNS_AVAILABLE;
500
501  $IS_DNS_AVAILABLE = 0;
502
503  if ($dnsopt eq "no") {
504    dbg("dns: dns_available set to no in config file, skipping test");
505    return $IS_DNS_AVAILABLE;
506  }
507
508  # Even if "dns_available" is explicitly set to "yes", we want to ignore
509  # DNS if we're only supposed to be looking at local tests.
510  if ($self->{main}->{local_tests_only}) {
511    dbg("dns: using local tests only, DNS not available");
512    return $IS_DNS_AVAILABLE;
513  }
514
515  #$self->clear_resolver();
516  if (!$self->load_resolver()) {
517    dbg("dns: could not load resolver, DNS not available");
518    return $IS_DNS_AVAILABLE;
519  }
520
521  if ($dnsopt eq "yes") {
522    # optionally shuffle the list of nameservers to distribute the load
523    if ($self->{conf}->{dns_options}->{rotate}) {
524      my @nameservers = $self->{resolver}->available_nameservers();
525      Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers);
526      dbg("dns: shuffled NS list: " . join(", ", @nameservers));
527      $self->{resolver}->available_nameservers(@nameservers);
528    }
529    $IS_DNS_AVAILABLE = 1;
530    dbg("dns: dns_available set to yes in config file, skipping test");
531    return $IS_DNS_AVAILABLE;
532  }
533
534  my @domains;
535  my @rtypes;
536  push @rtypes, 'A' if $self->{main}->{conf}->{dns_options}->{v4};
537  push @rtypes, 'AAAA' if $self->{main}->{conf}->{dns_options}->{v6};
538  if ($dnsopt =~ /^test:\s*(\S.*)$/) {
539    @domains = split (/\s+/, $1);
540    dbg("dns: testing %s records for user specified domains: %s",
541        join("/", @rtypes), join(", ", @domains));
542  } else {
543    @domains = @EXISTING_DOMAINS;
544    dbg("dns: testing %s records for built-in domains: %s",
545        join("/", @rtypes), join(", ", @domains));
546  }
547
548  # do the test with a full set of configured nameservers
549  my @nameservers = $self->{resolver}->configured_nameservers();
550
551  # optionally shuffle the list of nameservers to distribute the load
552  if ($self->{conf}->{dns_options}->{rotate}) {
553    Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers);
554    dbg("dns: shuffled NS list, testing: " . join(", ", @nameservers));
555  } else {
556    dbg("dns: testing resolver nameservers: " . join(", ", @nameservers));
557  }
558
559  # Try the different nameservers here and collect a list of working servers
560  my @good_nameservers;
561  foreach my $ns (@nameservers) {
562    $self->{resolver}->available_nameservers($ns);  # try just this one
563    for (my $retry = 0; $retry < 3 && @domains; $retry++) {
564      my $domain = splice(@domains, rand(@domains), 1);
565      dbg("dns: trying $domain, server $ns ..." .
566          ($retry ? " (retry $retry)" : ""));
567      my ($ok_a, $ok_aaaa) = $self->test_dns_a_aaaa($domain);
568      $self->{resolver}->finish_socket();
569      if (!defined $ok_a || !defined $ok_aaaa) {
570        # error printed already
571        last;
572      } elsif (!$ok_a && !$ok_aaaa) {
573        dbg("dns: lookup of $domain using $ns failed, no results found");
574      } else {
575        dbg("dns: lookup of $domain using $ns succeeded => DNS available".
576            " (set dns_available to override)");
577        push(@good_nameservers, $ns);
578        last;
579      }
580    }
581  }
582
583  if (!@good_nameservers) {
584    dbg("dns: all NS queries failed => DNS unavailable ".
585        "(set dns_available to override)");
586  } else {
587    $IS_DNS_AVAILABLE = 1;
588    dbg("dns: NS list: ".join(", ", @good_nameservers));
589    $self->{resolver}->available_nameservers(@good_nameservers);
590  }
591
592  dbg("dns: is DNS available? " . $IS_DNS_AVAILABLE);
593  return $IS_DNS_AVAILABLE;
594}
595
596###########################################################################
597
598sub server_failed_to_respond_for_domain {
599  my ($self, $dom) = @_;
600  if ($self->{dns_server_too_slow}->{$dom}) {
601    dbg("dns: server for '$dom' failed to reply previously, not asking again");
602    return 1;
603  }
604  return 0;
605}
606
607sub set_server_failed_to_respond_for_domain {
608  my ($self, $dom) = @_;
609  dbg("dns: server for '$dom' failed to reply, marking as bad");
610  $self->{dns_server_too_slow}->{$dom} = 1;
611}
612
613###########################################################################
614
615sub enter_helper_run_mode {
616  my ($self) = @_;
617
618  dbg("dns: entering helper-app run mode");
619  $self->{old_slash} = $/;              # Razor pollutes this
620  %{$self->{old_env}} = ();
621  if ( %ENV ) {
622    # undefined values in %ENV can result due to autovivification elsewhere,
623    # this prevents later possible warnings when we restore %ENV
624    while (my ($key, $value) = each %ENV) {
625      $self->{old_env}->{$key} = $value if defined $value;
626    }
627  }
628
629  Mail::SpamAssassin::Util::clean_path_in_taint_mode();
630
631  my $newhome;
632  if ($self->{main}->{home_dir_for_helpers}) {
633    $newhome = $self->{main}->{home_dir_for_helpers};
634  } else {
635    # use spamd -u user's home dir
636    $newhome = (Mail::SpamAssassin::Util::portable_getpwuid ($>))[7];
637  }
638
639  if ($newhome) {
640    $ENV{'HOME'} = Mail::SpamAssassin::Util::untaint_file_path ($newhome);
641  }
642
643  # enforce SIGCHLD as DEFAULT; IGNORE causes spurious kernel warnings
644  # on Red Hat NPTL kernels (bug 1536), and some users of the
645  # Mail::SpamAssassin modules set SIGCHLD to be a fatal signal
646  # for some reason! (bug 3507)
647  $self->{old_sigchld_handler} = $SIG{CHLD};
648  $SIG{CHLD} = 'DEFAULT';
649}
650
651sub leave_helper_run_mode {
652  my ($self) = @_;
653
654  dbg("dns: leaving helper-app run mode");
655  $/ = $self->{old_slash};
656  %ENV = %{$self->{old_env}};
657
658  if (defined $self->{old_sigchld_handler}) {
659    $SIG{CHLD} = $self->{old_sigchld_handler};
660  } else {
661    # if SIGCHLD has never been explicitly set, it's returned as undef.
662    # however, when *setting* SIGCHLD, using undef(%) or assigning to an
663    # undef value produces annoying 'Use of uninitialized value in scalar
664    # assignment' warnings.  That's silly.  workaround:
665    $SIG{CHLD} = 'DEFAULT';
666  }
667}
668
669# note: this must be called before leave_helper_run_mode() is called,
670# as the SIGCHLD signal must be set to DEFAULT for it to work.
671sub cleanup_kids {
672  my ($self, $pid) = @_;
673
674  if ($SIG{CHLD} && $SIG{CHLD} ne 'IGNORE') {	# running from spamd
675    waitpid ($pid, 0);
676  }
677}
678
679###########################################################################
680
681# Deprecated async functions, everything is handled automatically
682# now by bgsend .. $self->{async}->{pending_rules}
683sub register_async_rule_start {}
684sub register_async_rule_finish {}
685sub mark_all_async_rules_complete {}
686sub is_rule_complete {}
687
688# Return number of pending lookups for a rule,
689# or list all of rules still pending
690sub get_pending_lookups {
691  my ($self, $rule) = @_;
692  if (defined $rule) {
693    return 0 if !exists $self->{async}->{pending_rules}{$rule};
694    return scalar keys %{$self->{async}->{pending_rules}{$rule}};
695  } else {
696    return grep { %{$self->{async}->{pending_rules}{$_}} }
697             keys %{$self->{async}->{pending_rules}};
698  }
699}
700
701###########################################################################
702
7031;
704