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 |