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