"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Fatal.pm" (18 Apr 2017, 58176 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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