This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update autodie to CPAN version 2.20
[perl5.git] / cpan / autodie / lib / Fatal.pm
1 package Fatal;
2
3 # ABSTRACT: Replace functions with equivalents which succeed or die
4
5 use 5.008;  # 5.8.x needed for autodie
6 use Carp;
7 use strict;
8 use warnings;
9 use Tie::RefHash;   # To cache subroutine refs
10 use Config;
11 use Scalar::Util qw(set_prototype);
12
13 use constant PERL510     => ( $] >= 5.010 );
14
15 use constant LEXICAL_TAG => q{:lexical};
16 use constant VOID_TAG    => q{:void};
17 use constant INSIST_TAG  => q{!};
18
19 use constant ERROR_NOARGS    => 'Cannot use lexical %s with no arguments';
20 use constant ERROR_VOID_LEX  => VOID_TAG.' cannot be used with lexical scope';
21 use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
22 use constant ERROR_NO_LEX    => "no %s can only start with ".LEXICAL_TAG;
23 use constant ERROR_BADNAME   => "Bad subroutine name for %s: %s";
24 use constant ERROR_NOTSUB    => "%s is not a Perl subroutine";
25 use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
26 use constant ERROR_NOHINTS   => "No user hints defined for %s";
27
28 use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
29
30 use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
31
32 use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system().  We only have version %f";
33
34 use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
35
36 use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
37
38 use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
39
40 # Older versions of IPC::System::Simple don't support all the
41 # features we need.
42
43 use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
44
45 our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version
46
47 our $Debug ||= 0;
48
49 # EWOULDBLOCK values for systems that don't supply their own.
50 # Even though this is defined with our, that's to help our
51 # test code.  Please don't rely upon this variable existing in
52 # the future.
53
54 our %_EWOULDBLOCK = (
55     MSWin32 => 33,
56 );
57
58 # the linux parisc port has separate EAGAIN and EWOULDBLOCK,
59 # and the kernel returns EAGAIN
60 my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
61
62 # We have some tags that can be passed in for use with import.
63 # These are all assumed to be CORE::
64
65 my %TAGS = (
66     ':io'      => [qw(:dbm :file :filesys :ipc :socket
67                        read seek sysread syswrite sysseek )],
68     ':dbm'     => [qw(dbmopen dbmclose)],
69     ':file'    => [qw(open close flock sysopen fcntl fileno binmode
70                      ioctl truncate)],
71     ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
72                       symlink rmdir readlink umask chmod chown utime)],
73     ':ipc'     => [qw(:msg :semaphore :shm pipe kill)],
74     ':msg'     => [qw(msgctl msgget msgrcv msgsnd)],
75     ':threads' => [qw(fork)],
76     ':semaphore'=>[qw(semctl semget semop)],
77     ':shm'     => [qw(shmctl shmget shmread)],
78     ':system'  => [qw(system exec)],
79
80     # Can we use qw(getpeername getsockname)? What do they do on failure?
81     # TODO - Can socket return false?
82     ':socket'  => [qw(accept bind connect getsockopt listen recv send
83                    setsockopt shutdown socketpair)],
84
85     # Our defaults don't include system(), because it depends upon
86     # an optional module, and it breaks the exotic form.
87     #
88     # This *may* change in the future.  I'd love IPC::System::Simple
89     # to be a dependency rather than a recommendation, and hence for
90     # system() to be autodying by default.
91
92     ':default' => [qw(:io :threads)],
93
94     # Everything in v2.07 and brefore. This was :default less chmod and chown
95     ':v207'    => [qw(:threads :dbm :socket read seek sysread
96                    syswrite sysseek open close flock sysopen fcntl fileno
97                    binmode ioctl truncate opendir closedir chdir link unlink
98                    rename mkdir symlink rmdir readlink umask
99                    :msg :semaphore :shm pipe)],
100
101     # Chmod was added in 2.13
102     ':v213'    => [qw(:v207 chmod)],
103
104     # chown, utime, kill were added in 2.14
105     ':v214'    => [qw(:v213 chown utime kill)],
106
107     # Version specific tags.  These allow someone to specify
108     # use autodie qw(:1.994) and know exactly what they'll get.
109
110     ':1.994' => [qw(:v207)],
111     ':1.995' => [qw(:v207)],
112     ':1.996' => [qw(:v207)],
113     ':1.997' => [qw(:v207)],
114     ':1.998' => [qw(:v207)],
115     ':1.999' => [qw(:v207)],
116     ':1.999_01' => [qw(:v207)],
117     ':2.00'  => [qw(:v207)],
118     ':2.01'  => [qw(:v207)],
119     ':2.02'  => [qw(:v207)],
120     ':2.03'  => [qw(:v207)],
121     ':2.04'  => [qw(:v207)],
122     ':2.05'  => [qw(:v207)],
123     ':2.06'  => [qw(:v207)],
124     ':2.06_01' => [qw(:v207)],
125     ':2.07'  => [qw(:v207)],     # Last release without chmod
126     ':2.08'  => [qw(:v213)],
127     ':2.09'  => [qw(:v213)],
128     ':2.10'  => [qw(:v213)],
129     ':2.11'  => [qw(:v213)],
130     ':2.12'  => [qw(:v213)],
131     ':2.13'  => [qw(:v213)],
132     ':2.14'  => [qw(:default)],
133     ':2.15'  => [qw(:default)],
134     ':2.16'  => [qw(:default)],
135     ':2.17'  => [qw(:default)],
136     ':2.18'  => [qw(:default)],
137     ':2.19'  => [qw(:default)],
138     ':2.20'  => [qw(:default)],
139 );
140
141 # chmod was only introduced in 2.07
142 # chown was only introduced in 2.14
143
144 $TAGS{':all'}  = [ keys %TAGS ];
145
146 # This hash contains subroutines for which we should
147 # subroutine() // die() rather than subroutine() || die()
148
149 my %Use_defined_or;
150
151 # CORE::open returns undef on failure.  It can legitimately return
152 # 0 on success, eg: open(my $fh, '-|') || exec(...);
153
154 @Use_defined_or{qw(
155     CORE::fork
156     CORE::recv
157     CORE::send
158     CORE::open
159     CORE::fileno
160     CORE::read
161     CORE::readlink
162     CORE::sysread
163     CORE::syswrite
164     CORE::sysseek
165     CORE::umask
166 )} = ();
167
168 # Some functions can return true because they changed *some* things, but
169 # not all of them.  This is a list of offending functions, and how many
170 # items to subtract from @_ to determine the "success" value they return.
171
172 my %Returns_num_things_changed = (
173     'CORE::chmod'  => 1,
174     'CORE::chown'  => 2,
175     'CORE::kill'   => 1,  # TODO: Could this return anything on negative args?
176     'CORE::unlink' => 0,
177     'CORE::utime'  => 2,
178 );
179
180 # Optional actions to take on the return value before returning it.
181
182 my %Retval_action = (
183     "CORE::open"        => q{
184
185     # apply the open pragma from our caller
186     if( defined $retval ) {
187         # Get the caller's hint hash
188         my $hints = (caller 0)[10];
189
190         # Decide if we're reading or writing and apply the appropriate encoding
191         # These keys are undocumented.
192         # Match what PerlIO_context_layers() does.  Read gets the read layer,
193         # everything else gets the write layer.
194         my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"};
195
196         # Apply the encoding, if any.
197         if( $encoding ) {
198             binmode $_[0], $encoding;
199         }
200     }
201
202 },
203     "CORE::sysopen"     => q{
204
205     # apply the open pragma from our caller
206     if( defined $retval ) {
207         # Get the caller's hint hash
208         my $hints = (caller 0)[10];
209
210         require Fcntl;
211
212         # Decide if we're reading or writing and apply the appropriate encoding.
213         # Match what PerlIO_context_layers() does.  Read gets the read layer,
214         # everything else gets the write layer.
215         my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY());
216         my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"};
217
218         # Apply the encoding, if any.
219         if( $encoding ) {
220             binmode $_[0], $encoding;
221         }
222     }
223
224 },
225 );
226
227 my %reusable_builtins;
228
229 # "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can
230 # take file and directory handles, which are package depedent."
231 #
232 # You would be correct, except that prototype() returns signatures which don't
233 # allow for passing of globs, and nobody's complained about that. You can
234 # still use \*FILEHANDLE, but that results in a reference coming through,
235 # and it's already pointing to the filehandle in the caller's packge, so
236 # it's all okay.
237
238 @reusable_builtins{qw(
239     CORE::fork
240     CORE::kill
241     CORE::truncate
242     CORE::chdir
243     CORE::link
244     CORE::unlink
245     CORE::rename
246     CORE::mkdir
247     CORE::symlink
248     CORE::rmdir
249     CORE::readlink
250     CORE::umask
251     CORE::chmod
252     CORE::chown
253     CORE::utime
254     CORE::msgctl
255     CORE::msgget
256     CORE::msgrcv
257     CORE::msgsnd
258     CORE::semctl
259     CORE::semget
260     CORE::semop
261     CORE::shmctl
262     CORE::shmget
263     CORE::shmread
264 )} = ();
265
266 # Cached_fatalised_sub caches the various versions of our
267 # fatalised subs as they're produced.  This means we don't
268 # have to build our own replacement of CORE::open and friends
269 # for every single package that wants to use them.
270
271 my %Cached_fatalised_sub = ();
272
273 # Every time we're called with package scope, we record the subroutine
274 # (including package or CORE::) in %Package_Fatal.  This allows us
275 # to detect illegal combinations of autodie and Fatal, and makes sure
276 # we don't accidently make a Fatal function autodying (which isn't
277 # very useful).
278
279 my %Package_Fatal = ();
280
281 # The first time we're called with a user-sub, we cache it here.
282 # In the case of a "no autodie ..." we put back the cached copy.
283
284 my %Original_user_sub = ();
285
286 # Is_fatalised_sub simply records a big map of fatalised subroutine
287 # refs.  It means we can avoid repeating work, or fatalising something
288 # we've already processed.
289
290 my  %Is_fatalised_sub = ();
291 tie %Is_fatalised_sub, 'Tie::RefHash';
292
293 # Our trampoline cache allows us to cache trampolines which are used to
294 # bounce leaked wrapped core subroutines to their actual core counterparts.
295
296 my %Trampoline_cache;
297
298 # We use our package in a few hash-keys.  Having it in a scalar is
299 # convenient.  The "guard $PACKAGE" string is used as a key when
300 # setting up lexical guards.
301
302 my $PACKAGE       = __PACKAGE__;
303 my $PACKAGE_GUARD = "guard $PACKAGE";
304 my $NO_PACKAGE    = "no $PACKAGE";      # Used to detect 'no autodie'
305
306 # Here's where all the magic happens when someone write 'use Fatal'
307 # or 'use autodie'.
308
309 sub import {
310     my $class        = shift(@_);
311     my @original_args = @_;
312     my $void         = 0;
313     my $lexical      = 0;
314     my $insist_hints = 0;
315
316     my ($pkg, $filename) = caller();
317
318     @_ or return;   # 'use Fatal' is a no-op.
319
320     # If we see the :lexical flag, then _all_ arguments are
321     # changed lexically
322
323     if ($_[0] eq LEXICAL_TAG) {
324         $lexical = 1;
325         shift @_;
326
327         # If we see no arguments and :lexical, we assume they
328         # wanted ':default'.
329
330         if (@_ == 0) {
331             push(@_, ':default');
332         }
333
334         # Don't allow :lexical with :void, it's needlessly confusing.
335         if ( grep { $_ eq VOID_TAG } @_ ) {
336             croak(ERROR_VOID_LEX);
337         }
338     }
339
340     if ( grep { $_ eq LEXICAL_TAG } @_ ) {
341         # If we see the lexical tag as the non-first argument, complain.
342         croak(ERROR_LEX_FIRST);
343     }
344
345     my @fatalise_these =  @_;
346
347     # Thiese subs will get unloaded at the end of lexical scope.
348     my %unload_later;
349
350     # Use _translate_import_args to expand tags for us.  It will
351     # pass-through unknown tags (i.e. we have to manually handle
352     # VOID_TAG).
353     #
354     # TODO: Consider how to handle stuff like:
355     #   use autodie qw(:defaults ! :io);
356     #   use Fatal qw(:defaults :void :io);
357     #
358     # The ! and :void is currently not applied to anything in the
359     # example above since duplicates are filtered out.  This has been
360     # autodie's behaviour for quite a while, but it might make sense
361     # to change it so "!" or ":void" applies to stuff after they
362     # appear (even if they are all duplicates).
363     for my $func ($class->_translate_import_args(@fatalise_these)) {
364
365         if ($func eq VOID_TAG) {
366
367             # When we see :void, set the void flag.
368             $void = 1;
369
370         } elsif ($func eq INSIST_TAG) {
371
372             $insist_hints = 1;
373
374         } else {
375
376             # Otherwise, fatalise it.
377
378             # Check to see if there's an insist flag at the front.
379             # If so, remove it, and insist we have hints for this sub.
380             my $insist_this;
381
382             if ($func =~ s/^!//) {
383                 $insist_this = 1;
384             }
385
386             # We're going to make a subroutine fatalistic.
387             # However if we're being invoked with 'use Fatal qw(x)'
388             # and we've already been called with 'no autodie qw(x)'
389             # in the same scope, we consider this to be an error.
390             # Mixing Fatal and autodie effects was considered to be
391             # needlessly confusing on p5p.
392
393             my $sub = $func;
394             $sub = "${pkg}::$sub" unless $sub =~ /::/;
395
396             # If we're being called as Fatal, and we've previously
397             # had a 'no X' in scope for the subroutine, then complain
398             # bitterly.
399
400             if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
401                  croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
402             }
403
404             # We're not being used in a confusing way, so make
405             # the sub fatal.  Note that _make_fatal returns the
406             # old (original) version of the sub, or undef for
407             # built-ins.
408
409             my $sub_ref = $class->_make_fatal(
410                 $func, $pkg, $void, $lexical, $filename,
411                 ( $insist_this || $insist_hints )
412             );
413
414             $Original_user_sub{$sub} ||= $sub_ref;
415
416             # If we're making lexical changes, we need to arrange
417             # for them to be cleaned at the end of our scope, so
418             # record them here.
419
420             $unload_later{$func} = $sub_ref if $lexical;
421         }
422     }
423
424     if ($lexical) {
425
426         # Dark magic to have autodie work under 5.8
427         # Copied from namespace::clean, that copied it from
428         # autobox, that found it on an ancient scroll written
429         # in blood.
430
431         # This magic bit causes %^H to be lexically scoped.
432
433         $^H |= 0x020000;
434
435         # Our package guard gets invoked when we leave our lexical
436         # scope.
437
438         push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
439             $class->_install_subs($pkg, \%unload_later);
440         }));
441
442         # To allow others to determine when autodie was in scope,
443         # and with what arguments, we also set a %^H hint which
444         # is how we were called.
445
446         # This feature should be considered EXPERIMENTAL, and
447         # may change without notice.  Please e-mail pjf@cpan.org
448         # if you're actually using it.
449
450         $^H{autodie} = "$PACKAGE @original_args";
451
452     }
453
454     return;
455
456 }
457
458 # The code here is originally lifted from namespace::clean,
459 # by Robert "phaylon" Sedlacek.
460 #
461 # It's been redesigned after feedback from ikegami on perlmonks.
462 # See http://perlmonks.org/?node_id=693338 .  Ikegami rocks.
463 #
464 # Given a package, and hash of (subname => subref) pairs,
465 # we install the given subroutines into the package.  If
466 # a subref is undef, the subroutine is removed.  Otherwise
467 # it replaces any existing subs which were already there.
468
469 sub _install_subs {
470     my ($class, $pkg, $subs_to_reinstate) = @_;
471
472     my $pkg_sym = "${pkg}::";
473
474     # It does not hurt to do this in a predictable order, and might help debugging.
475     foreach my $sub_name (sort keys %$subs_to_reinstate) {
476         my $sub_ref= $subs_to_reinstate->{$sub_name};
477
478         my $full_path = $pkg_sym.$sub_name;
479
480         # Copy symbols across to temp area.
481
482         no strict 'refs';   ## no critic
483
484         local *__tmp = *{ $full_path };
485
486         # Nuke the old glob.
487         { no strict; delete $pkg_sym->{$sub_name}; }    ## no critic
488
489         # Copy innocent bystanders back.  Note that we lose
490         # formats; it seems that Perl versions up to 5.10.0
491         # have a bug which causes copying formats to end up in
492         # the scalar slot.  Thanks to Ben Morrow for spotting this.
493
494         foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
495             next unless defined *__tmp{ $slot };
496             *{ $full_path } = *__tmp{ $slot };
497         }
498
499         # Put back the old sub (if there was one).
500
501         if ($sub_ref) {
502
503             no strict;  ## no critic
504             *{ $full_path } = $sub_ref;
505         }
506     }
507
508     return;
509 }
510
511 sub unimport {
512     my $class = shift;
513
514     # Calling "no Fatal" must start with ":lexical"
515     if ($_[0] ne LEXICAL_TAG) {
516         croak(sprintf(ERROR_NO_LEX,$class));
517     }
518
519     shift @_;   # Remove :lexical
520
521     my $pkg = (caller)[0];
522
523     # If we've been called with arguments, then the developer
524     # has explicitly stated 'no autodie qw(blah)',
525     # in which case, we disable Fatalistic behaviour for 'blah'.
526
527     my @unimport_these = @_ ? @_ : ':all';
528
529     for my $symbol ($class->_translate_import_args(@unimport_these)) {
530
531         my $sub = $symbol;
532         $sub = "${pkg}::$sub" unless $sub =~ /::/;
533
534         # If 'blah' was already enabled with Fatal (which has package
535         # scope) then, this is considered an error.
536
537         if (exists $Package_Fatal{$sub}) {
538             croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
539         }
540
541         # Record 'no autodie qw($sub)' as being in effect.
542         # This is to catch conflicting semantics elsewhere
543         # (eg, mixing Fatal with no autodie)
544
545         $^H{$NO_PACKAGE}{$sub} = 1;
546
547         if (my $original_sub = $Original_user_sub{$sub}) {
548             # Hey, we've got an original one of these, put it back.
549             $class->_install_subs($pkg, { $symbol => $original_sub });
550             next;
551         }
552
553         # We don't have an original copy of the sub, on the assumption
554         # it's core (or doesn't exist), we'll just nuke it.
555
556         $class->_install_subs($pkg,{ $symbol => undef });
557
558     }
559
560     return;
561
562 }
563
564 sub _translate_import_args {
565     my ($class, @args) = @_;
566     my @result;
567     for my $a (@args){
568         if (exists $TAGS{$a}) {
569             my $expanded = $class->_expand_tag($a);
570             # Strip "CORE::" from all elements in the list as import and
571             # unimport does not handle the "CORE::" prefix too well.
572             #
573             # NB: we use substr as it is faster than s/^CORE::// and
574             # it does not change the elements.
575             push @result, map { substr($_, 6) } @{$expanded};
576         } else {
577             #pass through
578             push @result, $a;
579         }
580     }
581     # If @args < 2, then we have no duplicates (because _expand_tag
582     # does not have duplicates and if it is not a tag, it is just a
583     # single value).  We optimize for this because it is a fairly
584     # common case (e.g. use autodie; or use autodie qw(:all); both
585     # trigger this).
586     return @result if @args < 2;
587
588     my %seen = ();
589     # Yes, this is basically List::MoreUtils's uniq/distinct, but
590     # List::MoreUtils is not in the Perl core and autodie is
591     return grep { !$seen{$_}++ } @result;
592 }
593
594
595 # NB: Perl::Critic's dump-autodie-tag-contents depends upon this
596 # continuing to work.
597
598 {
599     my %tag_cache;
600
601     # Expand a given tag (e.g. ":default") into a listref containing
602     # all sub names covered by that tag.  Each sub is returned as
603     # "CORE::<name>" (i.e. "CORE::open" rather than "open").
604     #
605     # NB: the listref must not be modified.
606     sub _expand_tag {
607         my ($class, $tag) = @_;
608
609         if (my $cached = $tag_cache{$tag}) {
610             return $cached;
611         }
612
613         if (not exists $TAGS{$tag}) {
614             croak "Invalid exception class $tag";
615         }
616
617         my @to_process = @{$TAGS{$tag}};
618
619         # If the tag is basically an alias of another tag (like e.g. ":2.11"),
620         # then just share the resulting reference with the original content (so
621         # we only pay for an extra reference for the alias memory-wise).
622         if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') {
623             # We could do this for "non-tags" as well, but that only occurs
624             # once at the time of writing (":threads" => ["fork"]), so
625             # probably not worth it.
626             my $expanded = $class->_expand_tag($to_process[0]);
627             $tag_cache{$tag} = $expanded;
628             return $expanded;
629         }
630
631         my %seen = ();
632         my @taglist = ();
633
634         for my $item (@to_process) {
635             # substr is more efficient than m/^:/ for stuff like this,
636             # at the price of being a bit more verbose/low-level.
637             if (substr($item, 0, 1) eq ':') {
638                 # Use recursion here to ensure we expand a tag at most once.
639                 #
640                 # TODO: Improve handling of :all so we don't expand
641                 # all those aliases (e.g :2.00..:2.07 are all aliases
642                 # of v2.07).
643
644                 my $expanded = $class->_expand_tag($item);
645                 push @taglist, grep { !$seen{$_}++ } @{$expanded};
646             } else {
647                 my $subname = "CORE::$item";
648                 push @taglist, $subname
649                     unless $seen{$subname}++;
650             }
651         }
652
653         $tag_cache{$tag} = \@taglist;
654
655         return \@taglist;
656
657     }
658
659 }
660
661 # This code is from the original Fatal.  It scares me.
662 # It is 100% compatible with the 5.10.0 Fatal module, right down
663 # to the scary 'XXXX' comment.  ;)
664
665 sub fill_protos {
666     my $proto = shift;
667     my ($n, $isref, @out, @out1, $seen_semi) = -1;
668     if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) {
669         # prototype is entirely slurp - special case that does not
670         # require any handling.
671         return ([0, '@_']);
672     }
673
674     while ($proto =~ /\S/) {
675         $n++;
676         push(@out1,[$n,@out]) if $seen_semi;
677         push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
678         push(@out, "\$_[$n]"),        next if $proto =~ s/^\s*([_*\$&])//;
679         push(@out, "\@_[$n..\$#_]"),  last if $proto =~ s/^\s*(;\s*)?\@//;
680         $seen_semi = 1, $n--,         next if $proto =~ s/^\s*;//; # XXXX ????
681         die "Internal error: Unknown prototype letters: \"$proto\"";
682     }
683     push(@out1,[$n+1,@out]);
684     return @out1;
685 }
686
687 # This is a backwards compatible version of _write_invocation.  It's
688 # recommended you don't use it.
689
690 sub write_invocation {
691     my ($core, $call, $name, $void, @args) = @_;
692
693     return Fatal->_write_invocation(
694         $core, $call, $name, $void,
695         0,      # Lexical flag
696         undef,  # Sub, unused in legacy mode
697         undef,  # Subref, unused in legacy mode.
698         @args
699     );
700 }
701
702 # This version of _write_invocation is used internally.  It's not
703 # recommended you call it from external code, as the interface WILL
704 # change in the future.
705
706 sub _write_invocation {
707
708     my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
709
710     if (@argvs == 1) {        # No optional arguments
711
712         my @argv = @{$argvs[0]};
713         shift @argv;
714
715         return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
716
717     } else {
718         my $else = "\t";
719         my (@out, @argv, $n);
720         while (@argvs) {
721             @argv = @{shift @argvs};
722             $n = shift @argv;
723
724             my $condition = "\@_ == $n";
725
726             if (@argv and $argv[-1] =~ /[#@]_/) {
727                 # This argv ends with '@' in the prototype, so it matches
728                 # any number of args >= the number of expressions in the
729                 # argv.
730                 $condition = "\@_ >= $n";
731             }
732
733             push @out, "${else}if ($condition) {\n";
734
735             $else = "\t} els";
736
737         push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
738         }
739         push @out, qq[
740             }
741             die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
742     ];
743
744         return join '', @out;
745     }
746 }
747
748
749 # This is a slim interface to ensure backward compatibility with
750 # anyone doing very foolish things with old versions of Fatal.
751
752 sub one_invocation {
753     my ($core, $call, $name, $void, @argv) = @_;
754
755     return Fatal->_one_invocation(
756         $core, $call, $name, $void,
757         undef,   # Sub.  Unused in back-compat mode.
758         1,       # Back-compat flag
759         undef,   # Subref, unused in back-compat mode.
760         @argv
761     );
762
763 }
764
765 # This is the internal interface that generates code.
766 # NOTE: This interface WILL change in the future.  Please do not
767 # call this subroutine directly.
768
769 # TODO: Whatever's calling this code has already looked up hints.  Pass
770 # them in, rather than look them up a second time.
771
772 sub _one_invocation {
773     my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
774
775
776     # If someone is calling us directly (a child class perhaps?) then
777     # they could try to mix void without enabling backwards
778     # compatibility.  We just don't support this at all, so we gripe
779     # about it rather than doing something unwise.
780
781     if ($void and not $back_compat) {
782         Carp::confess("Internal error: :void mode not supported with $class");
783     }
784
785     # @argv only contains the results of the in-built prototype
786     # function, and is therefore safe to interpolate in the
787     # code generators below.
788
789     # TODO - The following clobbers context, but that's what the
790     #        old Fatal did.  Do we care?
791
792     if ($back_compat) {
793
794         # Use Fatal qw(system) will never be supported.  It generated
795         # a compile-time error with legacy Fatal, and there's no reason
796         # to support it when autodie does a better job.
797
798         if ($call eq 'CORE::system') {
799             return q{
800                 croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
801             };
802         }
803
804         local $" = ', ';
805
806         if ($void) {
807             return qq/return (defined wantarray)?$call(@argv):
808                    $call(@argv) || Carp::croak("Can't $name(\@_)/ .
809                    ($core ? ': $!' : ', \$! is \"$!\"') . '")'
810         } else {
811             return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
812                    ($core ? ': $!' : ', \$! is \"$!\"') . '")';
813         }
814     }
815
816     # The name of our original function is:
817     #   $call if the function is CORE
818     #   $sub if our function is non-CORE
819
820     # The reason for this is that $call is what we're actually
821     # calling.  For our core functions, this is always
822     # CORE::something.  However for user-defined subs, we're about to
823     # replace whatever it is that we're calling; as such, we actually
824     # calling a subroutine ref.
825
826     my $human_sub_name = $core ? $call : $sub;
827
828     # Should we be testing to see if our result is defined, or
829     # just true?
830
831     my $use_defined_or;
832
833     my $hints;      # All user-sub hints, including list hints.
834
835     if ( $core ) {
836
837         # Core hints are built into autodie.
838
839         $use_defined_or = exists ( $Use_defined_or{$call} );
840
841     }
842     else {
843
844         # User sub hints are looked up using autodie::hints,
845         # since users may wish to add their own hints.
846
847         require autodie::hints;
848
849         $hints = autodie::hints->get_hints_for( $sref );
850
851         # We'll look up the sub's fullname.  This means we
852         # get better reports of where it came from in our
853         # error messages, rather than what imported it.
854
855         $human_sub_name = autodie::hints->sub_fullname( $sref );
856
857     }
858
859     # Checks for special core subs.
860
861     if ($call eq 'CORE::system') {
862
863         # Leverage IPC::System::Simple if we're making an autodying
864         # system.
865
866         local $" = ", ";
867
868         # We need to stash $@ into $E, rather than using
869         # local $@ for the whole sub.  If we don't then
870         # any exceptions from internal errors in autodie/Fatal
871         # will mysteriously disappear before propagating
872         # upwards.
873
874         return qq{
875             my \$retval;
876             my \$E;
877
878
879             {
880                 local \$@;
881
882                 eval {
883                     \$retval = IPC::System::Simple::system(@argv);
884                 };
885
886                 \$E = \$@;
887             }
888
889             if (\$E) {
890
891                 # TODO - This can't be overridden in child
892                 # classes!
893
894                 die autodie::exception::system->new(
895                     function => q{CORE::system}, args => [ @argv ],
896                     message => "\$E", errno => \$!,
897                 );
898             }
899
900             return \$retval;
901         };
902
903     }
904
905     local $" = ', ';
906
907     # If we're going to throw an exception, here's the code to use.
908     my $die = qq{
909         die $class->throw(
910             function => q{$human_sub_name}, args => [ @argv ],
911             pragma => q{$class}, errno => \$!,
912             context => \$context, return => \$retval,
913             eval_error => \$@
914         )
915     };
916
917     if ($call eq 'CORE::flock') {
918
919         # flock needs special treatment.  When it fails with
920         # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
921         # means we couldn't get the lock right now.
922
923         require POSIX;      # For POSIX::EWOULDBLOCK
924
925         local $@;   # Don't blat anyone else's $@.
926
927         # Ensure that our vendor supports EWOULDBLOCK.  If they
928         # don't (eg, Windows), then we use known values for its
929         # equivalent on other systems.
930
931         my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
932                           || $_EWOULDBLOCK{$^O}
933                           || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
934         my $EAGAIN = $EWOULDBLOCK;
935         if ($try_EAGAIN) {
936             $EAGAIN = eval { POSIX::EAGAIN(); }
937                           || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
938         }
939
940         require Fcntl;      # For Fcntl::LOCK_NB
941
942         return qq{
943
944             my \$context = wantarray() ? "list" : "scalar";
945
946             # Try to flock.  If successful, return it immediately.
947
948             my \$retval = $call(@argv);
949             return \$retval if \$retval;
950
951             # If we failed, but we're using LOCK_NB and
952             # returned EWOULDBLOCK, it's not a real error.
953
954             if (\$_[1] & Fcntl::LOCK_NB() and
955                 (\$! == $EWOULDBLOCK or
956                 ($try_EAGAIN and \$! == $EAGAIN ))) {
957                 return \$retval;
958             }
959
960             # Otherwise, we failed.  Die noisily.
961
962             $die;
963
964         };
965     }
966
967     if (exists $Returns_num_things_changed{$call}) {
968
969         # Some things return the number of things changed (like
970         # chown, kill, chmod, etc). We only consider these successful
971         # if *all* the things are changed.
972
973         return qq[
974             my \$num_things = \@_ - $Returns_num_things_changed{$call};
975             my \$retval = $call(@argv);
976
977             if (\$retval != \$num_things) {
978
979                 # We need \$context to throw an exception.
980                 # It's *always* set to scalar, because that's how
981                 # autodie calls chown() above.
982
983                 my \$context = "scalar";
984                 $die;
985             }
986
987             return \$retval;
988         ];
989     }
990
991     # AFAIK everything that can be given an unopned filehandle
992     # will fail if it tries to use it, so we don't really need
993     # the 'unopened' warning class here.  Especially since they
994     # then report the wrong line number.
995
996     # Other warnings are disabled because they produce excessive
997     # complaints from smart-match hints under 5.10.1.
998
999     my $code = qq[
1000         no warnings qw(unopened uninitialized numeric);
1001         no if \$\] >= 5.017011, warnings => "experimental::smartmatch";
1002
1003         if (wantarray) {
1004             my \@results = $call(@argv);
1005             my \$retval  = \\\@results;
1006             my \$context = "list";
1007
1008     ];
1009
1010     my $retval_action = $Retval_action{$call} || '';
1011
1012     if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
1013
1014         # NB: Subroutine hints are passed as a full list.
1015         # This differs from the 5.10.0 smart-match behaviour,
1016         # but means that context unaware subroutines can use
1017         # the same hints in both list and scalar context.
1018
1019         $code .= qq{
1020             if ( \$hints->{list}->(\@results) ) { $die };
1021         };
1022     }
1023     elsif ( PERL510 and $hints ) {
1024         $code .= qq{
1025             if ( \@results ~~ \$hints->{list} ) { $die };
1026         };
1027     }
1028     elsif ( $hints ) {
1029         croak sprintf(ERROR_58_HINTS, 'list', $sub);
1030     }
1031     else {
1032         $code .= qq{
1033             # An empty list, or a single undef is failure
1034             if (! \@results or (\@results == 1 and ! defined \$results[0])) {
1035                 $die;
1036             }
1037         }
1038     }
1039
1040     # Tidy up the end of our wantarray call.
1041
1042     $code .= qq[
1043             return \@results;
1044         }
1045     ];
1046
1047
1048     # Otherwise, we're in scalar context.
1049     # We're never in a void context, since we have to look
1050     # at the result.
1051
1052     $code .= qq{
1053         my \$retval  = $call(@argv);
1054         my \$context = "scalar";
1055     };
1056
1057     if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
1058
1059         # We always call code refs directly, since that always
1060         # works in 5.8.x, and always works in 5.10.1
1061
1062         return $code .= qq{
1063             if ( \$hints->{scalar}->(\$retval) ) { $die };
1064             $retval_action
1065             return \$retval;
1066         };
1067
1068     }
1069     elsif (PERL510 and $hints) {
1070         return $code . qq{
1071
1072             if ( \$retval ~~ \$hints->{scalar} ) { $die };
1073             $retval_action
1074             return \$retval;
1075         };
1076     }
1077     elsif ( $hints ) {
1078         croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
1079     }
1080
1081     return $code .
1082     ( $use_defined_or ? qq{
1083
1084         $die if not defined \$retval;
1085         $retval_action
1086         return \$retval;
1087
1088     } : qq{
1089
1090         $retval_action
1091         return \$retval || $die;
1092
1093     } ) ;
1094
1095 }
1096
1097 # This returns the old copy of the sub, so we can
1098 # put it back at end of scope.
1099
1100 # TODO : Check to make sure prototypes are restored correctly.
1101
1102 # TODO: Taking a huge list of arguments is awful.  Rewriting to
1103 #       take a hash would be lovely.
1104
1105 # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
1106
1107 sub _make_fatal {
1108     my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
1109     my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
1110     my $ini = $sub;
1111
1112     $sub = "${pkg}::$sub" unless $sub =~ /::/;
1113
1114     # Figure if we're using lexical or package semantics and
1115     # twiddle the appropriate bits.
1116
1117     if (not $lexical) {
1118         $Package_Fatal{$sub} = 1;
1119     }
1120
1121     # TODO - We *should* be able to do skipping, since we know when
1122     # we've lexicalised / unlexicalised a subroutine.
1123
1124     $name = $sub;
1125     $name =~ s/.*::// or $name =~ s/^&//;
1126
1127     warn  "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
1128     croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
1129
1130     if (defined(&$sub)) {   # user subroutine
1131
1132         # NOTE: Previously we would localise $@ at this point, so
1133         # the following calls to eval {} wouldn't interfere with anything
1134         # that's already in $@.  Unfortunately, it would also stop
1135         # any of our croaks from triggering(!), which is even worse.
1136
1137         # This could be something that we've fatalised that
1138         # was in core.
1139
1140         if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
1141
1142             # Something we previously made Fatal that was core.
1143             # This is safe to replace with an autodying to core
1144             # version.
1145
1146             $core  = 1;
1147             $call  = "CORE::$name";
1148             $proto = prototype $call;
1149
1150             # We return our $sref from this subroutine later
1151             # on, indicating this subroutine should be placed
1152             # back when we're finished.
1153
1154             $sref = \&$sub;
1155
1156         } else {
1157
1158             # If this is something we've already fatalised or played with,
1159             # then look-up the name of the original sub for the rest of
1160             # our processing.
1161
1162             $sub = $Is_fatalised_sub{\&$sub} || $sub;
1163
1164             # A regular user sub, or a user sub wrapping a
1165             # core sub.
1166
1167             $sref = \&$sub;
1168             $proto = prototype $sref;
1169             $call = '&$sref';
1170             require autodie::hints;
1171
1172             $hints = autodie::hints->get_hints_for( $sref );
1173
1174             # If we've insisted on hints, but don't have them, then
1175             # bail out!
1176
1177             if ($insist and not $hints) {
1178                 croak(sprintf(ERROR_NOHINTS, $name));
1179             }
1180
1181             # Otherwise, use the default hints if we don't have
1182             # any.
1183
1184             $hints ||= autodie::hints::DEFAULT_HINTS();
1185
1186         }
1187
1188     } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
1189         # Stray user subroutine
1190         croak(sprintf(ERROR_NOTSUB,$sub));
1191
1192     } elsif ($name eq 'system') {
1193
1194         # If we're fatalising system, then we need to load
1195         # helper code.
1196
1197         # The business with $E is to avoid clobbering our caller's
1198         # $@, and to avoid $@ being localised when we croak.
1199
1200         my $E;
1201
1202         {
1203             local $@;
1204
1205             eval {
1206                 require IPC::System::Simple; # Only load it if we need it.
1207                 require autodie::exception::system;
1208             };
1209             $E = $@;
1210         }
1211
1212         if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
1213
1214         # Make sure we're using a recent version of ISS that actually
1215         # support fatalised system.
1216         if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
1217             croak sprintf(
1218             ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
1219             $IPC::System::Simple::VERSION
1220             );
1221         }
1222
1223         $call = 'CORE::system';
1224         $name = 'system';
1225         $core = 1;
1226
1227     } elsif ($name eq 'exec') {
1228         # Exec doesn't have a prototype.  We don't care.  This
1229         # breaks the exotic form with lexical scope, and gives
1230         # the regular form a "do or die" behavior as expected.
1231
1232         $call = 'CORE::exec';
1233         $name = 'exec';
1234         $core = 1;
1235
1236     } else {            # CORE subroutine
1237         my $E;
1238         {
1239             local $@;
1240             $proto = eval { prototype "CORE::$name" };
1241             $E = $@;
1242         }
1243         croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
1244         croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
1245         $core = 1;
1246         $call = "CORE::$name";
1247     }
1248
1249     my $true_name = $core ? $call : $sub;
1250
1251     # TODO: This caching works, but I don't like using $void and
1252     # $lexical as keys.  In particular, I suspect our code may end up
1253     # wrapping already wrapped code when autodie and Fatal are used
1254     # together.
1255
1256     # NB: We must use '$sub' (the name plus package) and not
1257     # just '$name' (the short name) here.  Failing to do so
1258     # results code that's in the wrong package, and hence has
1259     # access to the wrong package filehandles.
1260
1261     if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
1262         $class->_install_subs($pkg, { $name => $subref });
1263         return $sref;
1264     }
1265
1266     # If our subroutine is reusable (ie, not package depdendent),
1267     # then check to see if we've got a cached copy, and use that.
1268     # See RT #46984. (Thanks to Niels Thykier for being awesome!)
1269
1270     if ($core && exists $reusable_builtins{$call}) {
1271         # For non-lexical subs, we can just use this cache directly
1272         # - for lexical variants, we need a leak guard as well.
1273         $code = $reusable_builtins{$call}{$lexical};
1274         if (!$lexical && defined($code)) {
1275             $class->_install_subs($pkg, { $name => $code });
1276             return $sref;
1277         }
1278     }
1279
1280     if (defined $proto) {
1281         $real_proto = " ($proto)";
1282     } else {
1283         $real_proto = '';
1284         $proto = '@';
1285     }
1286
1287     if (!defined($code)) {
1288         # No code available, generate it now.
1289         my @protos = fill_protos($proto);
1290
1291         $code = qq[
1292             sub$real_proto {
1293               local(\$", \$!) = (', ', 0);    # TODO - Why do we do this?
1294         ];
1295
1296         # Don't have perl whine if exec fails, since we'll be handling
1297         # the exception now.
1298         $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
1299
1300         $code .= $class->_write_invocation($core, $call, $name, $void, $lexical,
1301                                            $sub, $sref, @protos);
1302         $code .= "}\n";
1303         warn $code if $Debug;
1304
1305         # I thought that changing package was a monumental waste of
1306         # time for CORE subs, since they'll always be the same.  However
1307         # that's not the case, since they may refer to package-based
1308         # filehandles (eg, with open).
1309         #
1310         # The %reusable_builtins hash defines ones we can aggressively
1311         # cache as they never depend upon package-based symbols.
1312
1313         {
1314             no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
1315
1316             my $E;
1317
1318             {
1319                 local $@;
1320                 if (!exists($reusable_builtins{$call})) {
1321                     $code = eval("package $pkg; require Carp; $code");  ## no critic
1322                 } else {
1323                     $code = eval("require Carp; $code");  ## no critic
1324                     if (exists $reusable_builtins{$call}) {
1325                         # cache it so we don't recompile this part again
1326                         $reusable_builtins{$call}{$lexical} = $code;
1327                     }
1328                 }
1329                 $E = $@;
1330             }
1331
1332             if (not $code) {
1333                 croak("Internal error in autodie/Fatal processing $true_name: $E");
1334
1335             }
1336         }
1337     }
1338
1339     # Now we need to wrap our fatalised sub inside an itty bitty
1340     # closure, which can detect if we've leaked into another file.
1341     # Luckily, we only need to do this for lexical (autodie)
1342     # subs.  Fatal subs can leak all they want, it's considered
1343     # a "feature" (or at least backwards compatible).
1344
1345     # TODO: Cache our leak guards!
1346
1347     # TODO: This is pretty hairy code.  A lot more tests would
1348     # be really nice for this.
1349
1350     my $leak_guard;
1351
1352     if ($lexical) {
1353         $leak_guard = _make_leak_guard($filename, $code, $sref, $call,
1354                                        $pkg, $proto, $real_proto);
1355     }
1356
1357     my $installed_sub = $leak_guard || $code;
1358
1359     $class->_install_subs($pkg, { $name => $installed_sub });
1360
1361     $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
1362
1363     # Cache that we've now overridden this sub.  If we get called
1364     # again, we may need to find that find subroutine again (eg, for hints).
1365
1366     $Is_fatalised_sub{$installed_sub} = $sref;
1367
1368     return $sref;
1369
1370 }
1371
1372 # This subroutine exists primarily so that child classes can override
1373 # it to point to their own exception class.  Doing this is significantly
1374 # less complex than overriding throw()
1375
1376 sub exception_class { return "autodie::exception" };
1377
1378 {
1379     my %exception_class_for;
1380     my %class_loaded;
1381
1382     sub throw {
1383         my ($class, @args) = @_;
1384
1385         # Find our exception class if we need it.
1386         my $exception_class =
1387              $exception_class_for{$class} ||= $class->exception_class;
1388
1389         if (not $class_loaded{$exception_class}) {
1390             if ($exception_class =~ /[^\w:']/) {
1391                 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.";
1392             }
1393
1394             # Alas, Perl does turn barewords into modules unless they're
1395             # actually barewords.  As such, we're left doing a string eval
1396             # to make sure we load our file correctly.
1397
1398             my $E;
1399
1400             {
1401                 local $@;   # We can't clobber $@, it's wrong!
1402                 my $pm_file = $exception_class . ".pm";
1403                 $pm_file =~ s{ (?: :: | ' ) }{/}gx;
1404                 eval { require $pm_file };
1405                 $E = $@;    # Save $E despite ending our local.
1406             }
1407
1408             # We need quotes around $@ to make sure it's stringified
1409             # while still in scope.  Without them, we run the risk of
1410             # $@ having been cleared by us exiting the local() block.
1411
1412             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;
1413
1414             $class_loaded{$exception_class}++;
1415
1416         }
1417
1418         return $exception_class->new(@args);
1419     }
1420 }
1421
1422 # Creates and returns a leak guard (with prototype if needed).
1423 sub _make_leak_guard {
1424     my ($filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto, $real_proto) = @_;
1425
1426     # The leak guard is rather lengthly (in fact it makes up the most
1427     # of _make_leak_guard).  It is possible to split it into a large
1428     # "generic" part and a small wrapper with call-specific
1429     # information.  This was done in v2.19 and profiling suggested
1430     # that we ended up using a substantial amount of runtime in "goto"
1431     # between the leak guard(s) and the final sub.  Therefore, the two
1432     # parts were merged into one to reduce the runtime overhead.
1433
1434     my $leak_guard = sub {
1435         my $caller_level = 0;
1436         my $caller;
1437
1438         while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) {
1439
1440             # If our filename is actually an eval, and we
1441             # reach it, then go to our autodying code immediatately.
1442
1443             last if ($caller eq $filename);
1444             $caller_level++;
1445         }
1446
1447         # We're now out of the eval stack.
1448
1449         if ($caller eq $filename) {
1450             # No leak, call the wrapper.  NB: In this case, it doesn't
1451             # matter if it is a CORE sub or not.
1452             goto $wrapped_sub;
1453         }
1454
1455         # We leaked, time to call the original function.
1456         # - for non-core functions that will be $orig_sub
1457         goto $orig_sub if defined($orig_sub);
1458
1459         # We are wrapping a CORE sub
1460
1461         # If we've cached a trampoline, then use it.
1462         my $trampoline_sub = $Trampoline_cache{$pkg}{$call};
1463
1464         if (not $trampoline_sub) {
1465             # If we don't have a trampoline, we need to build it.
1466             #
1467             # We only generate trampolines when we need them, and
1468             # we can cache them by subroutine + package.
1469
1470             # TODO: Consider caching on reusable_builtins status as well.
1471
1472             $trampoline_sub = _make_core_trampoline($call, $pkg, $proto);
1473
1474             # Let's cache that, so we don't have to do it again.
1475             $Trampoline_cache{$pkg}{$call} = $trampoline_sub;
1476         }
1477
1478         # Bounce to our trampoline, which takes us to our core sub.
1479         goto \&$trampoline_sub;
1480     };  # <-- end of leak guard
1481
1482     # If there is a prototype on the original sub, copy it to the leak
1483     # guard.
1484     if ($real_proto ne '') {
1485         # The "\&" may appear to be redundant but set_prototype
1486         # croaks when it is removed.
1487         set_prototype(\&$leak_guard, $proto);
1488     }
1489
1490     return $leak_guard;
1491 }
1492
1493 # Create a trampoline for calling a core sub.  Essentially, a tiny sub
1494 # that figures out how we should be calling our core sub, puts in the
1495 # arguments in the right way, and bounces our control over to it.
1496 #
1497 # If we could use `goto &` on core builtins, we wouldn't need this.
1498 sub _make_core_trampoline {
1499     my ($call, $pkg, $proto_str) = @_;
1500     my $trampoline_code = 'sub {';
1501     my $trampoline_sub;
1502     my @protos = fill_protos($proto_str);
1503
1504     # TODO: It may be possible to combine this with write_invocation().
1505
1506     foreach my $proto (@protos) {
1507         local $" = ", ";    # So @args is formatted correctly.
1508         my ($count, @args) = @$proto;
1509         if (@args && $args[-1] =~ m/[@#]_/) {
1510             $trampoline_code .= qq/
1511                 if (\@_ >= $count) {
1512                     return $call(@args);
1513                 }
1514              /;
1515         } else {
1516             $trampoline_code .= qq<
1517                 if (\@_ == $count) {
1518                     return $call(@args);
1519                 }
1520              >;
1521         }
1522     }
1523
1524     $trampoline_code .= qq< Carp::croak("Internal error in Fatal/autodie.  Leak-guard failure"); } >;
1525     my $E;
1526
1527     {
1528         local $@;
1529         $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic
1530         $E = $@;
1531     }
1532     die "Internal error in Fatal/autodie: Leak-guard installation failure: $E"
1533         if $E;
1534
1535     return $trampoline_sub;
1536 }
1537
1538 # For some reason, dying while replacing our subs doesn't
1539 # kill our calling program.  It simply stops the loading of
1540 # autodie and keeps going with everything else.  The _autocroak
1541 # sub allows us to die with a vengeance.  It should *only* ever be
1542 # used for serious internal errors, since the results of it can't
1543 # be captured.
1544
1545 sub _autocroak {
1546     warn Carp::longmess(@_);
1547     exit(255);  # Ugh!
1548 }
1549
1550 package autodie::Scope::Guard;
1551
1552 # This code schedules the cleanup of subroutines at the end of
1553 # scope.  It's directly inspired by chocolateboy's excellent
1554 # Scope::Guard module.
1555
1556 sub new {
1557     my ($class, $handler) = @_;
1558
1559     return bless $handler, $class;
1560 }
1561
1562 sub DESTROY {
1563     my ($self) = @_;
1564
1565     $self->();
1566 }
1567
1568 1;
1569
1570 __END__
1571
1572 =head1 NAME
1573
1574 Fatal - Replace functions with equivalents which succeed or die
1575
1576 =head1 SYNOPSIS
1577
1578     use Fatal qw(open close);
1579
1580     open(my $fh, "<", $filename);  # No need to check errors!
1581
1582     use File::Copy qw(move);
1583     use Fatal qw(move);
1584
1585     move($file1, $file2); # No need to check errors!
1586
1587     sub juggle { . . . }
1588     Fatal->import('juggle');
1589
1590 =head1 BEST PRACTICE
1591
1592 B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
1593 L<autodie> in preference to C<Fatal>.  L<autodie> supports lexical scoping,
1594 throws real exception objects, and provides much nicer error messages.
1595
1596 The use of C<:void> with Fatal is discouraged.
1597
1598 =head1 DESCRIPTION
1599
1600 C<Fatal> provides a way to conveniently replace
1601 functions which normally return a false value when they fail with
1602 equivalents which raise exceptions if they are not successful.  This
1603 lets you use these functions without having to test their return
1604 values explicitly on each call.  Exceptions can be caught using
1605 C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
1606
1607 The do-or-die equivalents are set up simply by calling Fatal's
1608 C<import> routine, passing it the names of the functions to be
1609 replaced.  You may wrap both user-defined functions and overridable
1610 CORE operators (except C<exec>, C<system>, C<print>, or any other
1611 built-in that cannot be expressed via prototypes) in this way.
1612
1613 If the symbol C<:void> appears in the import list, then functions
1614 named later in that import list raise an exception only when
1615 these are called in void context--that is, when their return
1616 values are ignored.  For example
1617
1618     use Fatal qw/:void open close/;
1619
1620     # properly checked, so no exception raised on error
1621     if (not open(my $fh, '<', '/bogotic') {
1622         warn "Can't open /bogotic: $!";
1623     }
1624
1625     # not checked, so error raises an exception
1626     close FH;
1627
1628 The use of C<:void> is discouraged, as it can result in exceptions
1629 not being thrown if you I<accidentally> call a method without
1630 void context.  Use L<autodie> instead if you need to be able to
1631 disable autodying/Fatal behaviour for a small block of code.
1632
1633 =head1 DIAGNOSTICS
1634
1635 =over 4
1636
1637 =item Bad subroutine name for Fatal: %s
1638
1639 You've called C<Fatal> with an argument that doesn't look like
1640 a subroutine name, nor a switch that this version of Fatal
1641 understands.
1642
1643 =item %s is not a Perl subroutine
1644
1645 You've asked C<Fatal> to try and replace a subroutine which does not
1646 exist, or has not yet been defined.
1647
1648 =item %s is neither a builtin, nor a Perl subroutine
1649
1650 You've asked C<Fatal> to replace a subroutine, but it's not a Perl
1651 built-in, and C<Fatal> couldn't find it as a regular subroutine.
1652 It either doesn't exist or has not yet been defined.
1653
1654 =item Cannot make the non-overridable %s fatal
1655
1656 You've tried to use C<Fatal> on a Perl built-in that can't be
1657 overridden, such as C<print> or C<system>, which means that
1658 C<Fatal> can't help you, although some other modules might.
1659 See the L</"SEE ALSO"> section of this documentation.
1660
1661 =item Internal error: %s
1662
1663 You've found a bug in C<Fatal>.  Please report it using
1664 the C<perlbug> command.
1665
1666 =back
1667
1668 =head1 BUGS
1669
1670 C<Fatal> clobbers the context in which a function is called and always
1671 makes it a scalar context, except when the C<:void> tag is used.
1672 This problem does not exist in L<autodie>.
1673
1674 "Used only once" warnings can be generated when C<autodie> or C<Fatal>
1675 is used with package filehandles (eg, C<FILE>).  It's strongly recommended
1676 you use scalar filehandles instead.
1677
1678 =head1 AUTHOR
1679
1680 Original module by Lionel Cons (CERN).
1681
1682 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
1683
1684 L<autodie> support, bugfixes, extended diagnostics, C<system>
1685 support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
1686
1687 =head1 LICENSE
1688
1689 This module is free software, you may distribute it under the
1690 same terms as Perl itself.
1691
1692 =head1 SEE ALSO
1693
1694 L<autodie> for a nicer way to use lexical Fatal.
1695
1696 L<IPC::System::Simple> for a similar idea for calls to C<system()>
1697 and backticks.
1698
1699 =for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation
1700
1701 =cut