← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:19 2017

Filename/usr/local/lib/perl5/site_perl/Mail/SpamAssassin/Timeout.pm
StatementsExecuted 21 statements in 2.54ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11144µs59µsMail::SpamAssassin::Timeout::::BEGIN@56Mail::SpamAssassin::Timeout::BEGIN@56
11129µs364µsMail::SpamAssassin::Timeout::::BEGIN@61Mail::SpamAssassin::Timeout::BEGIN@61
11128µs104µsMail::SpamAssassin::Timeout::::BEGIN@64Mail::SpamAssassin::Timeout::BEGIN@64
11127µs107µsMail::SpamAssassin::Timeout::::BEGIN@95Mail::SpamAssassin::Timeout::BEGIN@95
11126µs104µsMail::SpamAssassin::Timeout::::BEGIN@93Mail::SpamAssassin::Timeout::BEGIN@93
11126µs31µsMail::SpamAssassin::Timeout::::BEGIN@58Mail::SpamAssassin::Timeout::BEGIN@58
11126µs195µsMail::SpamAssassin::Timeout::::BEGIN@62Mail::SpamAssassin::Timeout::BEGIN@62
11125µs82µsMail::SpamAssassin::Timeout::::BEGIN@59Mail::SpamAssassin::Timeout::BEGIN@59
11120µs65µsMail::SpamAssassin::Timeout::::BEGIN@57Mail::SpamAssassin::Timeout::BEGIN@57
1119µs9µsMail::SpamAssassin::Timeout::::BEGIN@94Mail::SpamAssassin::Timeout::BEGIN@94
0000s0sMail::SpamAssassin::Timeout::::__ANON__[:193]Mail::SpamAssassin::Timeout::__ANON__[:193]
0000s0sMail::SpamAssassin::Timeout::::_runMail::SpamAssassin::Timeout::_run
0000s0sMail::SpamAssassin::Timeout::::newMail::SpamAssassin::Timeout::new
0000s0sMail::SpamAssassin::Timeout::::resetMail::SpamAssassin::Timeout::reset
0000s0sMail::SpamAssassin::Timeout::::runMail::SpamAssassin::Timeout::run
0000s0sMail::SpamAssassin::Timeout::::run_and_catchMail::SpamAssassin::Timeout::run_and_catch
0000s0sMail::SpamAssassin::Timeout::::timed_outMail::SpamAssassin::Timeout::timed_out
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::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
40This module provides a safe, reliable and clean API to provide
41C<alarm(2)>-based timeouts for perl code.
42
43Note that C<$SIG{ALRM}> is used to provide the timeout, so this will not
44interrupt out-of-control regular expression matches.
45
46Nested timeouts are supported.
47
48=head1 PUBLIC METHODS
49
50=over 4
51
52=cut
53
54package Mail::SpamAssassin::Timeout;
55
56264µs274µs
# spent 59µs (44+15) within Mail::SpamAssassin::Timeout::BEGIN@56 which was called: # once (44µs+15µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 56
use strict;
# spent 59µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@56 # spent 15µs making 1 call to strict::import
57270µs2110µs
# spent 65µs (20+45) within Mail::SpamAssassin::Timeout::BEGIN@57 which was called: # once (20µs+45µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 57
use warnings;
# spent 65µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@57 # spent 45µs making 1 call to warnings::import
58274µs236µs
# spent 31µs (26+5) within Mail::SpamAssassin::Timeout::BEGIN@58 which was called: # once (26µs+5µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 58
use bytes;
# spent 31µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@58 # spent 5µs making 1 call to bytes::import
59263µs2140µs
# spent 82µs (25+57) within Mail::SpamAssassin::Timeout::BEGIN@59 which was called: # once (25µs+57µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 59
use re 'taint';
# spent 82µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@59 # spent 58µs making 1 call to re::import
60
61282µs2698µs
# spent 364µs (29+335) within Mail::SpamAssassin::Timeout::BEGIN@61 which was called: # once (29µs+335µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 61
use Time::HiRes qw(time);
# spent 364µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@61 # spent 335µs making 1 call to Time::HiRes::import
62287µs2364µs
# spent 195µs (26+169) within Mail::SpamAssassin::Timeout::BEGIN@62 which was called: # once (26µs+169µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 62
use Mail::SpamAssassin::Logger;
# spent 195µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@62 # spent 169µs making 1 call to Exporter::import
63
6412µs
# spent 104µs (28+76) within Mail::SpamAssassin::Timeout::BEGIN@64 which was called: # once (28µs+76µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 66
use vars qw{
65 @ISA
661129µs2181µs};
# spent 104µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@64 # spent 76µs making 1 call to vars::import
67
6819µs@ISA = qw();
69
70###########################################################################
71
72=item my $t = Mail::SpamAssassin::Timeout->new({ ... options ... });
73
74Constructor. Options include:
75
76=over 4
77
78=item secs => $seconds
79
80time interval, in seconds. Optional; if neither C<secs> nor C<deadline> is
81specified, no timeouts will be applied.
82
83=item deadline => $unix_timestamp
84
85Unix timestamp (seconds since epoch) when a timeout is reached in the latest.
86Optional; if neither B<secs> nor B<deadline> is specified, no timeouts will
87be applied. If both are specified, the shorter interval of the two prevails.
88
89=back
90
91=cut
92
93268µs2181µs
# spent 104µs (26+77) within Mail::SpamAssassin::Timeout::BEGIN@93 which was called: # once (26µs+77µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 93
use vars qw($id_gen);
# spent 104µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@93 # spent 77µs making 1 call to vars::import
94157µs19µs
# spent 9µs within Mail::SpamAssassin::Timeout::BEGIN@94 which was called: # once (9µs+0s) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 94
BEGIN { $id_gen = 0 } # unique generator of IDs for timer objects
# spent 9µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@94
9521.82ms2186µs
# spent 107µs (27+80) within Mail::SpamAssassin::Timeout::BEGIN@95 which was called: # once (27µs+80µs) by Mail::SpamAssassin::PerMsgStatus::BEGIN@63 at line 95
use vars qw(@expiration); # stack of expected expiration times, top at [0]
# spent 107µs making 1 call to Mail::SpamAssassin::Timeout::BEGIN@95 # spent 80µs making 1 call to vars::import
96
97sub 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
117Run a code reference within the currently-defined timeout.
118
119The timeout is as defined by the B<secs> and B<deadline> parameters
120to the constructor.
121
122Returns whatever the subroutine returns, or C<undef> on timeout.
123If the timer times out, C<$t-<gt>timed_out()> will return C<1>.
124
125Time elapsed is not cumulative; multiple runs of C<run> will restart the
126timeout from scratch. On the other hand, nested timers do observe outer
127timeouts if they are shorter, resignalling a timeout to the level which
128established them, i.e. code running under an inner timer can not exceed
129the time limit established by an outer timer. When restarting an outer
130timer on return, elapsed time of a running code is taken into account.
131
132=item $t->run_and_catch($coderef)
133
134Run a code reference, as per C<$t-<gt>run()>, but also catching any
135C<die()> calls within the code reference.
136
137Returns C<undef> if no C<die()> call was executed and C<$@> was unset, or the
138value of C<$@> if it was set. (The timeout event doesn't count as a C<die()>.)
139
140=cut
141
142sub run { $_[0]->_run($_[1], 0); }
143
144sub run_and_catch { $_[0]->_run($_[1], 1); }
145
146sub _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
300Returns C<1> if the most recent code executed in C<run()> timed out, or
301C<undef> if it did not.
302
303=cut
304
305sub timed_out {
306 my ($self) = @_;
307 return $self->{timed_out};
308}
309
310###########################################################################
311
312=item $t->reset()
313
314If called within a C<run()> code reference, causes the current alarm timer
315to be restored to its original setting (useful after our alarm setting was
316clobbered by some underlying module).
317
318=back
319
320=cut
321
322sub 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
344114µs1;
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.