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