← Index
NYTProf Performance Profile   « block view • line view • sub view »
For reply.pl
  Run on Thu Oct 21 22:40:13 2010
Reported on Thu Oct 21 22:44:38 2010

Filename/home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/5.13.5/Fatal.pm
StatementsExecuted 455 statements in 7.92ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.26ms2.43msFatal::::BEGIN@4 Fatal::BEGIN@4
2111.71ms2.56msFatal::::_make_fatal Fatal::_make_fatal
1111.28ms7.56msFatal::::BEGIN@7 Fatal::BEGIN@7
1111.03ms1.67msFatal::::BEGIN@10 Fatal::BEGIN@10
511167µs167µsFatal::::_one_invocation Fatal::_one_invocation
211139µs311µsFatal::::_write_invocation Fatal::_write_invocation
111135µs2.72msFatal::::import Fatal::import
211127µs172µsFatal::::fill_protos Fatal::fill_protos
21189µs89µsFatal::::_install_subs Fatal::_install_subs
216146µs46µsFatal::::CORE:subst Fatal::CORE:subst (opcode)
186138µs38µsFatal::::CORE:match Fatal::CORE:match (opcode)
11130µs30µsFatal::::BEGIN@3 Fatal::BEGIN@3
11117µs48µsFatal::::BEGIN@364 Fatal::BEGIN@364
11116µs45µsFatal::::BEGIN@1096 Fatal::BEGIN@1096
11115µs40µsFatal::::BEGIN@8 Fatal::BEGIN@8
11114µs72µsFatal::::BEGIN@29 Fatal::BEGIN@29
11112µs17µsFatal::::BEGIN@385 Fatal::BEGIN@385
11112µs71µsFatal::::BEGIN@12 Fatal::BEGIN@12
11111µs16µsFatal::::BEGIN@5 Fatal::BEGIN@5
11111µs70µsFatal::::BEGIN@18 Fatal::BEGIN@18
11111µs72µsFatal::::BEGIN@31 Fatal::BEGIN@31
11111µs20µsFatal::::BEGIN@6 Fatal::BEGIN@6
11111µs15µsFatal::::BEGIN@369 Fatal::BEGIN@369
11111µs69µsFatal::::BEGIN@16 Fatal::BEGIN@16
11110µs68µsFatal::::BEGIN@23 Fatal::BEGIN@23
11110µs68µsFatal::::BEGIN@27 Fatal::BEGIN@27
11110µs10µsautodie::Scope::Guard::::newautodie::Scope::Guard::new
11110µs70µsFatal::::BEGIN@14 Fatal::BEGIN@14
11110µs68µsFatal::::BEGIN@40 Fatal::BEGIN@40
11110µs69µsFatal::::BEGIN@17 Fatal::BEGIN@17
11110µs70µsFatal::::BEGIN@22 Fatal::BEGIN@22
11110µs68µsFatal::::BEGIN@33 Fatal::BEGIN@33
11110µs69µsFatal::::BEGIN@35 Fatal::BEGIN@35
11110µs70µsFatal::::BEGIN@20 Fatal::BEGIN@20
11110µs160µsFatal::::BEGIN@13 Fatal::BEGIN@13
11110µs68µsFatal::::BEGIN@25 Fatal::BEGIN@25
11110µs69µsFatal::::BEGIN@21 Fatal::BEGIN@21
11110µs70µsFatal::::BEGIN@19 Fatal::BEGIN@19
0000s0sFatal::::__ANON__[:324] Fatal::__ANON__[:324]
0000s0sFatal::::_autocroak Fatal::_autocroak
0000s0sFatal::::_expand_tag Fatal::_expand_tag
0000s0sFatal::::exception_class Fatal::exception_class
0000s0sFatal::::one_invocation Fatal::one_invocation
0000s0sFatal::::throw Fatal::throw
0000s0sFatal::::unimport Fatal::unimport
0000s0sFatal::::write_invocation Fatal::write_invocation
0000s0sautodie::Scope::Guard::::DESTROYautodie::Scope::Guard::DESTROY
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Fatal;
2
3234µs130µs
# spent 30µs within Fatal::BEGIN@3 which was called: # once (30µs+0s) by autodie::BEGIN@6 at line 3
use 5.008; # 5.8.x needed for autodie
# spent 30µs making 1 call to Fatal::BEGIN@3
421.57ms22.50ms
# spent 2.43ms (2.26+165µs) within Fatal::BEGIN@4 which was called: # once (2.26ms+165µs) by autodie::BEGIN@6 at line 4
use Carp;
# spent 2.43ms making 1 call to Fatal::BEGIN@4 # spent 72µs making 1 call to Exporter::import
5225µs221µs
# spent 16µs (11+5) within Fatal::BEGIN@5 which was called: # once (11µs+5µs) by autodie::BEGIN@6 at line 5
use strict;
# spent 16µs making 1 call to Fatal::BEGIN@5 # spent 5µs making 1 call to strict::import
6224µs228µs
# spent 20µs (11+9) within Fatal::BEGIN@6 which was called: # once (11µs+9µs) by autodie::BEGIN@6 at line 6
use warnings;
# spent 20µs making 1 call to Fatal::BEGIN@6 # spent 9µs making 1 call to warnings::import
72170µs17.56ms
# spent 7.56ms (1.28+6.28) within Fatal::BEGIN@7 which was called: # once (1.28ms+6.28ms) by autodie::BEGIN@6 at line 7
use Tie::RefHash; # To cache subroutine refs
# spent 7.56ms making 1 call to Fatal::BEGIN@7
8236µs264µs
# spent 40µs (15+24) within Fatal::BEGIN@8 which was called: # once (15µs+24µs) by autodie::BEGIN@6 at line 8
use Config;
# spent 40µs making 1 call to Fatal::BEGIN@8 # spent 24µs making 1 call to Config::import
9
102258µs21.78ms
# spent 1.67ms (1.03+641µs) within Fatal::BEGIN@10 which was called: # once (1.03ms+641µs) by autodie::BEGIN@6 at line 10
use constant PERL510 => ( $] >= 5.010 );
# spent 1.67ms making 1 call to Fatal::BEGIN@10 # spent 103µs making 1 call to constant::import
11
12229µs2131µs
# spent 71µs (12+60) within Fatal::BEGIN@12 which was called: # once (12µs+60µs) by autodie::BEGIN@6 at line 12
use constant LEXICAL_TAG => q{:lexical};
# spent 71µs making 1 call to Fatal::BEGIN@12 # spent 60µs making 1 call to constant::import
13230µs2310µs
# spent 160µs (10+150) within Fatal::BEGIN@13 which was called: # once (10µs+150µs) by autodie::BEGIN@6 at line 13
use constant VOID_TAG => q{:void};
# spent 160µs making 1 call to Fatal::BEGIN@13 # spent 150µs making 1 call to constant::import
14228µs2130µs
# spent 70µs (10+60) within Fatal::BEGIN@14 which was called: # once (10µs+60µs) by autodie::BEGIN@6 at line 14
use constant INSIST_TAG => q{!};
# spent 70µs making 1 call to Fatal::BEGIN@14 # spent 60µs making 1 call to constant::import
15
16238µs2128µs
# spent 69µs (11+59) within Fatal::BEGIN@16 which was called: # once (11µs+59µs) by autodie::BEGIN@6 at line 16
use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
# spent 69µs making 1 call to Fatal::BEGIN@16 # spent 59µs making 1 call to constant::import
17235µs2128µs
# spent 69µs (10+59) within Fatal::BEGIN@17 which was called: # once (10µs+59µs) by autodie::BEGIN@6 at line 17
use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
# spent 69µs making 1 call to Fatal::BEGIN@17 # spent 59µs making 1 call to constant::import
18236µs2128µs
# spent 70µs (11+59) within Fatal::BEGIN@18 which was called: # once (11µs+59µs) by autodie::BEGIN@6 at line 18
use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
# spent 70µs making 1 call to Fatal::BEGIN@18 # spent 59µs making 1 call to constant::import
19227µs2129µs
# spent 70µs (10+60) within Fatal::BEGIN@19 which was called: # once (10µs+60µs) by autodie::BEGIN@6 at line 19
use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
# spent 70µs making 1 call to Fatal::BEGIN@19 # spent 60µs making 1 call to constant::import
20228µs2130µs
# spent 70µs (10+60) within Fatal::BEGIN@20 which was called: # once (10µs+60µs) by autodie::BEGIN@6 at line 20
use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
# spent 70µs making 1 call to Fatal::BEGIN@20 # spent 60µs making 1 call to constant::import
21229µs2129µs
# spent 69µs (10+60) within Fatal::BEGIN@21 which was called: # once (10µs+60µs) by autodie::BEGIN@6 at line 21
use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
# spent 69µs making 1 call to Fatal::BEGIN@21 # spent 60µs making 1 call to constant::import
22229µs2129µs
# spent 70µs (10+59) within Fatal::BEGIN@22 which was called: # once (10µs+59µs) by autodie::BEGIN@6 at line 22
use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
# spent 70µs making 1 call to Fatal::BEGIN@22 # spent 59µs making 1 call to constant::import
23229µs2126µs
# spent 68µs (10+58) within Fatal::BEGIN@23 which was called: # once (10µs+58µs) by autodie::BEGIN@6 at line 23
use constant ERROR_NOHINTS => "No user hints defined for %s";
# spent 68µs making 1 call to Fatal::BEGIN@23 # spent 58µs making 1 call to constant::import
24
25228µs2127µs
# spent 68µs (10+58) within Fatal::BEGIN@25 which was called: # once (10µs+58µs) by autodie::BEGIN@6 at line 25
use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
# spent 68µs making 1 call to Fatal::BEGIN@25 # spent 58µs making 1 call to constant::import
26
27234µs2125µs
# spent 68µs (10+57) within Fatal::BEGIN@27 which was called: # once (10µs+57µs) by autodie::BEGIN@6 at line 27
use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
# spent 68µs making 1 call to Fatal::BEGIN@27 # spent 57µs making 1 call to constant::import
28
29230µs2131µs
# spent 72µs (14+58) within Fatal::BEGIN@29 which was called: # once (14µs+58µs) by autodie::BEGIN@6 at line 29
use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
# spent 72µs making 1 call to Fatal::BEGIN@29 # spent 58µs making 1 call to constant::import
30
31230µs2132µs
# spent 72µs (11+61) within Fatal::BEGIN@31 which was called: # once (11µs+61µs) by autodie::BEGIN@6 at line 31
use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
# spent 72µs making 1 call to Fatal::BEGIN@31 # spent 61µs making 1 call to constant::import
32
33228µs2126µs
# spent 68µs (10+58) within Fatal::BEGIN@33 which was called: # once (10µs+58µs) by autodie::BEGIN@6 at line 33
use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
# spent 68µs making 1 call to Fatal::BEGIN@33 # spent 58µs making 1 call to constant::import
34
35230µs2127µs
# spent 69µs (10+59) within Fatal::BEGIN@35 which was called: # once (10µs+59µs) by autodie::BEGIN@6 at line 35
use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
# spent 69µs making 1 call to Fatal::BEGIN@35 # spent 59µs making 1 call to constant::import
36
37# Older versions of IPC::System::Simple don't support all the
38# features we need.
39
402813µs2125µs
# spent 68µs (10+57) within Fatal::BEGIN@40 which was called: # once (10µs+57µs) by autodie::BEGIN@6 at line 40
use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
# spent 68µs making 1 call to Fatal::BEGIN@40 # spent 58µs making 1 call to constant::import
41
42# All the Fatal/autodie modules share the same version number.
4312µsour $VERSION = '2.10';
44
4511µsour $Debug ||= 0;
46
47# EWOULDBLOCK values for systems that don't supply their own.
48# Even though this is defined with our, that's to help our
49# test code. Please don't rely upon this variable existing in
50# the future.
51
5213µsour %_EWOULDBLOCK = (
53 MSWin32 => 33,
54);
55
56# the linux parisc port has separate EAGAIN and EWOULDBLOCK,
57# and the kernel returns EAGAIN
58125µs216µsmy $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
# spent 11µs making 1 call to Config::FETCH # spent 6µs making 1 call to Fatal::CORE:match
59
60# We have some tags that can be passed in for use with import.
61# These are all assumed to be CORE::
62
63135µsmy %TAGS = (
64 ':io' => [qw(:dbm :file :filesys :ipc :socket
65 read seek sysread syswrite sysseek )],
66 ':dbm' => [qw(dbmopen dbmclose)],
67 ':file' => [qw(open close flock sysopen fcntl fileno binmode
68 ioctl truncate chmod)],
69 ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
70 symlink rmdir readlink umask)],
71 ':ipc' => [qw(:msg :semaphore :shm pipe)],
72 ':msg' => [qw(msgctl msgget msgrcv msgsnd)],
73 ':threads' => [qw(fork)],
74 ':semaphore'=>[qw(semctl semget semop)],
75 ':shm' => [qw(shmctl shmget shmread)],
76 ':system' => [qw(system exec)],
77
78 # Can we use qw(getpeername getsockname)? What do they do on failure?
79 # TODO - Can socket return false?
80 ':socket' => [qw(accept bind connect getsockopt listen recv send
81 setsockopt shutdown socketpair)],
82
83 # Our defaults don't include system(), because it depends upon
84 # an optional module, and it breaks the exotic form.
85 #
86 # This *may* change in the future. I'd love IPC::System::Simple
87 # to be a dependency rather than a recommendation, and hence for
88 # system() to be autodying by default.
89
90 ':default' => [qw(:io :threads)],
91
92 # Everything in v2.07 and brefore. This was :default less chmod.
93 ':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread
94 syswrite sysseek open close flock sysopen fcntl fileno
95 binmode ioctl truncate)],
96
97 # Version specific tags. These allow someone to specify
98 # use autodie qw(:1.994) and know exactly what they'll get.
99
100 ':1.994' => [qw(:v207)],
101 ':1.995' => [qw(:v207)],
102 ':1.996' => [qw(:v207)],
103 ':1.997' => [qw(:v207)],
104 ':1.998' => [qw(:v207)],
105 ':1.999' => [qw(:v207)],
106 ':1.999_01' => [qw(:v207)],
107 ':2.00' => [qw(:v207)],
108 ':2.01' => [qw(:v207)],
109 ':2.02' => [qw(:v207)],
110 ':2.03' => [qw(:v207)],
111 ':2.04' => [qw(:v207)],
112 ':2.05' => [qw(:v207)],
113 ':2.06' => [qw(:v207)],
114 ':2.06_01' => [qw(:v207)],
115 ':2.07' => [qw(:v207)], # Last release without chmod
116 ':2.08' => [qw(:default)],
117 ':2.09' => [qw(:default)],
118 ':2.10' => [qw(:default)],
119);
120
121# chmod was only introduced in 2.07
122
123111µs$TAGS{':all'} = [ keys %TAGS ];
124
125# This hash contains subroutines for which we should
126# subroutine() // die() rather than subroutine() || die()
127
12811µsmy %Use_defined_or;
129
130# CORE::open returns undef on failure. It can legitimately return
131# 0 on success, eg: open(my $fh, '-|') || exec(...);
132
13316µs@Use_defined_or{qw(
134 CORE::fork
135 CORE::recv
136 CORE::send
137 CORE::open
138 CORE::fileno
139 CORE::read
140 CORE::readlink
141 CORE::sysread
142 CORE::syswrite
143 CORE::sysseek
144 CORE::umask
145)} = ();
146
147# Cached_fatalised_sub caches the various versions of our
148# fatalised subs as they're produced. This means we don't
149# have to build our own replacement of CORE::open and friends
150# for every single package that wants to use them.
151
15211µsmy %Cached_fatalised_sub = ();
153
154# Every time we're called with package scope, we record the subroutine
155# (including package or CORE::) in %Package_Fatal. This allows us
156# to detect illegal combinations of autodie and Fatal, and makes sure
157# we don't accidently make a Fatal function autodying (which isn't
158# very useful).
159
16011µsmy %Package_Fatal = ();
161
162# The first time we're called with a user-sub, we cache it here.
163# In the case of a "no autodie ..." we put back the cached copy.
164
16511µsmy %Original_user_sub = ();
166
167# Is_fatalised_sub simply records a big map of fatalised subroutine
168# refs. It means we can avoid repeating work, or fatalising something
169# we've already processed.
170
17111µsmy %Is_fatalised_sub = ();
172110µs124µstie %Is_fatalised_sub, 'Tie::RefHash';
# spent 24µs making 1 call to Tie::RefHash::TIEHASH
173
174# We use our package in a few hash-keys. Having it in a scalar is
175# convenient. The "guard $PACKAGE" string is used as a key when
176# setting up lexical guards.
177
17811µsmy $PACKAGE = __PACKAGE__;
17912µsmy $PACKAGE_GUARD = "guard $PACKAGE";
18011µsmy $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
181
182# Here's where all the magic happens when someone write 'use Fatal'
183# or 'use autodie'.
184
185
# spent 2.72ms (135µs+2.58) within Fatal::import which was called: # once (135µs+2.58ms) by Hailo::BEGIN@10 at line 58 of autodie.pm
sub import {
18644142µs my $class = shift(@_);
187 my @original_args = @_;
188 my $void = 0;
189 my $lexical = 0;
190 my $insist_hints = 0;
191
192 my ($pkg, $filename) = caller();
193
194 @_ or return; # 'use Fatal' is a no-op.
195
196 # If we see the :lexical flag, then _all_ arguments are
197 # changed lexically
198
199 if ($_[0] eq LEXICAL_TAG) {
200 $lexical = 1;
201 shift @_;
202
203 # If we see no arguments and :lexical, we assume they
204 # wanted ':default'.
205
206 if (@_ == 0) {
207 push(@_, ':default');
208 }
209
210 # Don't allow :lexical with :void, it's needlessly confusing.
211 if ( grep { $_ eq VOID_TAG } @_ ) {
212 croak(ERROR_VOID_LEX);
213 }
214 }
215
216 if ( grep { $_ eq LEXICAL_TAG } @_ ) {
217 # If we see the lexical tag as the non-first argument, complain.
218 croak(ERROR_LEX_FIRST);
219 }
220
221 my @fatalise_these = @_;
222
223 # Thiese subs will get unloaded at the end of lexical scope.
224 my %unload_later;
225
226 # This hash helps us track if we've alredy done work.
227 my %done_this;
228
229 # NB: we're using while/shift rather than foreach, since
230 # we'll be modifying the array as we walk through it.
231
232 while (my $func = shift @fatalise_these) {
233
234 if ($func eq VOID_TAG) {
235
236 # When we see :void, set the void flag.
237 $void = 1;
238
239 } elsif ($func eq INSIST_TAG) {
240
241 $insist_hints = 1;
242
243 } elsif (exists $TAGS{$func}) {
244
245 # When it's a tag, expand it.
246 push(@fatalise_these, @{ $TAGS{$func} });
247
248 } else {
249
250 # Otherwise, fatalise it.
251
252 # Check to see if there's an insist flag at the front.
253 # If so, remove it, and insist we have hints for this sub.
254 my $insist_this;
255
25624µs if ($func =~ s/^!//) {
# spent 4µs making 2 calls to Fatal::CORE:subst, avg 2µs/call
257 $insist_this = 1;
258 }
259
260 # TODO: Even if we've already fatalised, we should
261 # check we've done it with hints (if $insist_hints).
262
263 # If we've already made something fatal this call,
264 # then don't do it twice.
265
266 next if $done_this{$func};
267
268 # We're going to make a subroutine fatalistic.
269 # However if we're being invoked with 'use Fatal qw(x)'
270 # and we've already been called with 'no autodie qw(x)'
271 # in the same scope, we consider this to be an error.
272 # Mixing Fatal and autodie effects was considered to be
273 # needlessly confusing on p5p.
274
275 my $sub = $func;
27625µs $sub = "${pkg}::$sub" unless $sub =~ /::/;
# spent 5µs making 2 calls to Fatal::CORE:match, avg 2µs/call
277
278 # If we're being called as Fatal, and we've previously
279 # had a 'no X' in scope for the subroutine, then complain
280 # bitterly.
281
282 if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
283 croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
284 }
285
286 # We're not being used in a confusing way, so make
287 # the sub fatal. Note that _make_fatal returns the
288 # old (original) version of the sub, or undef for
289 # built-ins.
290
29122.56ms my $sub_ref = $class->_make_fatal(
# spent 2.56ms making 2 calls to Fatal::_make_fatal, avg 1.28ms/call
292 $func, $pkg, $void, $lexical, $filename,
293 ( $insist_this || $insist_hints )
294 );
295
296 $done_this{$func}++;
297
298 $Original_user_sub{$sub} ||= $sub_ref;
299
300 # If we're making lexical changes, we need to arrange
301 # for them to be cleaned at the end of our scope, so
302 # record them here.
303
304 $unload_later{$func} = $sub_ref if $lexical;
305 }
306 }
307
308 if ($lexical) {
309
310 # Dark magic to have autodie work under 5.8
311 # Copied from namespace::clean, that copied it from
312 # autobox, that found it on an ancient scroll written
313 # in blood.
314
315 # This magic bit causes %^H to be lexically scoped.
316
317 $^H |= 0x020000;
318
319 # Our package guard gets invoked when we leave our lexical
320 # scope.
321
322 push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
323 $class->_install_subs($pkg, \%unload_later);
324110µs }));
# spent 10µs making 1 call to autodie::Scope::Guard::new
325
326 # To allow others to determine when autodie was in scope,
327 # and with what arguments, we also set a %^H hint which
328 # is how we were called.
329
330 # This feature should be considered EXPERIMENTAL, and
331 # may change without notice. Please e-mail pjf@cpan.org
332 # if you're actually using it.
333
334 $^H{autodie} = "$PACKAGE @original_args";
335
336 }
337
338 return;
339
340}
341
342# The code here is originally lifted from namespace::clean,
343# by Robert "phaylon" Sedlacek.
344#
345# It's been redesigned after feedback from ikegami on perlmonks.
346# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
347#
348# Given a package, and hash of (subname => subref) pairs,
349# we install the given subroutines into the package. If
350# a subref is undef, the subroutine is removed. Otherwise
351# it replaces any existing subs which were already there.
352
353
# spent 89µs within Fatal::_install_subs which was called 2 times, avg 45µs/call: # 2 times (89µs+0s) by Fatal::_make_fatal at line 1198, avg 45µs/call
sub _install_subs {
35432108µs my ($class, $pkg, $subs_to_reinstate) = @_;
355
356 my $pkg_sym = "${pkg}::";
357
358 while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
359
360 my $full_path = $pkg_sym.$sub_name;
361
362 # Copy symbols across to temp area.
363
364240µs279µs
# spent 48µs (17+31) within Fatal::BEGIN@364 which was called: # once (17µs+31µs) by autodie::BEGIN@6 at line 364
no strict 'refs'; ## no critic
# spent 48µs making 1 call to Fatal::BEGIN@364 # spent 31µs making 1 call to strict::unimport
365
366 local *__tmp = *{ $full_path };
367
368 # Nuke the old glob.
369266µs220µs
# spent 15µs (11+5) within Fatal::BEGIN@369 which was called: # once (11µs+5µs) by autodie::BEGIN@6 at line 369
{ no strict; delete $pkg_sym->{$sub_name}; } ## no critic
# spent 15µs making 1 call to Fatal::BEGIN@369 # spent 4µs making 1 call to strict::unimport
370
371 # Copy innocent bystanders back. Note that we lose
372 # formats; it seems that Perl versions up to 5.10.0
373 # have a bug which causes copying formats to end up in
374 # the scalar slot. Thanks to Ben Morrow for spotting this.
375
376 foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
377 next unless defined *__tmp{ $slot };
378 *{ $full_path } = *__tmp{ $slot };
379 }
380
381 # Put back the old sub (if there was one).
382
383 if ($sub_ref) {
384
38522.04ms222µs
# spent 17µs (12+5) within Fatal::BEGIN@385 which was called: # once (12µs+5µs) by autodie::BEGIN@6 at line 385
no strict; ## no critic
# spent 17µs making 1 call to Fatal::BEGIN@385 # spent 5µs making 1 call to strict::unimport
386 *{ $pkg_sym . $sub_name } = $sub_ref;
387 }
388 }
389
390 return;
391}
392
393sub unimport {
394 my $class = shift;
395
396 # Calling "no Fatal" must start with ":lexical"
397 if ($_[0] ne LEXICAL_TAG) {
398 croak(sprintf(ERROR_NO_LEX,$class));
399 }
400
401 shift @_; # Remove :lexical
402
403 my $pkg = (caller)[0];
404
405 # If we've been called with arguments, then the developer
406 # has explicitly stated 'no autodie qw(blah)',
407 # in which case, we disable Fatalistic behaviour for 'blah'.
408
409 my @unimport_these = @_ ? @_ : ':all';
410
411 while (my $symbol = shift @unimport_these) {
412
413 if ($symbol =~ /^:/) {
414
415 # Looks like a tag! Expand it!
416 push(@unimport_these, @{ $TAGS{$symbol} });
417
418 next;
419 }
420
421 my $sub = $symbol;
422 $sub = "${pkg}::$sub" unless $sub =~ /::/;
423
424 # If 'blah' was already enabled with Fatal (which has package
425 # scope) then, this is considered an error.
426
427 if (exists $Package_Fatal{$sub}) {
428 croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
429 }
430
431 # Record 'no autodie qw($sub)' as being in effect.
432 # This is to catch conflicting semantics elsewhere
433 # (eg, mixing Fatal with no autodie)
434
435 $^H{$NO_PACKAGE}{$sub} = 1;
436
437 if (my $original_sub = $Original_user_sub{$sub}) {
438 # Hey, we've got an original one of these, put it back.
439 $class->_install_subs($pkg, { $symbol => $original_sub });
440 next;
441 }
442
443 # We don't have an original copy of the sub, on the assumption
444 # it's core (or doesn't exist), we'll just nuke it.
445
446 $class->_install_subs($pkg,{ $symbol => undef });
447
448 }
449
450 return;
451
452}
453
454# TODO - This is rather terribly inefficient right now.
455
456# NB: Perl::Critic's dump-autodie-tag-contents depends upon this
457# continuing to work.
458
459{
46023µs my %tag_cache;
461
462 sub _expand_tag {
463 my ($class, $tag) = @_;
464
465 if (my $cached = $tag_cache{$tag}) {
466 return $cached;
467 }
468
469 if (not exists $TAGS{$tag}) {
470 croak "Invalid exception class $tag";
471 }
472
473 my @to_process = @{$TAGS{$tag}};
474
475 my @taglist = ();
476
477 while (my $item = shift @to_process) {
478 if ($item =~ /^:/) {
479 # Expand :tags
480 push(@to_process, @{$TAGS{$item}} );
481 }
482 else {
483 push(@taglist, "CORE::$item");
484 }
485 }
486
487 $tag_cache{$tag} = \@taglist;
488
489 return \@taglist;
490
491 }
492
493}
494
495# This code is from the original Fatal. It scares me.
496# It is 100% compatible with the 5.10.0 Fatal module, right down
497# to the scary 'XXXX' comment. ;)
498
499
# spent 172µs (127+45) within Fatal::fill_protos which was called 2 times, avg 86µs/call: # 2 times (127µs+45µs) by Fatal::_make_fatal at line 1081, avg 86µs/call
sub fill_protos {
50039173µs my $proto = shift;
501 my ($n, $isref, @out, @out1, $seen_semi) = -1;
502713µs while ($proto =~ /\S/) {
# spent 13µs making 7 calls to Fatal::CORE:match, avg 2µs/call
503 $n++;
504 push(@out1,[$n,@out]) if $seen_semi;
50568µs push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
# spent 8µs making 6 calls to Fatal::CORE:subst, avg 1µs/call
506612µs push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
# spent 12µs making 6 calls to Fatal::CORE:subst, avg 2µs/call
50738µs push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
# spent 8µs making 3 calls to Fatal::CORE:subst, avg 3µs/call
50824µs $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
# spent 4µs making 2 calls to Fatal::CORE:subst, avg 2µs/call
509 die "Internal error: Unknown prototype letters: \"$proto\"";
510 }
511 push(@out1,[$n+1,@out]);
512 return @out1;
513}
514
515# This is a backwards compatible version of _write_invocation. It's
516# recommended you don't use it.
517
518sub write_invocation {
519 my ($core, $call, $name, $void, @args) = @_;
520
521 return Fatal->_write_invocation(
522 $core, $call, $name, $void,
523 0, # Lexical flag
524 undef, # Sub, unused in legacy mode
525 undef, # Subref, unused in legacy mode.
526 @args
527 );
528}
529
530# This version of _write_invocation is used internally. It's not
531# recommended you call it from external code, as the interface WILL
532# change in the future.
533
534
# spent 311µs (139+173) within Fatal::_write_invocation which was called 2 times, avg 156µs/call: # 2 times (139µs+173µs) by Fatal::_make_fatal at line 1082, avg 156µs/call
sub _write_invocation {
535
53649140µs my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
537
538 if (@argvs == 1) { # No optional arguments
539
540 my @argv = @{$argvs[0]};
541 shift @argv;
542
543 return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
544
545 } else {
546 my $else = "\t";
547 my (@out, @argv, $n);
548 while (@argvs) {
549 @argv = @{shift @argvs};
550 $n = shift @argv;
551
552 my $condition = "\@_ == $n";
553
55446µs if (@argv and $argv[-1] =~ /#_/) {
# spent 6µs making 4 calls to Fatal::CORE:match, avg 1µs/call
555 # This argv ends with '@' in the prototype, so it matches
556 # any number of args >= the number of expressions in the
557 # argv.
558 $condition = "\@_ >= $n";
559 }
560
561 push @out, "${else}if ($condition) {\n";
562
563 $else = "\t} els";
564
5655167µs push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
# spent 167µs making 5 calls to Fatal::_one_invocation, avg 33µs/call
566 }
567 push @out, qq[
568 }
569 die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
570 ];
571
572 return join '', @out;
573 }
574}
575
576
577# This is a slim interface to ensure backward compatibility with
578# anyone doing very foolish things with old versions of Fatal.
579
580sub one_invocation {
581 my ($core, $call, $name, $void, @argv) = @_;
582
583 return Fatal->_one_invocation(
584 $core, $call, $name, $void,
585 undef, # Sub. Unused in back-compat mode.
586 1, # Back-compat flag
587 undef, # Subref, unused in back-compat mode.
588 @argv
589 );
590
591}
592
593# This is the internal interface that generates code.
594# NOTE: This interface WILL change in the future. Please do not
595# call this subroutine directly.
596
597# TODO: Whatever's calling this code has already looked up hints. Pass
598# them in, rather than look them up a second time.
599
600
# spent 167µs within Fatal::_one_invocation which was called 5 times, avg 33µs/call: # 5 times (167µs+0s) by Fatal::_write_invocation at line 565, avg 33µs/call
sub _one_invocation {
60190173µs my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
602
603
604 # If someone is calling us directly (a child class perhaps?) then
605 # they could try to mix void without enabling backwards
606 # compatibility. We just don't support this at all, so we gripe
607 # about it rather than doing something unwise.
608
609 if ($void and not $back_compat) {
610 Carp::confess("Internal error: :void mode not supported with $class");
611 }
612
613 # @argv only contains the results of the in-built prototype
614 # function, and is therefore safe to interpolate in the
615 # code generators below.
616
617 # TODO - The following clobbers context, but that's what the
618 # old Fatal did. Do we care?
619
620 if ($back_compat) {
621
622 # Use Fatal qw(system) will never be supported. It generated
623 # a compile-time error with legacy Fatal, and there's no reason
624 # to support it when autodie does a better job.
625
626 if ($call eq 'CORE::system') {
627 return q{
628 croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
629 };
630 }
631
632 local $" = ', ';
633
634 if ($void) {
635 return qq/return (defined wantarray)?$call(@argv):
636 $call(@argv) || Carp::croak("Can't $name(\@_)/ .
637 ($core ? ': $!' : ', \$! is \"$!\"') . '")'
638 } else {
639 return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
640 ($core ? ': $!' : ', \$! is \"$!\"') . '")';
641 }
642 }
643
644 # The name of our original function is:
645 # $call if the function is CORE
646 # $sub if our function is non-CORE
647
648 # The reason for this is that $call is what we're actualling
649 # calling. For our core functions, this is always
650 # CORE::something. However for user-defined subs, we're about to
651 # replace whatever it is that we're calling; as such, we actually
652 # calling a subroutine ref.
653
654 my $human_sub_name = $core ? $call : $sub;
655
656 # Should we be testing to see if our result is defined, or
657 # just true?
658
659 my $use_defined_or;
660
661 my $hints; # All user-sub hints, including list hints.
662
663 if ( $core ) {
664
665 # Core hints are built into autodie.
666
667 $use_defined_or = exists ( $Use_defined_or{$call} );
668
669 }
670 else {
671
672 # User sub hints are looked up using autodie::hints,
673 # since users may wish to add their own hints.
674
675 require autodie::hints;
676
677 $hints = autodie::hints->get_hints_for( $sref );
678
679 # We'll look up the sub's fullname. This means we
680 # get better reports of where it came from in our
681 # error messages, rather than what imported it.
682
683 $human_sub_name = autodie::hints->sub_fullname( $sref );
684
685 }
686
687 # Checks for special core subs.
688
689 if ($call eq 'CORE::system') {
690
691 # Leverage IPC::System::Simple if we're making an autodying
692 # system.
693
694 local $" = ", ";
695
696 # We need to stash $@ into $E, rather than using
697 # local $@ for the whole sub. If we don't then
698 # any exceptions from internal errors in autodie/Fatal
699 # will mysteriously disappear before propogating
700 # upwards.
701
702 return qq{
703 my \$retval;
704 my \$E;
705
706
707 {
708 local \$@;
709
710 eval {
711 \$retval = IPC::System::Simple::system(@argv);
712 };
713
714 \$E = \$@;
715 }
716
717 if (\$E) {
718
719 # TODO - This can't be overridden in child
720 # classes!
721
722 die autodie::exception::system->new(
723 function => q{CORE::system}, args => [ @argv ],
724 message => "\$E", errno => \$!,
725 );
726 }
727
728 return \$retval;
729 };
730
731 }
732
733 local $" = ', ';
734
735 # If we're going to throw an exception, here's the code to use.
736 my $die = qq{
737 die $class->throw(
738 function => q{$human_sub_name}, args => [ @argv ],
739 pragma => q{$class}, errno => \$!,
740 context => \$context, return => \$retval,
741 eval_error => \$@
742 )
743 };
744
745 if ($call eq 'CORE::flock') {
746
747 # flock needs special treatment. When it fails with
748 # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
749 # means we couldn't get the lock right now.
750
751 require POSIX; # For POSIX::EWOULDBLOCK
752
753 local $@; # Don't blat anyone else's $@.
754
755 # Ensure that our vendor supports EWOULDBLOCK. If they
756 # don't (eg, Windows), then we use known values for its
757 # equivalent on other systems.
758
759 my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
760 || $_EWOULDBLOCK{$^O}
761 || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
762 my $EAGAIN = $EWOULDBLOCK;
763 if ($try_EAGAIN) {
764 $EAGAIN = eval { POSIX::EAGAIN(); }
765 || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
766 }
767
768 require Fcntl; # For Fcntl::LOCK_NB
769
770 return qq{
771
772 my \$context = wantarray() ? "list" : "scalar";
773
774 # Try to flock. If successful, return it immediately.
775
776 my \$retval = $call(@argv);
777 return \$retval if \$retval;
778
779 # If we failed, but we're using LOCK_NB and
780 # returned EWOULDBLOCK, it's not a real error.
781
782 if (\$_[1] & Fcntl::LOCK_NB() and
783 (\$! == $EWOULDBLOCK or
784 ($try_EAGAIN and \$! == $EAGAIN ))) {
785 return \$retval;
786 }
787
788 # Otherwise, we failed. Die noisily.
789
790 $die;
791
792 };
793 }
794
795 # AFAIK everything that can be given an unopned filehandle
796 # will fail if it tries to use it, so we don't really need
797 # the 'unopened' warning class here. Especially since they
798 # then report the wrong line number.
799
800 # Other warnings are disabled because they produce excessive
801 # complaints from smart-match hints under 5.10.1.
802
803 my $code = qq[
804 no warnings qw(unopened uninitialized numeric);
805
806 if (wantarray) {
807 my \@results = $call(@argv);
808 my \$retval = \\\@results;
809 my \$context = "list";
810
811 ];
812
813 if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
814
815 # NB: Subroutine hints are passed as a full list.
816 # This differs from the 5.10.0 smart-match behaviour,
817 # but means that context unaware subroutines can use
818 # the same hints in both list and scalar context.
819
820 $code .= qq{
821 if ( \$hints->{list}->(\@results) ) { $die };
822 };
823 }
824 elsif ( PERL510 and $hints ) {
825 $code .= qq{
826 if ( \@results ~~ \$hints->{list} ) { $die };
827 };
828 }
829 elsif ( $hints ) {
830 croak sprintf(ERROR_58_HINTS, 'list', $sub);
831 }
832 else {
833 $code .= qq{
834 # An empty list, or a single undef is failure
835 if (! \@results or (\@results == 1 and ! defined \$results[0])) {
836 $die;
837 }
838 }
839 }
840
841 # Tidy up the end of our wantarray call.
842
843 $code .= qq[
844 return \@results;
845 }
846 ];
847
848
849 # Otherwise, we're in scalar context.
850 # We're never in a void context, since we have to look
851 # at the result.
852
853 $code .= qq{
854 my \$retval = $call(@argv);
855 my \$context = "scalar";
856 };
857
858 if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
859
860 # We always call code refs directly, since that always
861 # works in 5.8.x, and always works in 5.10.1
862
863 return $code .= qq{
864 if ( \$hints->{scalar}->(\$retval) ) { $die };
865 return \$retval;
866 };
867
868 }
869 elsif (PERL510 and $hints) {
870 return $code . qq{
871
872 if ( \$retval ~~ \$hints->{scalar} ) { $die };
873
874 return \$retval;
875 };
876 }
877 elsif ( $hints ) {
878 croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
879 }
880
881 return $code .
882 ( $use_defined_or ? qq{
883
884 $die if not defined \$retval;
885
886 return \$retval;
887
888 } : qq{
889
890 return \$retval || $die;
891
892 } ) ;
893
894}
895
896# This returns the old copy of the sub, so we can
897# put it back at end of scope.
898
899# TODO : Check to make sure prototypes are restored correctly.
900
901# TODO: Taking a huge list of arguments is awful. Rewriting to
902# take a hash would be lovely.
903
904# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
905
906
# spent 2.56ms (1.71+855µs) within Fatal::_make_fatal which was called 2 times, avg 1.28ms/call: # 2 times (1.71ms+855µs) by Fatal::import at line 291, avg 1.28ms/call
sub _make_fatal {
907119865µs my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
908 my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
909 my $ini = $sub;
910
91123µs $sub = "${pkg}::$sub" unless $sub =~ /::/;
# spent 3µs making 2 calls to Fatal::CORE:match, avg 2µs/call
912
913 # Figure if we're using lexical or package semantics and
914 # twiddle the appropriate bits.
915
916 if (not $lexical) {
917 $Package_Fatal{$sub} = 1;
918 }
919
920 # TODO - We *should* be able to do skipping, since we know when
921 # we've lexicalised / unlexicalised a subroutine.
922
923 $name = $sub;
92429µs $name =~ s/.*::// or $name =~ s/^&//;
# spent 9µs making 2 calls to Fatal::CORE:subst, avg 5µs/call
925
926 warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
92726µs croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
# spent 6µs making 2 calls to Fatal::CORE:match, avg 3µs/call
928
929 if (defined(&$sub)) { # user subroutine
930
931 # NOTE: Previously we would localise $@ at this point, so
932 # the following calls to eval {} wouldn't interfere with anything
933 # that's already in $@. Unfortunately, it would also stop
934 # any of our croaks from triggering(!), which is even worse.
935
936 # This could be something that we've fatalised that
937 # was in core.
938
939 if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
940
941 # Something we previously made Fatal that was core.
942 # This is safe to replace with an autodying to core
943 # version.
944
945 $core = 1;
946 $call = "CORE::$name";
947 $proto = prototype $call;
948
949 # We return our $sref from this subroutine later
950 # on, indicating this subroutine should be placed
951 # back when we're finished.
952
953 $sref = \&$sub;
954
955 } else {
956
957 # If this is something we've already fatalised or played with,
958 # then look-up the name of the original sub for the rest of
959 # our processing.
960
961 $sub = $Is_fatalised_sub{\&$sub} || $sub;
962
963 # A regular user sub, or a user sub wrapping a
964 # core sub.
965
966 $sref = \&$sub;
967 $proto = prototype $sref;
968 $call = '&$sref';
969 require autodie::hints;
970
971 $hints = autodie::hints->get_hints_for( $sref );
972
973 # If we've insisted on hints, but don't have them, then
974 # bail out!
975
976 if ($insist and not $hints) {
977 croak(sprintf(ERROR_NOHINTS, $name));
978 }
979
980 # Otherwise, use the default hints if we don't have
981 # any.
982
983 $hints ||= autodie::hints::DEFAULT_HINTS();
984
985 }
986
987 } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
988 # Stray user subroutine
989 croak(sprintf(ERROR_NOTSUB,$sub));
990
991 } elsif ($name eq 'system') {
992
993 # If we're fatalising system, then we need to load
994 # helper code.
995
996 # The business with $E is to avoid clobbering our caller's
997 # $@, and to avoid $@ being localised when we croak.
998
999 my $E;
1000
1001 {
1002 local $@;
1003
1004 eval {
1005 require IPC::System::Simple; # Only load it if we need it.
1006 require autodie::exception::system;
1007 };
1008 $E = $@;
1009 }
1010
1011 if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
1012
1013 # Make sure we're using a recent version of ISS that actually
1014 # support fatalised system.
1015 if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
1016 croak sprintf(
1017 ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
1018 $IPC::System::Simple::VERSION
1019 );
1020 }
1021
1022 $call = 'CORE::system';
1023 $name = 'system';
1024 $core = 1;
1025
1026 } elsif ($name eq 'exec') {
1027 # Exec doesn't have a prototype. We don't care. This
1028 # breaks the exotic form with lexical scope, and gives
1029 # the regular form a "do or die" beaviour as expected.
1030
1031 $call = 'CORE::exec';
1032 $name = 'exec';
1033 $core = 1;
1034
1035 } else { # CORE subroutine
1036 my $E;
1037 {
1038 local $@;
1039 $proto = eval { prototype "CORE::$name" };
1040 $E = $@;
1041 }
1042 croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
1043 croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
1044 $core = 1;
1045 $call = "CORE::$name";
1046 }
1047
1048 if (defined $proto) {
1049 $real_proto = " ($proto)";
1050 } else {
1051 $real_proto = '';
1052 $proto = '@';
1053 }
1054
1055 my $true_name = $core ? $call : $sub;
1056
1057 # TODO: This caching works, but I don't like using $void and
1058 # $lexical as keys. In particular, I suspect our code may end up
1059 # wrapping already wrapped code when autodie and Fatal are used
1060 # together.
1061
1062 # NB: We must use '$sub' (the name plus package) and not
1063 # just '$name' (the short name) here. Failing to do so
1064 # results code that's in the wrong package, and hence has
1065 # access to the wrong package filehandles.
1066
1067 if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
1068 $class->_install_subs($pkg, { $name => $subref });
1069 return $sref;
1070 }
1071
1072 $code = qq[
1073 sub$real_proto {
1074 local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
1075 ];
1076
1077 # Don't have perl whine if exec fails, since we'll be handling
1078 # the exception now.
1079 $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
1080
10812172µs my @protos = fill_protos($proto);
# spent 172µs making 2 calls to Fatal::fill_protos, avg 86µs/call
10822311µs $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
# spent 311µs making 2 calls to Fatal::_write_invocation, avg 156µs/call
1083 $code .= "}\n";
1084 warn $code if $Debug;
1085
1086 # I thought that changing package was a monumental waste of
1087 # time for CORE subs, since they'll always be the same. However
1088 # that's not the case, since they may refer to package-based
1089 # filehandles (eg, with open).
1090 #
1091 # There is potential to more aggressively cache core subs
1092 # that we know will never want to interact with package variables
1093 # and filehandles.
1094
1095 {
10962567µs275µs
# spent 45µs (16+29) within Fatal::BEGIN@1096 which was called: # once (16µs+29µs) by autodie::BEGIN@6 at line 1096
no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
# spent 45µs making 1 call to Fatal::BEGIN@1096 # spent 30µs making 1 call to strict::unimport
1097
1098 my $E;
1099
1100 {
1101 local $@;
1102 $code = eval("package $pkg; require Carp; $code"); ## no critic
# spent 588µs executing statements in string eval
# includes 45µs spent executing 3 calls to 4 subs defined therein. # spent 294µs executing statements in string eval
# includes 29µs spent executing 2 calls to 3 subs defined therein.
1103 $E = $@;
1104 }
1105
1106 if (not $code) {
1107 croak("Internal error in autodie/Fatal processing $true_name: $E");
1108
1109 }
1110 }
1111
1112 # Now we need to wrap our fatalised sub inside an itty bitty
1113 # closure, which can detect if we've leaked into another file.
1114 # Luckily, we only need to do this for lexical (autodie)
1115 # subs. Fatal subs can leak all they want, it's considered
1116 # a "feature" (or at least backwards compatible).
1117
1118 # TODO: Cache our leak guards!
1119
1120 # TODO: This is pretty hairy code. A lot more tests would
1121 # be really nice for this.
1122
1123 my $leak_guard;
1124
1125 if ($lexical) {
1126
1127 $leak_guard = qq<
1128 package $pkg;
1129
1130 sub$real_proto {
1131
1132 # If we're inside a string eval, we can end up with a
1133 # whacky filename. The following code allows autodie
1134 # to propagate correctly into string evals.
1135
1136 my \$caller_level = 0;
1137
1138 my \$caller;
1139
1140 while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
1141
1142 # If our filename is actually an eval, and we
1143 # reach it, then go to our autodying code immediatately.
1144
1145 goto &\$code if (\$caller eq \$filename);
1146 \$caller_level++;
1147 }
1148
1149 # We're now out of the eval stack.
1150
1151 # If we're called from the correct file, then use the
1152 # autodying code.
1153 goto &\$code if ((caller \$caller_level)[1] eq \$filename);
1154
1155 # Oh bother, we've leaked into another file. Call the
1156 # original code. Note that \$sref may actually be a
1157 # reference to a Fatalised version of a core built-in.
1158 # That's okay, because Fatal *always* leaks between files.
1159
1160 goto &\$sref if \$sref;
1161 >;
1162
1163
1164 # If we're here, it must have been a core subroutine called.
1165 # Warning: The following code may disturb some viewers.
1166
1167 # TODO: It should be possible to combine this with
1168 # write_invocation().
1169
1170 foreach my $proto (@protos) {
1171 local $" = ", "; # So @args is formatted correctly.
1172 my ($count, @args) = @$proto;
1173 $leak_guard .= qq<
1174 if (\@_ == $count) {
1175 return $call(@args);
1176 }
1177 >;
1178 }
1179
1180 $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >;
1181
1182 # warn "$leak_guard\n";
1183
1184 my $E;
1185 {
1186 local $@;
1187
1188 $leak_guard = eval $leak_guard; ## no critic
# spent 6µs executing statements in string eval # spent 6µs executing statements in string eval
1189
1190 $E = $@;
1191 }
1192
1193 die "Internal error in $class: Leak-guard installation failure: $E" if $E;
1194 }
1195
1196 my $installed_sub = $leak_guard || $code;
1197
1198289µs $class->_install_subs($pkg, { $name => $installed_sub });
# spent 89µs making 2 calls to Fatal::_install_subs, avg 45µs/call
1199
1200 $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
1201
1202 # Cache that we've now overriddent this sub. If we get called
1203 # again, we may need to find that find subroutine again (eg, for hints).
1204
120514µs236µs $Is_fatalised_sub{$installed_sub} = $sref;
# spent 36µs making 2 calls to Tie::RefHash::STORE, avg 18µs/call
1206
1207 return $sref;
1208
1209}
1210
1211# This subroutine exists primarily so that child classes can override
1212# it to point to their own exception class. Doing this is significantly
1213# less complex than overriding throw()
1214
1215sub exception_class { return "autodie::exception" };
1216
1217{
121823µs my %exception_class_for;
121911µs my %class_loaded;
1220
1221 sub throw {
1222 my ($class, @args) = @_;
1223
1224 # Find our exception class if we need it.
1225 my $exception_class =
1226 $exception_class_for{$class} ||= $class->exception_class;
1227
1228 if (not $class_loaded{$exception_class}) {
1229 if ($exception_class =~ /[^\w:']/) {
1230 confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
1231 }
1232
1233 # Alas, Perl does turn barewords into modules unless they're
1234 # actually barewords. As such, we're left doing a string eval
1235 # to make sure we load our file correctly.
1236
1237 my $E;
1238
1239 {
1240 local $@; # We can't clobber $@, it's wrong!
1241 eval "require $exception_class"; ## no critic
1242 $E = $@; # Save $E despite ending our local.
1243 }
1244
1245 # We need quotes around $@ to make sure it's stringified
1246 # while still in scope. Without them, we run the risk of
1247 # $@ having been cleared by us exiting the local() block.
1248
1249 confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
1250
1251 $class_loaded{$exception_class}++;
1252
1253 }
1254
1255 return $exception_class->new(@args);
1256 }
1257}
1258
1259# For some reason, dying while replacing our subs doesn't
1260# kill our calling program. It simply stops the loading of
1261# autodie and keeps going with everything else. The _autocroak
1262# sub allows us to die with a vegence. It should *only* ever be
1263# used for serious internal errors, since the results of it can't
1264# be captured.
1265
1266sub _autocroak {
1267 warn Carp::longmess(@_);
1268 exit(255); # Ugh!
1269}
1270
1271package autodie::Scope::Guard;
1272
1273# This code schedules the cleanup of subroutines at the end of
1274# scope. It's directly inspired by chocolateboy's excellent
1275# Scope::Guard module.
1276
1277
# spent 10µs within autodie::Scope::Guard::new which was called: # once (10µs+0s) by Fatal::import at line 324
sub new {
1278213µs my ($class, $handler) = @_;
1279
1280 return bless $handler, $class;
1281}
1282
1283sub DESTROY {
1284 my ($self) = @_;
1285
1286 $self->();
1287}
1288
1289128µs1;
1290
1291__END__
 
# spent 38µs within Fatal::CORE:match which was called 18 times, avg 2µs/call: # 7 times (13µs+0s) by Fatal::fill_protos at line 502, avg 2µs/call # 4 times (6µs+0s) by Fatal::_write_invocation at line 554, avg 1µs/call # 2 times (6µs+0s) by Fatal::_make_fatal at line 927, avg 3µs/call # 2 times (5µs+0s) by Fatal::import at line 276, avg 2µs/call # 2 times (3µs+0s) by Fatal::_make_fatal at line 911, avg 2µs/call # once (6µs+0s) by autodie::BEGIN@6 at line 58
sub Fatal::CORE:match; # opcode
# spent 46µs within Fatal::CORE:subst which was called 21 times, avg 2µs/call: # 6 times (12µs+0s) by Fatal::fill_protos at line 506, avg 2µs/call # 6 times (8µs+0s) by Fatal::fill_protos at line 505, avg 1µs/call # 3 times (8µs+0s) by Fatal::fill_protos at line 507, avg 3µs/call # 2 times (9µs+0s) by Fatal::_make_fatal at line 924, avg 5µs/call # 2 times (4µs+0s) by Fatal::import at line 256, avg 2µs/call # 2 times (4µs+0s) by Fatal::fill_protos at line 508, avg 2µs/call
sub Fatal::CORE:subst; # opcode