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