← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Tue Nov 7 05:38:10 2017
Reported on Tue Nov 7 06:16:01 2017

Filename/usr/local/lib/perl5/site_perl/Mail/SpamAssassin/AsyncLoop.pm
StatementsExecuted 305169 statements in 1.82s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
8743311.23s6.88sMail::SpamAssassin::AsyncLoop::::bgsend_and_start_lookupMail::SpamAssassin::AsyncLoop::bgsend_and_start_lookup
196811357ms392msMail::SpamAssassin::AsyncLoop::::start_lookupMail::SpamAssassin::AsyncLoop::start_lookup
1551821127ms127msMail::SpamAssassin::AsyncLoop::::CORE:substMail::SpamAssassin::AsyncLoop::CORE:subst (opcode)
4701115.3ms15.3msMail::SpamAssassin::AsyncLoop::::newMail::SpamAssassin::AsyncLoop::new
11165µs180µsMail::SpamAssassin::AsyncLoop::::BEGIN@49Mail::SpamAssassin::AsyncLoop::BEGIN@49
11155µs68µsMail::SpamAssassin::AsyncLoop::::BEGIN@36Mail::SpamAssassin::AsyncLoop::BEGIN@36
11128µs102µsMail::SpamAssassin::AsyncLoop::::BEGIN@50Mail::SpamAssassin::AsyncLoop::BEGIN@50
11128µs33µsMail::SpamAssassin::AsyncLoop::::BEGIN@38Mail::SpamAssassin::AsyncLoop::BEGIN@38
11127µs83µsMail::SpamAssassin::AsyncLoop::::BEGIN@39Mail::SpamAssassin::AsyncLoop::BEGIN@39
11124µs24µsMail::SpamAssassin::AsyncLoop::::BEGIN@43Mail::SpamAssassin::AsyncLoop::BEGIN@43
11122µs60µsMail::SpamAssassin::AsyncLoop::::BEGIN@37Mail::SpamAssassin::AsyncLoop::BEGIN@37
11122µs393µsMail::SpamAssassin::AsyncLoop::::BEGIN@41Mail::SpamAssassin::AsyncLoop::BEGIN@41
11120µs205µsMail::SpamAssassin::AsyncLoop::::BEGIN@44Mail::SpamAssassin::AsyncLoop::BEGIN@44
0000s0sMail::SpamAssassin::AsyncLoop::::__ANON__[:354]Mail::SpamAssassin::AsyncLoop::__ANON__[:354]
0000s0sMail::SpamAssassin::AsyncLoop::::abort_remaining_lookupsMail::SpamAssassin::AsyncLoop::abort_remaining_lookups
0000s0sMail::SpamAssassin::AsyncLoop::::complete_lookupsMail::SpamAssassin::AsyncLoop::complete_lookups
0000s0sMail::SpamAssassin::AsyncLoop::::domain_to_search_listMail::SpamAssassin::AsyncLoop::domain_to_search_list
0000s0sMail::SpamAssassin::AsyncLoop::::get_lookupMail::SpamAssassin::AsyncLoop::get_lookup
0000s0sMail::SpamAssassin::AsyncLoop::::last_poll_responses_timeMail::SpamAssassin::AsyncLoop::last_poll_responses_time
0000s0sMail::SpamAssassin::AsyncLoop::::log_lookups_timingMail::SpamAssassin::AsyncLoop::log_lookups_timing
0000s0sMail::SpamAssassin::AsyncLoop::::report_id_completeMail::SpamAssassin::AsyncLoop::report_id_complete
0000s0sMail::SpamAssassin::AsyncLoop::::set_response_packetMail::SpamAssassin::AsyncLoop::set_response_packet
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 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
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
36274µs282µs
# spent 68µs (55+14) within Mail::SpamAssassin::AsyncLoop::BEGIN@36 which was called: # once (55µs+14µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 36
use strict;
# spent 68µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@36 # spent 14µs making 1 call to strict::import
37265µs299µs
# spent 60µs (22+38) within Mail::SpamAssassin::AsyncLoop::BEGIN@37 which was called: # once (22µs+38µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 37
use warnings;
# spent 60µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@37 # spent 38µs making 1 call to warnings::import
38272µs238µs
# spent 33µs (28+5) within Mail::SpamAssassin::AsyncLoop::BEGIN@38 which was called: # once (28µs+5µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 38
use bytes;
# spent 33µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@38 # spent 5µs making 1 call to bytes::import
39266µs2139µs
# spent 83µs (27+56) within Mail::SpamAssassin::AsyncLoop::BEGIN@39 which was called: # once (27µs+56µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 39
use re 'taint';
# spent 83µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@39 # spent 56µs making 1 call to re::import
40
41274µs2764µs
# spent 393µs (22+371) within Mail::SpamAssassin::AsyncLoop::BEGIN@41 which was called: # once (22µs+371µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 41
use Time::HiRes qw(time);
# spent 393µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@41 # spent 371µs making 1 call to Time::HiRes::import
42
43264µs124µs
# spent 24µs within Mail::SpamAssassin::AsyncLoop::BEGIN@43 which was called: # once (24µs+0s) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 43
use Mail::SpamAssassin;
# spent 24µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@43
442102µs2391µs
# spent 205µs (20+186) within Mail::SpamAssassin::AsyncLoop::BEGIN@44 which was called: # once (20µs+186µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 44
use Mail::SpamAssassin::Logger;
# spent 205µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@44 # spent 186µs making 1 call to Exporter::import
45
46110µsour @ISA = qw();
47
48# obtain timer resolution if possible
49
# spent 180µs (65+115) within Mail::SpamAssassin::AsyncLoop::BEGIN@49 which was called: # once (65µs+115µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 59
BEGIN {
502138µs2177µs
# spent 102µs (28+74) within Mail::SpamAssassin::AsyncLoop::BEGIN@50 which was called: # once (28µs+74µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@60 at line 50
use vars qw($timer_resolution);
# spent 102µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@50 # spent 74µs making 1 call to vars::import
51 eval {
52154µs3104µs $timer_resolution = Time::HiRes->can('clock_getres')
# spent 87µs making 1 call to Time::HiRes::AUTOLOAD # spent 11µs making 1 call to Time::HiRes::clock_getres # spent 5µs making 1 call to UNIVERSAL::can
53 ? Time::HiRes::clock_getres(Time::HiRes::CLOCK_REALTIME())
54 : 0.001; # wild guess, assume resolution is better than 1s
5512µs 1;
56113µs } or do {
57 $timer_resolution = 1; # Perl's builtin timer ticks at one second
58 };
5915.71ms1180µs}
# spent 180µs making 1 call to Mail::SpamAssassin::AsyncLoop::BEGIN@49
60
61#############################################################################
62
63
# spent 15.3ms within Mail::SpamAssassin::AsyncLoop::new which was called 470 times, avg 33µs/call: # 470 times (15.3ms+0s) by Mail::SpamAssassin::PerMsgStatus::new at line 279 of Mail/SpamAssassin/PerMsgStatus.pm, avg 33µs/call
sub new {
64 # called from PerMsgStatus, a new AsyncLoop object is created
65 # for each new message processing
664701.16ms my $class = shift;
674701.17ms $class = ref($class) || $class;
68
694701.05ms my ($main) = @_;
704707.47ms 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
814701.36ms bless ($self, $class);
824703.87ms $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
174
# spent 392ms (357+35.0) within Mail::SpamAssassin::AsyncLoop::start_lookup which was called 1968 times, avg 199µs/call: # 1968 times (357ms+35.0ms) by Mail::SpamAssassin::AsyncLoop::bgsend_and_start_lookup at line 359, avg 199µs/call
sub start_lookup {
17519684.22ms my ($self, $ent, $master_deadline) = @_;
176
17719685.93ms my $id = $ent->{id};
17819685.07ms my $key = $ent->{key};
17919685.33ms defined $id && $id ne '' or die "oops, no id";
18019684.01ms $key or die "oops, no key";
18119684.23ms $ent->{type} or die "oops, no type";
182
183196834.5ms196812.6ms my $now = time;
# spent 12.6ms making 1968 calls to Time::HiRes::time, avg 6µs/call
18419685.91ms $ent->{start_time} = $now if !defined $ent->{start_time};
185
186 # are there any applicable per-zone settings?
18719685.18ms my $zone = $ent->{zone};
18819683.43ms my $settings; # a ref to a by-zone or to global settings
18919686.39ms my $conf_by_zone = $self->{main}->{conf}->{by_zone};
19019683.81ms 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
20619683.64ms dbg("async: applying by_zone settings for %s", $zone) if $settings;
207
20819684.11ms my $t_init = $ent->{timeout_initial}; # application-specified has precedence
20919683.26ms $t_init = $settings->{rbl_timeout} if $settings && !defined $t_init;
21019685.79ms $t_init = $self->{main}->{conf}->{rbl_timeout} if !defined $t_init;
21119683.36ms $t_init = 0 if !defined $t_init; # last-resort default, just in case
212
21319684.08ms my $t_end = $ent->{timeout_min}; # application-specified has precedence
21419683.31ms $t_end = $settings->{rbl_timeout_min} if $settings && !defined $t_end;
21519685.06ms $t_end = $self->{main}->{conf}->{rbl_timeout_min} if !defined $t_end; # added for bug 7070
21619685.76ms $t_end = 0.2 * $t_init if !defined $t_end;
21719684.55ms $t_end = 0 if $t_end < 0; # just in case
21819683.44ms $t_init = $t_end if $t_init < $t_end;
219
22019683.95ms my $clipped_by_master_deadline = 0;
22119686.83ms if (defined $master_deadline) {
222196836.6ms19689.21ms my $time_avail = $master_deadline - time;
# spent 9.21ms making 1968 calls to Time::HiRes::time, avg 5µs/call
22319683.79ms $time_avail = 0.5 if $time_avail < 0.5; # give some slack
22419684.45ms 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 }
22919687.89ms $ent->{timeout_initial} = $t_init;
230196810.8ms $ent->{timeout_min} = $t_end;
231
232 $ent->{display_id} = # identifies entry in debug logging and similar
233984026.2ms join(", ", grep { defined }
2341180887.2ms map { ref $ent->{$_} ? @{$ent->{$_}} : $ent->{$_} }
235 qw(sets rules rulename type key) );
236
237196813.8ms $self->{pending_lookups}->{$key} = $ent;
238
23919684.01ms $self->{queries_started}++;
24019683.82ms $self->{total_queries_started}++;
241 dbg("async: starting: %s (timeout %.1fs, min %.1fs)%s",
242 $ent->{display_id}, $ent->{timeout_initial}, $ent->{timeout_min},
243196814.9ms196813.2ms !$clipped_by_master_deadline ? '' : ', capped by time limit');
# spent 13.2ms making 1968 calls to Mail::SpamAssassin::Logger::dbg, avg 7µs/call
244
245196820.9ms $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
258
# spent 6.88s (1.23+5.65) within Mail::SpamAssassin::AsyncLoop::bgsend_and_start_lookup which was called 8743 times, avg 787µs/call: # 8043 times (1.14s+3.89s) by Mail::SpamAssassin::Plugin::URIDNSBL::lookup_single_dnsbl at line 1071 of Mail/SpamAssassin/Plugin/URIDNSBL.pm, avg 625µs/call # 383 times (52.0ms+960ms) by Mail::SpamAssassin::Plugin::URIDNSBL::lookup_a_record at line 999 of Mail/SpamAssassin/Plugin/URIDNSBL.pm, avg 2.64ms/call # 317 times (43.6ms+796ms) by Mail::SpamAssassin::Plugin::URIDNSBL::lookup_domain_ns at line 914 of Mail/SpamAssassin/Plugin/URIDNSBL.pm, avg 2.65ms/call
sub bgsend_and_start_lookup {
259874365.7ms my($self, $domain, $type, $class, $ent, $cb, %options) = @_;
260874314.6ms $ent = {} if !$ent;
2618743186ms874359.0ms $domain =~ s/\.+\z//s; # strip trailing dots, these sometimes still sneak in
# spent 59.0ms making 8743 calls to Mail::SpamAssassin::AsyncLoop::CORE:subst, avg 7µs/call
262874323.5ms $ent->{id} = undef;
263874332.3ms $ent->{query_type} = $type;
264874371.4ms $ent->{query_domain} = $domain;
265874315.6ms $ent->{type} = $type if !exists $ent->{type};
266874315.5ms $cb = $ent->{completed_callback} if !$cb; # compatibility with SA < 3.4
267
268874359.7ms my $key = $ent->{key} || '';
269
270874365.1ms my $dnskey = uc($type) . '/' . lc($domain);
271874322.0ms my $dns_query_info = $self->{all_lookups}{$dnskey};
272
273874330.5ms if ($dns_query_info) { # DNS query already underway or completed
274677565.1ms my $id = $ent->{id} = $dns_query_info->{id}; # re-use existing query
275677511.3ms return if !defined $id; # presumably blocked, or other fatal failure
27613550177ms677568.4ms my $id_tail = $id; $id_tail =~ s{^\d+/IN/}{};
# spent 68.4ms making 6775 calls to Mail::SpamAssassin::AsyncLoop::CORE:subst, avg 10µs/call
277677518.7ms lc($id_tail) eq lc($dnskey)
278 or info("async: unmatched id %s, key=%s", $id, $dnskey);
279
280677513.9ms my $pkt = $dns_query_info->{pkt};
281677530.4ms if (!$pkt) { # DNS query underway, still waiting for results
282 # just add our query to the existing one
2831355075.2ms push(@{$dns_query_info->{applicants}}, [$ent,$cb]);
284 dbg("async: query %s already underway, adding no.%d %s",
285677512.3ms $id, scalar @{$dns_query_info->{applicants}},
286677573.2ms677558.6ms $ent->{rulename} || $key);
# spent 58.6ms making 6775 calls to Mail::SpamAssassin::Logger::dbg, avg 9µs/call
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
309196820.8ms $dns_query_info = $self->{all_lookups}{$dnskey} = {}; # new query needed
31019683.30ms my($id, $blocked);
31119686.80ms my $dns_query_blockages = $self->{main}->{conf}->{dns_query_blocked};
31219683.26ms 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 }
31919687.63ms if ($blocked) {
320 dbg("async: blocked by dns_query_restriction: %s", $dnskey);
321 } else {
322196814.4ms196813.8ms dbg("async: launching %s for %s", $dnskey, $key);
# spent 13.8ms making 1968 calls to Mail::SpamAssassin::Logger::dbg, avg 7µs/call
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;
354196845.7ms19685.06s });
# spent 5.06s making 1968 calls to Mail::SpamAssassin::DnsResolver::bgsend, avg 2.57ms/call
355 }
35619684.09ms return if !defined $id;
35719688.64ms $dns_query_info->{id} = $ent->{id} = $id;
358393615.9ms push(@{$dns_query_info->{applicants}}, [$ent,$cb]);
359196817.4ms1968392ms $self->start_lookup($ent, $options{master_deadline});
# spent 392ms making 1968 calls to Mail::SpamAssassin::AsyncLoop::start_lookup, avg 199µs/call
360 }
3618743188ms 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 futher 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
679110µs1;
680
681=back
682
683=cut
 
# spent 127ms within Mail::SpamAssassin::AsyncLoop::CORE:subst which was called 15518 times, avg 8µs/call: # 8743 times (59.0ms+0s) by Mail::SpamAssassin::AsyncLoop::bgsend_and_start_lookup at line 261, avg 7µs/call # 6775 times (68.4ms+0s) by Mail::SpamAssassin::AsyncLoop::bgsend_and_start_lookup at line 276, avg 10µs/call
sub Mail::SpamAssassin::AsyncLoop::CORE:subst; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.