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