Filename | /usr/local/lib/perl5/site_perl/Mail/SpamAssassin/Timeout.pm |
Statements | Executed 21 statements in 2.32ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 41µs | 50µs | BEGIN@56 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 20µs | 76µs | BEGIN@64 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 20µs | 44µs | BEGIN@57 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 19µs | 154µs | BEGIN@62 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 19µs | 24µs | BEGIN@58 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 19µs | 285µs | BEGIN@61 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 18µs | 68µs | BEGIN@93 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 18µs | 68µs | BEGIN@59 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 17µs | 69µs | BEGIN@95 | Mail::SpamAssassin::Timeout::
1 | 1 | 1 | 8µs | 8µs | BEGIN@94 | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | __ANON__[:193] | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | _run | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | new | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | reset | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | run | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | run_and_catch | Mail::SpamAssassin::Timeout::
0 | 0 | 0 | 0s | 0s | timed_out | Mail::SpamAssassin::Timeout::
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 | |||||
20 | Mail::SpamAssassin::Timeout - safe, reliable timeouts in perl | ||||
21 | |||||
22 | =head1 SYNOPSIS | ||||
23 | |||||
24 | # non-timeout code... | ||||
25 | |||||
26 | my $t = Mail::SpamAssassin::Timeout->new({ secs => 5, deadline => $when }); | ||||
27 | |||||
28 | $t->run(sub { | ||||
29 | # code to run with a 5-second timeout... | ||||
30 | }); | ||||
31 | |||||
32 | if ($t->timed_out()) { | ||||
33 | # do something... | ||||
34 | } | ||||
35 | |||||
36 | # more non-timeout code... | ||||
37 | |||||
38 | =head1 DESCRIPTION | ||||
39 | |||||
40 | This module provides a safe, reliable and clean API to provide | ||||
41 | C<alarm(2)>-based timeouts for perl code. | ||||
42 | |||||
43 | Note that C<$SIG{ALRM}> is used to provide the timeout, so this will not | ||||
44 | interrupt out-of-control regular expression matches. | ||||
45 | |||||
46 | Nested timeouts are supported. | ||||
47 | |||||
48 | =head1 PUBLIC METHODS | ||||
49 | |||||
50 | =over 4 | ||||
51 | |||||
52 | =cut | ||||
53 | |||||
54 | package Mail::SpamAssassin::Timeout; | ||||
55 | |||||
56 | 2 | 62µs | 2 | 59µs | # spent 50µs (41+9) within Mail::SpamAssassin::Timeout::BEGIN@56 which was called:
# once (41µs+9µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 56 # spent 50µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@56
# spent 9µs making 1 call to strict::import |
57 | 2 | 52µs | 2 | 70µs | # spent 44µs (20+25) within Mail::SpamAssassin::Timeout::BEGIN@57 which was called:
# once (20µs+25µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 57 # spent 44µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@57
# spent 25µs making 1 call to warnings::import |
58 | 2 | 59µs | 2 | 30µs | # spent 24µs (19+5) within Mail::SpamAssassin::Timeout::BEGIN@58 which was called:
# once (19µs+5µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 58 # spent 24µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@58
# spent 5µs making 1 call to bytes::import |
59 | 2 | 57µs | 2 | 118µs | # spent 68µs (18+50) within Mail::SpamAssassin::Timeout::BEGIN@59 which was called:
# once (18µs+50µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 59 # spent 68µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@59
# spent 50µs making 1 call to re::import |
60 | |||||
61 | 2 | 54µs | 2 | 551µs | # spent 285µs (19+266) within Mail::SpamAssassin::Timeout::BEGIN@61 which was called:
# once (19µs+266µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 61 # spent 285µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@61
# spent 266µs making 1 call to Time::HiRes::import |
62 | 2 | 72µs | 2 | 290µs | # spent 154µs (19+135) within Mail::SpamAssassin::Timeout::BEGIN@62 which was called:
# once (19µs+135µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 62 # spent 154µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@62
# spent 135µs making 1 call to Exporter::import |
63 | |||||
64 | 1 | 3µs | # spent 76µs (20+56) within Mail::SpamAssassin::Timeout::BEGIN@64 which was called:
# once (20µs+56µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 66 | ||
65 | @ISA | ||||
66 | 1 | 116µs | 2 | 132µs | }; # spent 76µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@64
# spent 56µs making 1 call to vars::import |
67 | |||||
68 | 1 | 8µs | @ISA = qw(); | ||
69 | |||||
70 | ########################################################################### | ||||
71 | |||||
72 | =item my $t = Mail::SpamAssassin::Timeout->new({ ... options ... }); | ||||
73 | |||||
74 | Constructor. Options include: | ||||
75 | |||||
76 | =over 4 | ||||
77 | |||||
78 | =item secs => $seconds | ||||
79 | |||||
80 | time interval, in seconds. Optional; if neither C<secs> nor C<deadline> is | ||||
81 | specified, no timeouts will be applied. | ||||
82 | |||||
83 | =item deadline => $unix_timestamp | ||||
84 | |||||
85 | Unix timestamp (seconds since epoch) when a timeout is reached in the latest. | ||||
86 | Optional; if neither B<secs> nor B<deadline> is specified, no timeouts will | ||||
87 | be applied. If both are specified, the shorter interval of the two prevails. | ||||
88 | |||||
89 | =back | ||||
90 | |||||
91 | =cut | ||||
92 | |||||
93 | 2 | 56µs | 2 | 117µs | # spent 68µs (18+49) within Mail::SpamAssassin::Timeout::BEGIN@93 which was called:
# once (18µs+49µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 93 # spent 68µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@93
# spent 49µs making 1 call to vars::import |
94 | 1 | 47µs | 1 | 8µs | # spent 8µs within Mail::SpamAssassin::Timeout::BEGIN@94 which was called:
# once (8µs+0s) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 94 # spent 8µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@94 |
95 | 2 | 1.72ms | 2 | 121µs | # spent 69µs (17+52) within Mail::SpamAssassin::Timeout::BEGIN@95 which was called:
# once (17µs+52µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 95 # spent 69µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@95
# spent 52µs making 1 call to vars::import |
96 | |||||
97 | sub new { | ||||
98 | my ($class, $opts) = @_; | ||||
99 | $class = ref($class) || $class; | ||||
100 | my %selfval = $opts ? %{$opts} : (); | ||||
101 | $selfval{id} = ++$id_gen; | ||||
102 | my($package, $filename, $line, $subroutine) = caller(1); | ||||
103 | if (defined $subroutine) { | ||||
104 | $subroutine =~ s/^Mail::SpamAssassin::/::/; | ||||
105 | $selfval{id} = join('/', $id_gen, $subroutine, $line); | ||||
106 | } | ||||
107 | my $self = \%selfval; | ||||
108 | |||||
109 | bless ($self, $class); | ||||
110 | $self; | ||||
111 | } | ||||
112 | |||||
113 | ########################################################################### | ||||
114 | |||||
115 | =item $t->run($coderef) | ||||
116 | |||||
117 | Run a code reference within the currently-defined timeout. | ||||
118 | |||||
119 | The timeout is as defined by the B<secs> and B<deadline> parameters | ||||
120 | to the constructor. | ||||
121 | |||||
122 | Returns whatever the subroutine returns, or C<undef> on timeout. | ||||
123 | If the timer times out, C<$t-<gt>timed_out()> will return C<1>. | ||||
124 | |||||
125 | Time elapsed is not cumulative; multiple runs of C<run> will restart the | ||||
126 | timeout from scratch. On the other hand, nested timers do observe outer | ||||
127 | timeouts if they are shorter, resignalling a timeout to the level which | ||||
128 | established them, i.e. code running under an inner timer can not exceed | ||||
129 | the time limit established by an outer timer. When restarting an outer | ||||
130 | timer on return, elapsed time of a running code is taken into account. | ||||
131 | |||||
132 | =item $t->run_and_catch($coderef) | ||||
133 | |||||
134 | Run a code reference, as per C<$t-<gt>run()>, but also catching any | ||||
135 | C<die()> calls within the code reference. | ||||
136 | |||||
137 | Returns C<undef> if no C<die()> call was executed and C<$@> was unset, or the | ||||
138 | value of C<$@> if it was set. (The timeout event doesn't count as a C<die()>.) | ||||
139 | |||||
140 | =cut | ||||
141 | |||||
142 | sub run { $_[0]->_run($_[1], 0); } | ||||
143 | |||||
144 | sub run_and_catch { $_[0]->_run($_[1], 1); } | ||||
145 | |||||
146 | sub _run { # private | ||||
147 | my ($self, $sub, $and_catch) = @_; | ||||
148 | |||||
149 | delete $self->{timed_out}; | ||||
150 | |||||
151 | my $id = $self->{id}; | ||||
152 | my $secs = $self->{secs}; | ||||
153 | my $deadline = $self->{deadline}; | ||||
154 | my $alarm_tinkered_with = 0; | ||||
155 | # dbg("timed: %s run", $id); | ||||
156 | |||||
157 | # assertion | ||||
158 | if (defined $secs && $secs < 0) { | ||||
159 | die "Mail::SpamAssassin::Timeout: oops? neg value for 'secs': $secs"; | ||||
160 | } | ||||
161 | |||||
162 | my $start_time = time; | ||||
163 | if (defined $deadline) { | ||||
164 | my $dt = $deadline - $start_time; | ||||
165 | $secs = $dt if !defined $secs || $dt < $secs; | ||||
166 | } | ||||
167 | |||||
168 | # bug 4699: under heavy load, an alarm may fire while $@ will contain "", | ||||
169 | # which isn't very useful. this flag works around it safely, since | ||||
170 | # it will not require malloc() be called if it fires | ||||
171 | my $timedout = 0; | ||||
172 | |||||
173 | my($oldalarm, $handler); | ||||
174 | if (defined $secs) { | ||||
175 | # stop the timer, collect remaining time | ||||
176 | $oldalarm = alarm(0); # 0 when disarmed, undef on error | ||||
177 | $alarm_tinkered_with = 1; | ||||
178 | if (!@expiration) { | ||||
179 | # dbg("timed: %s no timer in evidence", $id); | ||||
180 | # dbg("timed: %s actual timer was running, time left %.3f s", | ||||
181 | # $id, $oldalarm) if $oldalarm; | ||||
182 | } elsif (!defined $expiration[0]) { | ||||
183 | # dbg("timed: %s timer not running according to evidence", $id); | ||||
184 | # dbg("timed: %s actual timer was running, time left %.3f s", | ||||
185 | # $id, $oldalarm) if $oldalarm; | ||||
186 | } else { | ||||
187 | my $oldalarm2 = $expiration[0] - $start_time; | ||||
188 | # dbg("timed: %s stopping timer, time left %.3f s%s", $id, $oldalarm2, | ||||
189 | # !$oldalarm ? '' : sprintf(", reported as %.3f s", $oldalarm)); | ||||
190 | $oldalarm = $oldalarm2 < 1 ? 1 : $oldalarm2; | ||||
191 | } | ||||
192 | $self->{end_time} = $start_time + $secs; # needed by reset() | ||||
193 | $handler = sub { $timedout = 1; die "__alarm__ignore__($id)\n" }; | ||||
194 | } | ||||
195 | |||||
196 | my($ret, $eval_stat); | ||||
197 | unshift(@expiration, undef); | ||||
198 | eval { | ||||
199 | local $SIG{__DIE__}; # bug 4631 | ||||
200 | |||||
201 | if (!defined $secs) { # no timeout specified, just call the sub | ||||
202 | $ret = &$sub; | ||||
203 | |||||
204 | } elsif ($secs <= 0) { | ||||
205 | $self->{timed_out} = 1; | ||||
206 | &$handler; | ||||
207 | |||||
208 | } elsif ($oldalarm && $oldalarm < $secs) { # run under an outer timer | ||||
209 | # just restore outer timer, a timeout signal will be handled there | ||||
210 | # dbg("timed: %s alarm(%.3f) - outer", $id, $oldalarm); | ||||
211 | $expiration[0] = $start_time + $oldalarm; | ||||
212 | alarm($oldalarm); $alarm_tinkered_with = 1; | ||||
213 | $ret = &$sub; | ||||
214 | # dbg("timed: %s post-sub(outer)", $id); | ||||
215 | |||||
216 | } else { # run under a timer specified with this call | ||||
217 | local $SIG{ALRM} = $handler; # ensure closed scope here | ||||
218 | my $isecs = int($secs); | ||||
219 | $isecs++ if $secs > int($isecs); # ceiling | ||||
220 | # dbg("timed: %s alarm(%d)", $id, $isecs); | ||||
221 | $expiration[0] = $start_time + $isecs; | ||||
222 | alarm($isecs); $alarm_tinkered_with = 1; | ||||
223 | $ret = &$sub; | ||||
224 | # dbg("timed: %s post-sub", $id); | ||||
225 | } | ||||
226 | |||||
227 | # Unset the alarm() before we leave eval{ } scope, as that stack-pop | ||||
228 | # operation can take a second or two under load. Note: previous versions | ||||
229 | # restored $oldalarm here; however, that is NOT what we want to do, since | ||||
230 | # it creates a new race condition, namely that an old alarm could then fire | ||||
231 | # while the stack-pop was underway, thereby appearing to be *this* timeout | ||||
232 | # timing out. In terms of how we might possibly have nested timeouts in | ||||
233 | # SpamAssassin, this is an academic issue with little impact, but it's | ||||
234 | # still worth avoiding anyway. | ||||
235 | # | ||||
236 | alarm(0) if $alarm_tinkered_with; # disarm | ||||
237 | |||||
238 | 1; | ||||
239 | } or do { | ||||
240 | $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; | ||||
241 | # just in case we popped out for some other reason | ||||
242 | alarm(0) if $alarm_tinkered_with; # disarm | ||||
243 | }; | ||||
244 | |||||
245 | delete $self->{end_time}; # reset() is only applicable within a &$sub | ||||
246 | |||||
247 | # catch timedout return: | ||||
248 | # 0 0 $ret | ||||
249 | # 0 1 undef | ||||
250 | # 1 0 $eval_stat | ||||
251 | # 1 1 undef | ||||
252 | # | ||||
253 | my $return = $and_catch ? $eval_stat : $ret; | ||||
254 | |||||
255 | if (defined $eval_stat && $eval_stat =~ /__alarm__ignore__\Q($id)\E/) { | ||||
256 | $self->{timed_out} = 1; | ||||
257 | # dbg("timed: %s cought: %s", $id, $eval_stat); | ||||
258 | } elsif ($timedout) { | ||||
259 | # this happens occasionally; haven't figured out why. seems harmless | ||||
260 | # dbg("timed: %s timeout with empty eval status", $id); | ||||
261 | $self->{timed_out} = 1; | ||||
262 | } | ||||
263 | |||||
264 | shift(@expiration); # pop off the stack | ||||
265 | |||||
266 | # covers all cases, including where $self->{timed_out} is flagged by reset() | ||||
267 | undef $return if $self->{timed_out}; | ||||
268 | |||||
269 | my $remaining_time; | ||||
270 | # restore previous timer if necessary | ||||
271 | if ($oldalarm) { # an outer alarm was already active when we were called | ||||
272 | $remaining_time = $start_time + $oldalarm - time; | ||||
273 | if ($remaining_time > 0) { # still in the future | ||||
274 | # restore the previously-active alarm, | ||||
275 | # taking into account the elapsed time we spent here | ||||
276 | my $iremaining_time = int($remaining_time); | ||||
277 | $iremaining_time++ if $remaining_time > int($remaining_time); # ceiling | ||||
278 | # dbg("timed: %s restoring outer alarm(%.3f)", $id, $iremaining_time); | ||||
279 | alarm($iremaining_time); $alarm_tinkered_with = 1; | ||||
280 | undef $remaining_time; # already taken care of | ||||
281 | } | ||||
282 | } | ||||
283 | if (!$and_catch && defined $eval_stat && | ||||
284 | $eval_stat !~ /__alarm__ignore__\Q($id)\E/) { | ||||
285 | # propagate "real" errors or outer timeouts | ||||
286 | die "Timeout::_run: $eval_stat\n"; | ||||
287 | } | ||||
288 | if (defined $remaining_time) { | ||||
289 | # dbg("timed: %s outer timer expired %.3f s ago", $id, -$remaining_time); | ||||
290 | # mercifully grant two additional seconds | ||||
291 | alarm(2); $alarm_tinkered_with = 1; | ||||
292 | } | ||||
293 | return $return; | ||||
294 | } | ||||
295 | |||||
296 | ########################################################################### | ||||
297 | |||||
298 | =item $t->timed_out() | ||||
299 | |||||
300 | Returns C<1> if the most recent code executed in C<run()> timed out, or | ||||
301 | C<undef> if it did not. | ||||
302 | |||||
303 | =cut | ||||
304 | |||||
305 | sub timed_out { | ||||
306 | my ($self) = @_; | ||||
307 | return $self->{timed_out}; | ||||
308 | } | ||||
309 | |||||
310 | ########################################################################### | ||||
311 | |||||
312 | =item $t->reset() | ||||
313 | |||||
314 | If called within a C<run()> code reference, causes the current alarm timer | ||||
315 | to be restored to its original setting (useful after our alarm setting was | ||||
316 | clobbered by some underlying module). | ||||
317 | |||||
318 | =back | ||||
319 | |||||
320 | =cut | ||||
321 | |||||
322 | sub reset { | ||||
323 | my ($self) = @_; | ||||
324 | |||||
325 | my $id = $self->{id}; | ||||
326 | # dbg("timed: %s reset", $id); | ||||
327 | return if !defined $self->{end_time}; | ||||
328 | |||||
329 | my $secs = $self->{end_time} - time; | ||||
330 | if ($secs > 0) { | ||||
331 | my $isecs = int($secs); | ||||
332 | $isecs++ if $secs > int($isecs); # ceiling | ||||
333 | # dbg("timed: %s reset: alarm(%.3f)", $self->{id}, $isecs); | ||||
334 | alarm($isecs); | ||||
335 | } else { | ||||
336 | $self->{timed_out} = 1; | ||||
337 | # dbg("timed: %s reset, timer expired %.3f s ago", $id, -$secs); | ||||
338 | alarm(2); # mercifully grant two additional seconds | ||||
339 | } | ||||
340 | } | ||||
341 | |||||
342 | ########################################################################### | ||||
343 | |||||
344 | 1 | 8µs | 1; |