File Coverage

blib/lib/Mail/SpamAssassin/AsyncLoop.pm
Criterion Covered Total %
statement 210 297 70.7
branch 67 170 39.4
condition 20 47 42.5
subroutine 16 19 84.2
pod 9 11 81.8
total 322 544 59.1


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             =head1 NAME
19              
20             Mail::SpamAssassin::AsyncLoop - scanner asynchronous event loop
21              
22             =head1 DESCRIPTION
23              
24             An asynchronous event loop used for long-running operations, performed "in the
25             background" during the Mail::SpamAssassin::check() scan operation, such as DNS
26             blocklist lookups.
27              
28             =head1 METHODS
29              
30             =over 4
31              
32             =cut
33              
34             package Mail::SpamAssassin::AsyncLoop;
35              
36 40     40   259 use strict;
  40         94  
  40         1226  
37 40     40   238 use warnings;
  40         93  
  40         1411  
38             # use bytes;
39 40     40   255 use re 'taint';
  40         82  
  40         2065  
40              
41 40     40   251 use Time::HiRes qw(time);
  40         112  
  40         250  
42              
43 40     40   3707 use Mail::SpamAssassin;
  40         82  
  40         1380  
44 40     40   232 use Mail::SpamAssassin::Logger;
  40         92  
  40         5222  
45              
46             our @ISA = qw();
47              
48             # obtain timer resolution if possible
49             our $timer_resolution;
50             BEGIN {
51             eval {
52 40 50       963 $timer_resolution = Time::HiRes->can('clock_getres')
53             ? Time::HiRes::clock_getres(Time::HiRes::CLOCK_REALTIME())
54             : 0.001; # wild guess, assume resolution is better than 1s
55 40         125930 1;
56 40 50   40   170 } or do {
57 0         0 $timer_resolution = 1; # Perl's builtin timer ticks at one second
58             };
59             }
60              
61             #############################################################################
62              
63             sub new {
64             # called from PerMsgStatus, a new AsyncLoop object is created
65             # for each new message processing
66 142     142 0 406 my $class = shift;
67 142   33     882 $class = ref($class) || $class;
68              
69 142         413 my ($main) = @_;
70 142         1830 my $self = {
71             main => $main,
72             queries_started => 0,
73             queries_completed => 0,
74             total_queries_started => 0,
75             total_queries_completed => 0,
76             pending_lookups => { },
77             timing_by_query => { },
78             all_lookups => { }, # keyed by "rr_type/domain"
79             };
80              
81 142         482 bless ($self, $class);
82 142         3189 $self;
83             }
84              
85             # Given a domain name, produces a listref of successively stripped down
86             # parent domains, e.g. a domain '2.10.Example.COM' would produce a list:
87             # '2.10.example.com', '10.example.com', 'example.com', 'com', ''
88             #
89             sub domain_to_search_list {
90 0     0 0 0 my ($domain) = @_;
91 0         0 $domain =~ s/^\.+//; $domain =~ s/\.+\z//; # strip leading and trailing dots
  0         0  
92 0         0 my @search_keys;
93 0 0       0 if ($domain =~ /\[/) { # don't split address literals
94 0         0 @search_keys = ( $domain, '' ); # presumably an address literal
95             } else {
96 0         0 local $1;
97 0         0 $domain = lc $domain;
98 0         0 for (;;) {
99 0         0 push(@search_keys, $domain);
100 0 0       0 last if $domain eq '';
101             # strip one level
102 0 0       0 $domain = ($domain =~ /^ (?: [^.]* ) \. (.*) \z/xs) ? $1 : '';
103             }
104 0 0       0 if (@search_keys > 20) { # enforce some sanity limit
105 0         0 @search_keys = @search_keys[$#search_keys-19 .. $#search_keys];
106             }
107             }
108 0         0 return \@search_keys;
109             }
110              
111             # ---------------------------------------------------------------------------
112              
113             =item $ent = $async->start_lookup($ent, $master_deadline)
114              
115             Register the start of a long-running asynchronous lookup operation.
116             C<$ent> is a hash reference containing the following items:
117              
118             =over 4
119              
120             =item key (required)
121              
122             A key string, unique to this lookup. This is what is reported in
123             debug messages, used as the key for C<get_lookup()>, etc.
124              
125             =item id (required)
126              
127             An ID string, also unique to this lookup. Typically, this is the DNS packet ID
128             as returned by DnsResolver's C<bgsend> method. Sadly, the Net::DNS
129             architecture forces us to keep a separate ID string for this task instead of
130             reusing C<key> -- if you are not using DNS lookups through DnsResolver, it
131             should be OK to just reuse C<key>.
132              
133             =item type (required)
134              
135             A string, typically one word, used to describe the type of lookup in log
136             messages, such as C<DNSBL>, C<MX>, C<TXT>.
137              
138             =item zone (optional)
139              
140             A zone specification (typically a DNS zone name - e.g. host, domain, or RBL)
141             which may be used as a key to look up per-zone settings. No semantics on this
142             parameter is imposed by this module. Currently used to fetch by-zone timeouts.
143              
144             =item timeout_initial (optional)
145              
146             An initial value of elapsed time for which we are willing to wait for a
147             response (time in seconds, floating point value is allowed). When elapsed
148             time since a query started exceeds the timeout value and there are no other
149             queries to wait for, the query is aborted. The actual timeout value ranges
150             from timeout_initial and gradually approaches timeout_min (see next parameter)
151             as the number of already completed queries approaches the number of all
152             queries started.
153              
154             If a caller does not explicitly provide this parameter or its value is
155             undefined, a default initial timeout value is settable by a configuration
156             variable rbl_timeout.
157              
158             If a value of the timeout_initial parameter is below timeout_min, the initial
159             timeout is set to timeout_min.
160              
161             =item timeout_min (optional)
162              
163             A lower bound (in seconds) to which the actual timeout approaches as the
164             number of queries completed approaches the number of all queries started.
165             Defaults to 0.2 * timeout_initial.
166              
167             =back
168              
169             C<$ent> is returned by this method, with its contents augmented by additional
170             information.
171              
172             =cut
173              
174             sub start_lookup {
175 13     13 1 29 my ($self, $ent, $master_deadline) = @_;
176              
177 13         23 my $id = $ent->{id};
178 13         24 my $key = $ent->{key};
179 13 50 33     72 defined $id && $id ne '' or die "oops, no id";
180 13 50       28 $key or die "oops, no key";
181 13 50       29 $ent->{type} or die "oops, no type";
182              
183 13         42 my $now = time;
184 13 50       48 $ent->{start_time} = $now if !defined $ent->{start_time};
185              
186             # are there any applicable per-zone settings?
187 13         36 my $zone = $ent->{zone};
188 13         23 my $settings; # a ref to a by-zone or to global settings
189 13         31 my $conf_by_zone = $self->{main}->{conf}->{by_zone};
190 13 50 33     49 if (defined $zone && $conf_by_zone) {
191             # dbg("async: searching for by_zone settings for $zone");
192 0         0 $zone =~ s/^\.//; $zone =~ s/\.\z//; # strip leading and trailing dot
  0         0  
193 0         0 for (;;) { # 2.10.example.com, 10.example.com, example.com, com, ''
194 0 0       0 if (exists $conf_by_zone->{$zone}) {
    0          
195 0         0 $settings = $conf_by_zone->{$zone};
196 0         0 last;
197             } elsif ($zone eq '') {
198 0         0 last;
199             } else { # strip one level, careful with address literals
200 0 0       0 $zone = ($zone =~ /^( (?: [^.] | \[ (?: \\. | [^\]\\] )* \] )* )
201             \. (.*) \z/xs) ? $2 : '';
202             }
203             }
204             }
205              
206 13 50       24 dbg("async: applying by_zone settings for %s", $zone) if $settings;
207              
208 13         20 my $t_init = $ent->{timeout_initial}; # application-specified has precedence
209 13 50 33     30 $t_init = $settings->{rbl_timeout} if $settings && !defined $t_init;
210 13 50       38 $t_init = $self->{main}->{conf}->{rbl_timeout} if !defined $t_init;
211 13 50       30 $t_init = 0 if !defined $t_init; # last-resort default, just in case
212              
213 13         19 my $t_end = $ent->{timeout_min}; # application-specified has precedence
214 13 50 33     32 $t_end = $settings->{rbl_timeout_min} if $settings && !defined $t_end;
215 13 50       35 $t_end = $self->{main}->{conf}->{rbl_timeout_min} if !defined $t_end; # added for bug 7070
216 13 50       35 $t_end = 0.2 * $t_init if !defined $t_end;
217 13 50       33 $t_end = 0 if $t_end < 0; # just in case
218 13 50       36 $t_init = $t_end if $t_init < $t_end;
219              
220 13         20 my $clipped_by_master_deadline = 0;
221 13 50       26 if (defined $master_deadline) {
222 13         29 my $time_avail = $master_deadline - time;
223 13 50       29 $time_avail = 0.5 if $time_avail < 0.5; # give some slack
224 13 50       26 if ($t_init > $time_avail) {
225 0         0 $t_init = $time_avail; $clipped_by_master_deadline = 1;
  0         0  
226 0 0       0 $t_end = $time_avail if $t_end > $time_avail;
227             }
228             }
229 13         27 $ent->{timeout_initial} = $t_init;
230 13         24 $ent->{timeout_min} = $t_end;
231              
232             $ent->{display_id} = # identifies entry in debug logging and similar
233 65         143 join(", ", grep { defined }
234 13 50       24 map { ref $ent->{$_} ? @{$ent->{$_}} : $ent->{$_} }
  65         144  
  0         0  
235             qw(sets rules rulename type key) );
236              
237 13         44 $self->{pending_lookups}->{$key} = $ent;
238              
239 13         38 $self->{queries_started}++;
240 13         24 $self->{total_queries_started}++;
241             dbg("async: starting: %s (timeout %.1fs, min %.1fs)%s",
242             $ent->{display_id}, $ent->{timeout_initial}, $ent->{timeout_min},
243 13 50       55 !$clipped_by_master_deadline ? '' : ', capped by time limit');
244              
245 13         27 $ent;
246             }
247              
248             # ---------------------------------------------------------------------------
249              
250             =item $ent = $async->bgsend_and_start_lookup($domain, $type, $class, $ent, $cb, %options)
251              
252             A common idiom: calls C<bgsend>, followed by a call to C<start_lookup>,
253             returning the argument $ent object as modified by C<start_lookup> and
254             filled-in with a query ID.
255              
256             =cut
257              
258             sub bgsend_and_start_lookup {
259 135     135 1 340 my($self, $domain, $type, $class, $ent, $cb, %options) = @_;
260 135 50       256 $ent = {} if !$ent;
261 135         411 $domain =~ s/\.+\z//s; # strip trailing dots, these sometimes still sneak in
262 135         248 $ent->{id} = undef;
263 135         254 $ent->{query_type} = $type;
264 135         285 $ent->{query_domain} = $domain;
265 135 50       264 $ent->{type} = $type if !exists $ent->{type};
266 135 50       196 $cb = $ent->{completed_callback} if !$cb; # compatibility with SA < 3.4
267              
268 135   50     237 my $key = $ent->{key} || '';
269              
270 135         311 my $dnskey = uc($type) . '/' . lc($domain);
271 135         217 my $dns_query_info = $self->{all_lookups}{$dnskey};
272              
273 135 100       227 if ($dns_query_info) { # DNS query already underway or completed
274 122         194 my $id = $ent->{id} = $dns_query_info->{id}; # re-use existing query
275 122 50       198 return if !defined $id; # presumably blocked, or other fatal failure
276 122         177 my $id_tail = $id; $id_tail =~ s{^\d+/IN/}{};
  122         421  
277 122 50       290 lc($id_tail) eq lc($dnskey)
278             or info("async: unmatched id %s, key=%s", $id, $dnskey);
279              
280 122         167 my $pkt = $dns_query_info->{pkt};
281 122 50       179 if (!$pkt) { # DNS query underway, still waiting for results
282             # just add our query to the existing one
283 122         133 push(@{$dns_query_info->{applicants}}, [$ent,$cb]);
  122         320  
284             dbg("async: query %s already underway, adding no.%d %s",
285 122         334 $id, scalar @{$dns_query_info->{applicants}},
286 122   33     159 $ent->{rulename} || $key);
287              
288             } else { # DNS query already completed, re-use results
289             # answer already known, just do the callback and be done with it
290 0 0       0 if (!$cb) {
291 0         0 dbg("async: query %s already done, re-using for %s", $id, $key);
292             } else {
293 0         0 dbg("async: query %s already done, re-using for %s, callback",
294             $id, $key);
295             eval {
296 0         0 $cb->($ent, $pkt); 1;
  0         0  
297 0 0       0 } or do {
298 0         0 chomp $@;
299             # resignal if alarm went off
300 0 0       0 die "async: (1) $@\n" if $@ =~ /__alarm__ignore__\(.*\)/s;
301 0         0 warn sprintf("query %s completed, callback %s failed: %s\n",
302             $id, $key, $@);
303             };
304             }
305             }
306             }
307              
308             else { # no existing query, open a new DNS query
309 13         35 $dns_query_info = $self->{all_lookups}{$dnskey} = {}; # new query needed
310 13         23 my($id, $blocked);
311 13         30 my $dns_query_blockages = $self->{main}->{conf}->{dns_query_blocked};
312 13 50       30 if ($dns_query_blockages) {
313 0         0 my $search_list = domain_to_search_list($domain);
314 0         0 foreach my $parent_domain (@$search_list) {
315 0         0 $blocked = $dns_query_blockages->{$parent_domain};
316 0 0       0 last if defined $blocked; # stop at first defined, can be true or false
317             }
318             }
319 13 50       23 if ($blocked) {
320 0         0 dbg("async: blocked by dns_query_restriction: %s", $dnskey);
321             } else {
322 13         48 dbg("async: launching %s for %s", $dnskey, $key);
323             $id = $self->{main}->{resolver}->bgsend($domain, $type, $class, sub {
324 13     13   29 my($pkt, $pkt_id, $timestamp) = @_;
325             # this callback sub is called from DnsResolver::poll_responses()
326             # dbg("async: in a bgsend_and_start_lookup callback, id %s", $pkt_id);
327 13 50       34 if ($pkt_id ne $id) {
328 0         0 warn "async: mismatched dns id: got $pkt_id, expected $id\n";
329 0         0 return;
330             }
331 13         53 $self->set_response_packet($pkt_id, $pkt, $ent->{key}, $timestamp);
332 13         24 $dns_query_info->{pkt} = $pkt;
333 13         19 my $cb_count = 0;
334 13         17 foreach my $tuple (@{$dns_query_info->{applicants}}) {
  13         35  
335 135         251 my($appl_ent, $appl_cb) = @$tuple;
336 135 50       226 if ($appl_cb) {
337             dbg("async: calling callback on key %s%s", $key,
338             !defined $appl_ent->{rulename} ? ''
339 135 50       480 : ", rule ".$appl_ent->{rulename});
340 135         186 $cb_count++;
341             eval {
342 135         362 $appl_cb->($appl_ent, $pkt); 1;
  135         382  
343 135 50       185 } or do {
344 0         0 chomp $@;
345             # resignal if alarm went off
346 0 0       0 die "async: (2) $@\n" if $@ =~ /__alarm__ignore__\(.*\)/s;
347             warn sprintf("query %s completed, callback %s failed: %s\n",
348 0         0 $id, $appl_ent->{key}, $@);
349             };
350             }
351             }
352 13         256 delete $dns_query_info->{applicants};
353 13 50       45 dbg("async: query $id completed, no callbacks run") if !$cb_count;
354 13         157 });
355             }
356 13 50       32 return if !defined $id;
357 13         35 $dns_query_info->{id} = $ent->{id} = $id;
358 13         24 push(@{$dns_query_info->{applicants}}, [$ent,$cb]);
  13         47  
359 13         40 $self->start_lookup($ent, $options{master_deadline});
360             }
361 135         334 return $ent;
362             }
363              
364             # ---------------------------------------------------------------------------
365              
366             =item $ent = $async->get_lookup($key)
367              
368             Retrieve the pending-lookup object for the given key C<$key>.
369              
370             If the lookup is complete, this will return C<undef>.
371              
372             Note that a lookup is still considered "pending" until C<complete_lookups()> is
373             called, even if it has been reported as complete via C<set_response_packet()>.
374              
375             =cut
376              
377             sub get_lookup {
378 0     0 1 0 my ($self, $key) = @_;
379 0         0 return $self->{pending_lookups}->{$key};
380             }
381              
382             # ---------------------------------------------------------------------------
383              
384             =item $async->log_lookups_timing()
385              
386             Log sorted timing for all completed lookups.
387              
388             =cut
389              
390             sub log_lookups_timing {
391 96     96 1 301 my ($self) = @_;
392 96         217 my $timings = $self->{timing_by_query};
393 96         512 for my $key (sort { $timings->{$a} <=> $timings->{$b} } keys %$timings) {
  15         38  
394 13         27 dbg("async: timing: %.3f %s", $timings->{$key}, $key);
395             }
396             }
397              
398             # ---------------------------------------------------------------------------
399              
400             =item $alldone = $async->complete_lookups()
401              
402             Perform a poll of the pending lookups, to see if any are completed.
403             Callbacks on completed queries will be called from poll_responses().
404              
405             If there are no lookups remaining, or if too much time has elapsed since
406             any results were returned, C<1> is returned, otherwise C<0>.
407              
408             =cut
409              
410             sub complete_lookups {
411 3064     3064 1 4560 my ($self, $timeout, $allow_aborting_of_expired) = @_;
412 3064         3601 my $alldone = 0;
413 3064         3359 my $anydone = 0;
414 3064         3889 my $allexpired = 1;
415 3064         3550 my %typecount;
416              
417 3064         4834 my $pending = $self->{pending_lookups};
418 3064         4033 $self->{queries_started} = 0;
419 3064         3787 $self->{queries_completed} = 0;
420              
421 3064         5999 my $now = time;
422              
423 3064 50 66     10272 if (defined $timeout && $timeout > 0 &&
      66        
      66        
424             %$pending && $self->{total_queries_started} > 0)
425             {
426             # shrink a 'select' timeout if a caller specified unnecessarily long
427             # value beyond the latest deadline of any outstanding request;
428             # can save needless wait time (up to 1 second in harvest_dnsbl_queries)
429 1         5 my $r = $self->{total_queries_completed} / $self->{total_queries_started};
430 1         3 my $r2 = $r * $r; # 0..1
431 1         3 my $max_deadline;
432 1         7 while (my($key,$ent) = each %$pending) {
433 2         5 my $t_init = $ent->{timeout_initial};
434 2         3 my $dt = $t_init - ($t_init - $ent->{timeout_min}) * $r2;
435 2         7 my $deadline = $ent->{start_time} + $dt;
436 2 50 66     25 $max_deadline = $deadline if !defined $max_deadline ||
437             $deadline > $max_deadline;
438             }
439 1 50       5 if (defined $max_deadline) {
440             # adjust to timer resolution, only deals with 1s and with fine resolution
441 1 50 33     6 $max_deadline = 1 + int $max_deadline
442             if $timer_resolution == 1 && $max_deadline > int $max_deadline;
443 1         3 my $sufficient_timeout = $max_deadline - $now;
444 1 50       5 $sufficient_timeout = 0 if $sufficient_timeout < 0;
445 1 50       4 if ($timeout > $sufficient_timeout) {
446 0         0 dbg("async: reducing select timeout from %.1f to %.1f s",
447             $timeout, $sufficient_timeout);
448 0         0 $timeout = $sufficient_timeout;
449             }
450             }
451             }
452              
453             # trap this loop in an eval { } block, as Net::DNS could throw
454             # die()s our way; in particular, process_dnsbl_results() has
455             # thrown die()s before (bug 3794).
456             eval {
457              
458 3064 100       5513 if (%$pending) { # any outstanding requests still?
459 5         16 $self->{last_poll_responses_time} = $now;
460 5         38 my $nfound = $self->{main}->{resolver}->poll_responses($timeout);
461 5 50       27 dbg("async: select found %s responses ready (t.o.=%.1f)",
462             !$nfound ? 'no' : $nfound, $timeout);
463             }
464 3064         5958 $now = time; # capture new timestamp, after possible sleep in 'select'
465              
466             # A callback routine may generate another DNS query, which may insert
467             # an entry into the %$pending hash thus invalidating the each() context.
468             # So, make sure that callbacks are not called while the each() context
469             # is open. [Bug 6937]
470             #
471 3064         8033 while (my($key,$ent) = each %$pending) {
472 17         30 my $id = $ent->{id};
473 17 100       50 if (exists $self->{finished}->{$id}) {
474 13         25 delete $self->{finished}->{$id};
475 13         20 $anydone = 1;
476 13 50       28 $ent->{finish_time} = $now if !defined $ent->{finish_time};
477 13         22 my $elapsed = $ent->{finish_time} - $ent->{start_time};
478 13         33 dbg("async: completed in %.3f s: %s", $elapsed, $ent->{display_id});
479 13         41 $self->{timing_by_query}->{". $key"} += $elapsed;
480 13         18 $self->{queries_completed}++;
481 13         17 $self->{total_queries_completed}++;
482 13         73 delete $pending->{$key};
483             }
484             }
485              
486 3064 100       5662 if (%$pending) { # still any requests outstanding? are they expired?
487             my $r =
488             !$allow_aborting_of_expired || !$self->{total_queries_started} ? 1.0
489 2 100 66     40 : $self->{total_queries_completed} / $self->{total_queries_started};
490 2         7 my $r2 = $r * $r; # 0..1
491 2         10 while (my($key,$ent) = each %$pending) {
492 4         11 $typecount{$ent->{type}}++;
493 4         6 my $t_init = $ent->{timeout_initial};
494 4         9 my $dt = $t_init - ($t_init - $ent->{timeout_min}) * $r2;
495             # adjust to timer resolution, only deals with 1s and fine resolution
496 4 50 33     14 $dt = 1 + int $dt if $timer_resolution == 1 && $dt > int $dt;
497 4 50       20 $allexpired = 0 if $now <= $ent->{start_time} + $dt;
498             }
499             dbg("async: queries completed: %d, started: %d",
500 2         15 $self->{queries_completed}, $self->{queries_started});
501             }
502              
503             # ensure we don't get stuck if a request gets lost in the ether.
504 3064 100 33     5327 if (! %$pending) {
    50          
505 3062         3706 $alldone = 1;
506             }
507             elsif ($allexpired && $allow_aborting_of_expired) {
508             # avoid looping forever if we haven't got all results.
509 0         0 dbg("async: escaping: lost or timed out requests or responses");
510 0         0 $self->abort_remaining_lookups();
511 0         0 $alldone = 1;
512             }
513             else {
514             dbg("async: queries active: %s%s at %s",
515 2 50       8 join (' ', map { "$_=$typecount{$_}" } sort keys %typecount),
  2         109  
516             $allexpired ? ', all expired' : '', scalar(localtime(time)));
517 2         5 $alldone = 0;
518             }
519 3064         6045 1;
520              
521 3064 50       4490 } or do {
522 0 0       0 my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
  0         0  
523             # resignal if alarm went off
524 0 0       0 die "async: (3) $eval_stat\n" if $eval_stat =~ /__alarm__ignore__\(.*\)/s;
525 0         0 dbg("async: caught complete_lookups death, aborting: %s", $eval_stat);
526 0         0 $alldone = 1; # abort remaining
527             };
528              
529 3064 50       9217 return wantarray ? ($alldone,$anydone) : $alldone;
530             }
531              
532             # ---------------------------------------------------------------------------
533              
534             =item $async->abort_remaining_lookups()
535              
536             Abort any remaining lookups.
537              
538             =cut
539              
540             sub abort_remaining_lookups {
541 96     96 1 276 my ($self) = @_;
542              
543 96         220 my $pending = $self->{pending_lookups};
544 96         230 my $foundcnt = 0;
545 96         265 my $now = time;
546              
547 96         370 while (my($key,$ent) = each %$pending) {
548             dbg("async: aborting after %.3f s, %s: %s",
549             $now - $ent->{start_time},
550             (defined $ent->{timeout_initial} &&
551             $now > $ent->{start_time} + $ent->{timeout_initial}
552             ? 'past original deadline' : 'deadline shrunk'),
553 0 0 0     0 $ent->{display_id} );
554 0         0 $foundcnt++;
555 0         0 $self->{timing_by_query}->{"X $key"} = $now - $ent->{start_time};
556 0 0       0 $ent->{finish_time} = $now if !defined $ent->{finish_time};
557 0         0 delete $pending->{$key};
558             }
559              
560             # call any remaining callbacks, indicating the query has been aborted
561             #
562 96         244 my $all_lookups_ref = $self->{all_lookups};
563 96         419 foreach my $dnskey (keys %$all_lookups_ref) {
564 13         21 my $dns_query_info = $all_lookups_ref->{$dnskey};
565 13         47 my $cb_count = 0;
566 13         18 foreach my $tuple (@{$dns_query_info->{applicants}}) {
  13         32  
567 0         0 my($ent, $cb) = @$tuple;
568 0 0       0 if ($cb) {
569             dbg("async: calling callback/abort on key %s%s", $dnskey,
570 0 0       0 !defined $ent->{rulename} ? '' : ", rule ".$ent->{rulename});
571 0         0 $cb_count++;
572             eval {
573 0         0 $cb->($ent, undef); 1;
  0         0  
574 0 0       0 } or do {
575 0         0 chomp $@;
576             # resignal if alarm went off
577 0 0       0 die "async: (2) $@\n" if $@ =~ /__alarm__ignore__\(.*\)/s;
578             warn sprintf("query %s aborted, callback %s failed: %s\n",
579 0         0 $dnskey, $ent->{key}, $@);
580             };
581             }
582 0 0       0 dbg("async: query $dnskey aborted, no callbacks run") if !$cb_count;
583             }
584 13         25 delete $dns_query_info->{applicants};
585             }
586              
587 96 50       303 dbg("async: aborted %d remaining lookups", $foundcnt) if $foundcnt > 0;
588 96         179 delete $self->{last_poll_responses_time};
589 96         891 $self->{main}->{resolver}->bgabort();
590 96         227 1;
591             }
592              
593             # ---------------------------------------------------------------------------
594              
595             =item $async->set_response_packet($id, $pkt, $key, $timestamp)
596              
597             Register a "response packet" for a given query. C<$id> is the ID for the
598             query, and must match the C<id> supplied in C<start_lookup()>. C<$pkt> is the
599             packet object for the response. A parameter C<$key> identifies an entry in a
600             hash %{$self->{pending_lookups}} where the object which spawned this query can
601             be found, and through which futher information about the query is accessible.
602              
603             C<$pkt> may be undef, indicating that no response packet is available, but a
604             query has completed (e.g. was aborted or dismissed) and is no longer "pending".
605              
606             The DNS resolver's response packet C<$pkt> will be made available to a callback
607             subroutine through its argument as well as in C<$ent-<gt>{response_packet}>.
608              
609             =cut
610              
611             sub set_response_packet {
612 13     13 1 34 my ($self, $id, $pkt, $key, $timestamp) = @_;
613 13         36 $self->{finished}->{$id} = 1; # only key existence matters, any value
614 13 50       32 $timestamp = time if !defined $timestamp;
615 13         20 my $pending = $self->{pending_lookups};
616 13 50       31 if (!defined $key) { # backward compatibility with 3.2.3 and older plugins
617             # a third-party plugin did not provide $key in a call, search for it:
618 0 0       0 if ($id eq $pending->{$id}->{id}) { # I feel lucky, key==id ?
619 0         0 $key = $id;
620             } else { # then again, maybe not, be more systematic
621 0         0 for my $tkey (keys %$pending) {
622 0 0       0 if ($id eq $pending->{$tkey}->{id}) { $key = $tkey; last }
  0         0  
  0         0  
623             }
624             }
625 0         0 dbg("async: got response on id $id, search found key $key");
626             }
627 13 50       29 if (!defined $key) {
628 0         0 info("async: no key, response packet not remembered, id $id");
629             } else {
630 13         26 my $ent = $pending->{$key};
631 13         21 my $ent_id = $ent->{id};
632 13 50       33 if (!defined $ent_id) {
    50          
633             # should not happen, troubleshooting
634 0         0 info("async: ignoring response, id %s, ent_id is undef: %s",
635             $id, join(', ', %$ent));
636             } elsif ($id ne $ent_id) {
637 0         0 info("async: ignoring response, mismatched id $id, expected $ent_id");
638             } else {
639 13         35 $ent->{finish_time} = $timestamp;
640 13         37 $ent->{response_packet} = $pkt;
641             }
642             }
643 13         25 1;
644             }
645              
646             =item $async->report_id_complete($id,$key,$key,$timestamp)
647              
648             Legacy. Equivalent to $self->set_response_packet($id,undef,$key,$timestamp),
649             i.e. providing undef as a response packet. Register that a query has
650             completed and is no longer "pending". C<$id> is the ID for the query,
651             and must match the C<id> supplied in C<start_lookup()>.
652              
653             One or the other of C<set_response_packet()> or C<report_id_complete()>
654             should be called, but not both.
655              
656             =cut
657              
658             sub report_id_complete {
659 0     0 1 0 my ($self, $id, $key, $timestamp) = @_;
660 0         0 $self->set_response_packet($id, undef, $key, $timestamp);
661             }
662              
663             # ---------------------------------------------------------------------------
664              
665             =item $time = $async->last_poll_responses_time()
666              
667             Get the time of the last call to C<poll_responses()> (which is called
668             from C<complete_lookups()>. If C<poll_responses()> was never called or
669             C<abort_remaining_lookups()> has been called C<last_poll_responses_time()>
670             will return undef.
671              
672             =cut
673              
674             sub last_poll_responses_time {
675 3000     3000 1 4450 my ($self) = @_;
676 3000         5257 return $self->{last_poll_responses_time};
677             }
678              
679             1;
680              
681             =back
682              
683             =cut