diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/Fatal.pm |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Fatal.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/Fatal.pm | 1813 |
1 files changed, 1813 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Fatal.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Fatal.pm new file mode 100644 index 0000000000..16e1743474 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Fatal.pm @@ -0,0 +1,1813 @@ +package Fatal; + +# ABSTRACT: Replace functions with equivalents which succeed or die + +use 5.008; # 5.8.x needed for autodie +use Carp; +use strict; +use warnings; +use Tie::RefHash; # To cache subroutine refs +use Config; +use Scalar::Util qw(set_prototype); + +use autodie::Util qw( + fill_protos + install_subs + make_core_trampoline + on_end_of_compile_scope +); + +use constant PERL510 => ( $] >= 5.010 ); + +use constant LEXICAL_TAG => q{:lexical}; +use constant VOID_TAG => q{:void}; +use constant INSIST_TAG => q{!}; + +# Keys for %Cached_fatalised_sub (used in 3rd level) +use constant CACHE_AUTODIE_LEAK_GUARD => 0; +use constant CACHE_FATAL_WRAPPER => 1; +use constant CACHE_FATAL_VOID => 2; + + +use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; +use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; +use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; +use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG; +use constant ERROR_BADNAME => "Bad subroutine name for %s: %s"; +use constant ERROR_NOTSUB => "%s is not a Perl subroutine"; +use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine"; +use constant ERROR_NOHINTS => "No user hints defined for %s"; + +use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal"; + +use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()"; + +use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f"; + +use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect}; + +use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect}; + +use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x}; + +# Older versions of IPC::System::Simple don't support all the +# features we need. + +use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; + +our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version + +our $Debug ||= 0; + +# EWOULDBLOCK values for systems that don't supply their own. +# Even though this is defined with our, that's to help our +# test code. Please don't rely upon this variable existing in +# the future. + +our %_EWOULDBLOCK = ( + MSWin32 => 33, +); + +$Carp::CarpInternal{'Fatal'} = 1; +$Carp::CarpInternal{'autodie'} = 1; +$Carp::CarpInternal{'autodie::exception'} = 1; + +# the linux parisc port has separate EAGAIN and EWOULDBLOCK, +# and the kernel returns EAGAIN +my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; + +# We have some tags that can be passed in for use with import. +# These are all assumed to be CORE:: + +my %TAGS = ( + ':io' => [qw(:dbm :file :filesys :ipc :socket + read seek sysread syswrite sysseek )], + ':dbm' => [qw(dbmopen dbmclose)], + ':file' => [qw(open close flock sysopen fcntl binmode + ioctl truncate)], + ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir + symlink rmdir readlink chmod chown utime)], + ':ipc' => [qw(:msg :semaphore :shm pipe kill)], + ':msg' => [qw(msgctl msgget msgrcv msgsnd)], + ':threads' => [qw(fork)], + ':semaphore'=>[qw(semctl semget semop)], + ':shm' => [qw(shmctl shmget shmread)], + ':system' => [qw(system exec)], + + # Can we use qw(getpeername getsockname)? What do they do on failure? + # TODO - Can socket return false? + ':socket' => [qw(accept bind connect getsockopt listen recv send + setsockopt shutdown socketpair)], + + # Our defaults don't include system(), because it depends upon + # an optional module, and it breaks the exotic form. + # + # This *may* change in the future. I'd love IPC::System::Simple + # to be a dependency rather than a recommendation, and hence for + # system() to be autodying by default. + + ':default' => [qw(:io :threads)], + + # Everything in v2.07 and before. This was :default less chmod and chown + ':v207' => [qw(:threads :dbm :socket read seek sysread + syswrite sysseek open close flock sysopen fcntl fileno + binmode ioctl truncate opendir closedir chdir link unlink + rename mkdir symlink rmdir readlink umask + :msg :semaphore :shm pipe)], + + # Chmod was added in 2.13 + ':v213' => [qw(:v207 chmod)], + + # chown, utime, kill were added in 2.14 + ':v214' => [qw(:v213 chown utime kill)], + + # umask was removed in 2.26 + ':v225' => [qw(:io :threads umask fileno)], + + # Version specific tags. These allow someone to specify + # use autodie qw(:1.994) and know exactly what they'll get. + + ':1.994' => [qw(:v207)], + ':1.995' => [qw(:v207)], + ':1.996' => [qw(:v207)], + ':1.997' => [qw(:v207)], + ':1.998' => [qw(:v207)], + ':1.999' => [qw(:v207)], + ':1.999_01' => [qw(:v207)], + ':2.00' => [qw(:v207)], + ':2.01' => [qw(:v207)], + ':2.02' => [qw(:v207)], + ':2.03' => [qw(:v207)], + ':2.04' => [qw(:v207)], + ':2.05' => [qw(:v207)], + ':2.06' => [qw(:v207)], + ':2.06_01' => [qw(:v207)], + ':2.07' => [qw(:v207)], # Last release without chmod + ':2.08' => [qw(:v213)], + ':2.09' => [qw(:v213)], + ':2.10' => [qw(:v213)], + ':2.11' => [qw(:v213)], + ':2.12' => [qw(:v213)], + ':2.13' => [qw(:v213)], # Last release without chown + ':2.14' => [qw(:v225)], + ':2.15' => [qw(:v225)], + ':2.16' => [qw(:v225)], + ':2.17' => [qw(:v225)], + ':2.18' => [qw(:v225)], + ':2.19' => [qw(:v225)], + ':2.20' => [qw(:v225)], + ':2.21' => [qw(:v225)], + ':2.22' => [qw(:v225)], + ':2.23' => [qw(:v225)], + ':2.24' => [qw(:v225)], + ':2.25' => [qw(:v225)], + ':2.26' => [qw(:default)], + ':2.27' => [qw(:default)], + ':2.28' => [qw(:default)], + ':2.29' => [qw(:default)], +); + + +{ + # Expand :all immediately by expanding and flattening all tags. + # _expand_tag is not really optimised for expanding the ":all" + # case (i.e. keys %TAGS, or values %TAGS for that matter), so we + # just do it here. + # + # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being + # pre-expanded. + my %seen; + my @all = grep { + !/^:/ && !$seen{$_}++ + } map { @{$_} } values %TAGS; + $TAGS{':all'} = \@all; +} + +# This hash contains subroutines for which we should +# subroutine() // die() rather than subroutine() || die() + +my %Use_defined_or; + +# CORE::open returns undef on failure. It can legitimately return +# 0 on success, eg: open(my $fh, '-|') || exec(...); + +@Use_defined_or{qw( + CORE::fork + CORE::recv + CORE::send + CORE::open + CORE::fileno + CORE::read + CORE::readlink + CORE::sysread + CORE::syswrite + CORE::sysseek + CORE::umask +)} = (); + +# Some functions can return true because they changed *some* things, but +# not all of them. This is a list of offending functions, and how many +# items to subtract from @_ to determine the "success" value they return. + +my %Returns_num_things_changed = ( + 'CORE::chmod' => 1, + 'CORE::chown' => 2, + 'CORE::kill' => 1, # TODO: Could this return anything on negative args? + 'CORE::unlink' => 0, + 'CORE::utime' => 2, +); + +# Optional actions to take on the return value before returning it. + +my %Retval_action = ( + "CORE::open" => q{ + + # apply the open pragma from our caller + if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) { + # Get the caller's hint hash + my $hints = (caller 0)[10]; + + # Decide if we're reading or writing and apply the appropriate encoding + # These keys are undocumented. + # Match what PerlIO_context_layers() does. Read gets the read layer, + # everything else gets the write layer. + my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; + + # Apply the encoding, if any. + if( $encoding ) { + binmode $_[0], $encoding; + } + } + +}, + "CORE::sysopen" => q{ + + # apply the open pragma from our caller + if( defined $retval ) { + # Get the caller's hint hash + my $hints = (caller 0)[10]; + + require Fcntl; + + # Decide if we're reading or writing and apply the appropriate encoding. + # Match what PerlIO_context_layers() does. Read gets the read layer, + # everything else gets the write layer. + my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); + my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; + + # Apply the encoding, if any. + if( $encoding ) { + binmode $_[0], $encoding; + } + } + +}, +); + +my %reusable_builtins; + +# "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can +# take file and directory handles, which are package depedent." +# +# You would be correct, except that prototype() returns signatures which don't +# allow for passing of globs, and nobody's complained about that. You can +# still use \*FILEHANDLE, but that results in a reference coming through, +# and it's already pointing to the filehandle in the caller's packge, so +# it's all okay. + +@reusable_builtins{qw( + CORE::fork + CORE::kill + CORE::truncate + CORE::chdir + CORE::link + CORE::unlink + CORE::rename + CORE::mkdir + CORE::symlink + CORE::rmdir + CORE::readlink + CORE::umask + CORE::chmod + CORE::chown + CORE::utime + CORE::msgctl + CORE::msgget + CORE::msgrcv + CORE::msgsnd + CORE::semctl + CORE::semget + CORE::semop + CORE::shmctl + CORE::shmget + CORE::shmread + CORE::exec + CORE::system +)} = (); + +# Cached_fatalised_sub caches the various versions of our +# fatalised subs as they're produced. This means we don't +# have to build our own replacement of CORE::open and friends +# for every single package that wants to use them. + +my %Cached_fatalised_sub = (); + +# Every time we're called with package scope, we record the subroutine +# (including package or CORE::) in %Package_Fatal. This allows us +# to detect illegal combinations of autodie and Fatal, and makes sure +# we don't accidently make a Fatal function autodying (which isn't +# very useful). + +my %Package_Fatal = (); + +# The first time we're called with a user-sub, we cache it here. +# In the case of a "no autodie ..." we put back the cached copy. + +my %Original_user_sub = (); + +# Is_fatalised_sub simply records a big map of fatalised subroutine +# refs. It means we can avoid repeating work, or fatalising something +# we've already processed. + +my %Is_fatalised_sub = (); +tie %Is_fatalised_sub, 'Tie::RefHash'; + +# Our trampoline cache allows us to cache trampolines which are used to +# bounce leaked wrapped core subroutines to their actual core counterparts. + +my %Trampoline_cache; + +# A cache mapping "CORE::<name>" to their prototype. Turns out that if +# you "use autodie;" enough times, this pays off. +my %CORE_prototype_cache; + +# We use our package in a few hash-keys. Having it in a scalar is +# convenient. The "guard $PACKAGE" string is used as a key when +# setting up lexical guards. + +my $PACKAGE = __PACKAGE__; +my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' + +# Here's where all the magic happens when someone write 'use Fatal' +# or 'use autodie'. + +sub import { + my $class = shift(@_); + my @original_args = @_; + my $void = 0; + my $lexical = 0; + my $insist_hints = 0; + + my ($pkg, $filename) = caller(); + + @_ or return; # 'use Fatal' is a no-op. + + # If we see the :lexical flag, then _all_ arguments are + # changed lexically + + if ($_[0] eq LEXICAL_TAG) { + $lexical = 1; + shift @_; + + # It is currently an implementation detail that autodie is + # implemented as "use Fatal qw(:lexical ...)". For backwards + # compatibility, we allow it - but not without a warning. + # NB: Optimise for autodie as it is quite possibly the most + # freq. consumer of this case. + if ($class ne 'autodie' and not $class->isa('autodie')) { + if ($class eq 'Fatal') { + warnings::warnif( + 'deprecated', + '[deprecated] The "use Fatal qw(:lexical ...)" ' + . 'should be replaced by "use autodie qw(...)". ' + . 'Seen' # warnif appends " at <...>" + ); + } else { + warnings::warnif( + 'deprecated', + "[deprecated] The class/Package $class is a " + . 'subclass of Fatal and used the :lexical. ' + . 'If $class provides lexical error checking ' + . 'it should extend autodie instead of using :lexical. ' + . 'Seen' # warnif appends " at <...>" + ); + } + # "Promote" the call to autodie from here on. This is + # already mostly the case (e.g. use Fatal qw(:lexical ...) + # would throw autodie::exceptions on error rather than the + # Fatal errors. + $class = 'autodie'; + # This requires that autodie is in fact loaded; otherwise + # the "$class->X()" method calls below will explode. + require autodie; + # TODO, when autodie and Fatal are cleanly separated, we + # should go a "goto &autodie::import" here instead. + } + + # If we see no arguments and :lexical, we assume they + # wanted ':default'. + + if (@_ == 0) { + push(@_, ':default'); + } + + # Don't allow :lexical with :void, it's needlessly confusing. + if ( grep { $_ eq VOID_TAG } @_ ) { + croak(ERROR_VOID_LEX); + } + } + + if ( grep { $_ eq LEXICAL_TAG } @_ ) { + # If we see the lexical tag as the non-first argument, complain. + croak(ERROR_LEX_FIRST); + } + + my @fatalise_these = @_; + + # These subs will get unloaded at the end of lexical scope. + my %unload_later; + # These subs are to be installed into callers namespace. + my %install_subs; + + # Use _translate_import_args to expand tags for us. It will + # pass-through unknown tags (i.e. we have to manually handle + # VOID_TAG). + # + # NB: _translate_import_args re-orders everything for us, so + # we don't have to worry about stuff like: + # + # :default :void :io + # + # That will (correctly) translated into + # + # expand(:defaults-without-io) :void :io + # + # by _translate_import_args. + for my $func ($class->_translate_import_args(@fatalise_these)) { + + if ($func eq VOID_TAG) { + + # When we see :void, set the void flag. + $void = 1; + + } elsif ($func eq INSIST_TAG) { + + $insist_hints = 1; + + } else { + + # Otherwise, fatalise it. + + # Check to see if there's an insist flag at the front. + # If so, remove it, and insist we have hints for this sub. + my $insist_this = $insist_hints; + + if (substr($func, 0, 1) eq '!') { + $func = substr($func, 1); + $insist_this = 1; + } + + # We're going to make a subroutine fatalistic. + # However if we're being invoked with 'use Fatal qw(x)' + # and we've already been called with 'no autodie qw(x)' + # in the same scope, we consider this to be an error. + # Mixing Fatal and autodie effects was considered to be + # needlessly confusing on p5p. + + my $sub = $func; + $sub = "${pkg}::$sub" unless $sub =~ /::/; + + # If we're being called as Fatal, and we've previously + # had a 'no X' in scope for the subroutine, then complain + # bitterly. + + if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { + croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); + } + + # We're not being used in a confusing way, so make + # the sub fatal. Note that _make_fatal returns the + # old (original) version of the sub, or undef for + # built-ins. + + my $sub_ref = $class->_make_fatal( + $func, $pkg, $void, $lexical, $filename, + $insist_this, \%install_subs, + ); + + $Original_user_sub{$sub} ||= $sub_ref; + + # If we're making lexical changes, we need to arrange + # for them to be cleaned at the end of our scope, so + # record them here. + + $unload_later{$func} = $sub_ref if $lexical; + } + } + + install_subs($pkg, \%install_subs); + + if ($lexical) { + + # Dark magic to have autodie work under 5.8 + # Copied from namespace::clean, that copied it from + # autobox, that found it on an ancient scroll written + # in blood. + + # This magic bit causes %^H to be lexically scoped. + + $^H |= 0x020000; + + # Our package guard gets invoked when we leave our lexical + # scope. + + on_end_of_compile_scope(sub { + install_subs($pkg, \%unload_later); + }); + + # To allow others to determine when autodie was in scope, + # and with what arguments, we also set a %^H hint which + # is how we were called. + + # This feature should be considered EXPERIMENTAL, and + # may change without notice. Please e-mail pjf@cpan.org + # if you're actually using it. + + $^H{autodie} = "$PACKAGE @original_args"; + + } + + return; + +} + +sub unimport { + my $class = shift; + + # Calling "no Fatal" must start with ":lexical" + if ($_[0] ne LEXICAL_TAG) { + croak(sprintf(ERROR_NO_LEX,$class)); + } + + shift @_; # Remove :lexical + + my $pkg = (caller)[0]; + + # If we've been called with arguments, then the developer + # has explicitly stated 'no autodie qw(blah)', + # in which case, we disable Fatalistic behaviour for 'blah'. + + my @unimport_these = @_ ? @_ : ':all'; + my (%uninstall_subs, %reinstall_subs); + + for my $symbol ($class->_translate_import_args(@unimport_these)) { + + my $sub = $symbol; + $sub = "${pkg}::$sub" unless $sub =~ /::/; + + # If 'blah' was already enabled with Fatal (which has package + # scope) then, this is considered an error. + + if (exists $Package_Fatal{$sub}) { + croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); + } + + # Record 'no autodie qw($sub)' as being in effect. + # This is to catch conflicting semantics elsewhere + # (eg, mixing Fatal with no autodie) + + $^H{$NO_PACKAGE}{$sub} = 1; + # Record the current sub to be reinstalled at end of scope + # and then restore the original (can be undef for "CORE::" + # subs) + $reinstall_subs{$symbol} = \&$sub; + $uninstall_subs{$symbol} = $Original_user_sub{$sub}; + + } + + install_subs($pkg, \%uninstall_subs); + on_end_of_compile_scope(sub { + install_subs($pkg, \%reinstall_subs); + }); + + return; + +} + +sub _translate_import_args { + my ($class, @args) = @_; + my @result; + my %seen; + + if (@args < 2) { + # Optimize for this case, as it is fairly common. (e.g. use + # autodie; or use autodie qw(:all); both trigger this). + return unless @args; + + # Not a (known) tag, pass through. + return @args unless exists($TAGS{$args[0]}); + + # Strip "CORE::" from all elements in the list as import and + # unimport does not handle the "CORE::" prefix too well. + # + # NB: we use substr as it is faster than s/^CORE::// and + # it does not change the elements. + return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; + } + + # We want to translate + # + # :default :void :io + # + # into (pseudo-ish): + # + # expanded(:threads) :void expanded(:io) + # + # We accomplish this by "reverse, expand + filter, reverse". + for my $a (reverse(@args)) { + if (exists $TAGS{$a}) { + my $expanded = $class->_expand_tag($a); + push(@result, + # Remove duplicates after ... + grep { !$seen{$_}++ } + # we have stripped CORE:: (see above) + map { substr($_, 6) } + # We take the elements in reverse order + # (as @result be reversed later). + reverse(@{$expanded})); + } else { + # pass through - no filtering here for tags. + # + # The reason for not filtering tags cases like: + # + # ":default :void :io :void :threads" + # + # As we have reversed args, we see this as: + # + # ":threads :void :io :void* :default*" + # + # (Entries marked with "*" will be filtered out completely). When + # reversed again, this will be: + # + # ":io :void :threads" + # + # But we would rather want it to be: + # + # ":void :io :threads" or ":void :io :void :threads" + # + + my $letter = substr($a, 0, 1); + if ($letter ne ':' && $a ne INSIST_TAG) { + next if $seen{$a}++; + if ($letter eq '!' and $seen{substr($a, 1)}++) { + my $name = substr($a, 1); + # People are being silly and doing: + # + # use autodie qw(!a a); + # + # Enjoy this little O(n) clean up... + @result = grep { $_ ne $name } @result; + } + } + push @result, $a; + } + } + # Reverse the result to restore the input order + return reverse(@result); +} + + +# NB: Perl::Critic's dump-autodie-tag-contents depends upon this +# continuing to work. + +{ + # We assume that $TAGS{':all'} is pre-expanded and just fill it in + # from the beginning. + my %tag_cache = ( + 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], + ); + + # Expand a given tag (e.g. ":default") into a listref containing + # all sub names covered by that tag. Each sub is returned as + # "CORE::<name>" (i.e. "CORE::open" rather than "open"). + # + # NB: the listref must not be modified. + sub _expand_tag { + my ($class, $tag) = @_; + + if (my $cached = $tag_cache{$tag}) { + return $cached; + } + + if (not exists $TAGS{$tag}) { + croak "Invalid exception class $tag"; + } + + my @to_process = @{$TAGS{$tag}}; + + # If the tag is basically an alias of another tag (like e.g. ":2.11"), + # then just share the resulting reference with the original content (so + # we only pay for an extra reference for the alias memory-wise). + if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { + # We could do this for "non-tags" as well, but that only occurs + # once at the time of writing (":threads" => ["fork"]), so + # probably not worth it. + my $expanded = $class->_expand_tag($to_process[0]); + $tag_cache{$tag} = $expanded; + return $expanded; + } + + my %seen = (); + my @taglist = (); + + for my $item (@to_process) { + # substr is more efficient than m/^:/ for stuff like this, + # at the price of being a bit more verbose/low-level. + if (substr($item, 0, 1) eq ':') { + # Use recursion here to ensure we expand a tag at most once. + + my $expanded = $class->_expand_tag($item); + push @taglist, grep { !$seen{$_}++ } @{$expanded}; + } else { + my $subname = "CORE::$item"; + push @taglist, $subname + unless $seen{$subname}++; + } + } + + $tag_cache{$tag} = \@taglist; + + return \@taglist; + + } + +} + +# This is a backwards compatible version of _write_invocation. It's +# recommended you don't use it. + +sub write_invocation { + my ($core, $call, $name, $void, @args) = @_; + + return Fatal->_write_invocation( + $core, $call, $name, $void, + 0, # Lexical flag + undef, # Sub, unused in legacy mode + undef, # Subref, unused in legacy mode. + @args + ); +} + +# This version of _write_invocation is used internally. It's not +# recommended you call it from external code, as the interface WILL +# change in the future. + +sub _write_invocation { + + my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; + + if (@argvs == 1) { # No optional arguments + + my @argv = @{$argvs[0]}; + shift @argv; + + return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); + + } else { + my $else = "\t"; + my (@out, @argv, $n); + while (@argvs) { + @argv = @{shift @argvs}; + $n = shift @argv; + + my $condition = "\@_ == $n"; + + if (@argv and $argv[-1] =~ /[#@]_/) { + # This argv ends with '@' in the prototype, so it matches + # any number of args >= the number of expressions in the + # argv. + $condition = "\@_ >= $n"; + } + + push @out, "${else}if ($condition) {\n"; + + $else = "\t} els"; + + push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); + } + push @out, qq[ + } + die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; + ]; + + return join '', @out; + } +} + + +# This is a slim interface to ensure backward compatibility with +# anyone doing very foolish things with old versions of Fatal. + +sub one_invocation { + my ($core, $call, $name, $void, @argv) = @_; + + return Fatal->_one_invocation( + $core, $call, $name, $void, + undef, # Sub. Unused in back-compat mode. + 1, # Back-compat flag + undef, # Subref, unused in back-compat mode. + @argv + ); + +} + +# This is the internal interface that generates code. +# NOTE: This interface WILL change in the future. Please do not +# call this subroutine directly. + +# TODO: Whatever's calling this code has already looked up hints. Pass +# them in, rather than look them up a second time. + +sub _one_invocation { + my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; + + + # If someone is calling us directly (a child class perhaps?) then + # they could try to mix void without enabling backwards + # compatibility. We just don't support this at all, so we gripe + # about it rather than doing something unwise. + + if ($void and not $back_compat) { + Carp::confess("Internal error: :void mode not supported with $class"); + } + + # @argv only contains the results of the in-built prototype + # function, and is therefore safe to interpolate in the + # code generators below. + + # TODO - The following clobbers context, but that's what the + # old Fatal did. Do we care? + + if ($back_compat) { + + # Use Fatal qw(system) will never be supported. It generated + # a compile-time error with legacy Fatal, and there's no reason + # to support it when autodie does a better job. + + if ($call eq 'CORE::system') { + return q{ + croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); + }; + } + + local $" = ', '; + + if ($void) { + return qq/return (defined wantarray)?$call(@argv): + $call(@argv) || Carp::croak("Can't $name(\@_)/ . + ($core ? ': $!' : ', \$! is \"$!\"') . '")' + } else { + return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . + ($core ? ': $!' : ', \$! is \"$!\"') . '")'; + } + } + + # The name of our original function is: + # $call if the function is CORE + # $sub if our function is non-CORE + + # The reason for this is that $call is what we're actually + # calling. For our core functions, this is always + # CORE::something. However for user-defined subs, we're about to + # replace whatever it is that we're calling; as such, we actually + # calling a subroutine ref. + + my $human_sub_name = $core ? $call : $sub; + + # Should we be testing to see if our result is defined, or + # just true? + + my $use_defined_or; + + my $hints; # All user-sub hints, including list hints. + + if ( $core ) { + + # Core hints are built into autodie. + + $use_defined_or = exists ( $Use_defined_or{$call} ); + + } + else { + + # User sub hints are looked up using autodie::hints, + # since users may wish to add their own hints. + + require autodie::hints; + + $hints = autodie::hints->get_hints_for( $sref ); + + # We'll look up the sub's fullname. This means we + # get better reports of where it came from in our + # error messages, rather than what imported it. + + $human_sub_name = autodie::hints->sub_fullname( $sref ); + + } + + # Checks for special core subs. + + if ($call eq 'CORE::system') { + + # Leverage IPC::System::Simple if we're making an autodying + # system. + + local $" = ", "; + + # We need to stash $@ into $E, rather than using + # local $@ for the whole sub. If we don't then + # any exceptions from internal errors in autodie/Fatal + # will mysteriously disappear before propagating + # upwards. + + return qq{ + my \$retval; + my \$E; + + + { + local \$@; + + eval { + \$retval = IPC::System::Simple::system(@argv); + }; + + \$E = \$@; + } + + if (\$E) { + + # TODO - This can't be overridden in child + # classes! + + die autodie::exception::system->new( + function => q{CORE::system}, args => [ @argv ], + message => "\$E", errno => \$!, + ); + } + + return \$retval; + }; + + } + + local $" = ', '; + + # If we're going to throw an exception, here's the code to use. + my $die = qq{ + die $class->throw( + function => q{$human_sub_name}, args => [ @argv ], + pragma => q{$class}, errno => \$!, + context => \$context, return => \$retval, + eval_error => \$@ + ) + }; + + if ($call eq 'CORE::flock') { + + # flock needs special treatment. When it fails with + # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just + # means we couldn't get the lock right now. + + require POSIX; # For POSIX::EWOULDBLOCK + + local $@; # Don't blat anyone else's $@. + + # Ensure that our vendor supports EWOULDBLOCK. If they + # don't (eg, Windows), then we use known values for its + # equivalent on other systems. + + my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } + || $_EWOULDBLOCK{$^O} + || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); + my $EAGAIN = $EWOULDBLOCK; + if ($try_EAGAIN) { + $EAGAIN = eval { POSIX::EAGAIN(); } + || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); + } + + require Fcntl; # For Fcntl::LOCK_NB + + return qq{ + + my \$context = wantarray() ? "list" : "scalar"; + + # Try to flock. If successful, return it immediately. + + my \$retval = $call(@argv); + return \$retval if \$retval; + + # If we failed, but we're using LOCK_NB and + # returned EWOULDBLOCK, it's not a real error. + + if (\$_[1] & Fcntl::LOCK_NB() and + (\$! == $EWOULDBLOCK or + ($try_EAGAIN and \$! == $EAGAIN ))) { + return \$retval; + } + + # Otherwise, we failed. Die noisily. + + $die; + + }; + } + + if (exists $Returns_num_things_changed{$call}) { + + # Some things return the number of things changed (like + # chown, kill, chmod, etc). We only consider these successful + # if *all* the things are changed. + + return qq[ + my \$num_things = \@_ - $Returns_num_things_changed{$call}; + my \$retval = $call(@argv); + + if (\$retval != \$num_things) { + + # We need \$context to throw an exception. + # It's *always* set to scalar, because that's how + # autodie calls chown() above. + + my \$context = "scalar"; + $die; + } + + return \$retval; + ]; + } + + # AFAIK everything that can be given an unopned filehandle + # will fail if it tries to use it, so we don't really need + # the 'unopened' warning class here. Especially since they + # then report the wrong line number. + + # Other warnings are disabled because they produce excessive + # complaints from smart-match hints under 5.10.1. + + my $code = qq[ + no warnings qw(unopened uninitialized numeric); + no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; + + if (wantarray) { + my \@results = $call(@argv); + my \$retval = \\\@results; + my \$context = "list"; + + ]; + + my $retval_action = $Retval_action{$call} || ''; + + if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { + + # NB: Subroutine hints are passed as a full list. + # This differs from the 5.10.0 smart-match behaviour, + # but means that context unaware subroutines can use + # the same hints in both list and scalar context. + + $code .= qq{ + if ( \$hints->{list}->(\@results) ) { $die }; + }; + } + elsif ( PERL510 and $hints ) { + $code .= qq{ + if ( \@results ~~ \$hints->{list} ) { $die }; + }; + } + elsif ( $hints ) { + croak sprintf(ERROR_58_HINTS, 'list', $sub); + } + else { + $code .= qq{ + # An empty list, or a single undef is failure + if (! \@results or (\@results == 1 and ! defined \$results[0])) { + $die; + } + } + } + + # Tidy up the end of our wantarray call. + + $code .= qq[ + return \@results; + } + ]; + + + # Otherwise, we're in scalar context. + # We're never in a void context, since we have to look + # at the result. + + $code .= qq{ + my \$retval = $call(@argv); + my \$context = "scalar"; + }; + + if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { + + # We always call code refs directly, since that always + # works in 5.8.x, and always works in 5.10.1 + + return $code .= qq{ + if ( \$hints->{scalar}->(\$retval) ) { $die }; + $retval_action + return \$retval; + }; + + } + elsif (PERL510 and $hints) { + return $code . qq{ + + if ( \$retval ~~ \$hints->{scalar} ) { $die }; + $retval_action + return \$retval; + }; + } + elsif ( $hints ) { + croak sprintf(ERROR_58_HINTS, 'scalar', $sub); + } + + return $code . + ( $use_defined_or ? qq{ + + $die if not defined \$retval; + $retval_action + return \$retval; + + } : qq{ + + $retval_action + return \$retval || $die; + + } ) ; + +} + +# This returns the old copy of the sub, so we can +# put it back at end of scope. + +# TODO : Check to make sure prototypes are restored correctly. + +# TODO: Taking a huge list of arguments is awful. Rewriting to +# take a hash would be lovely. + +# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 + +sub _make_fatal { + my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; + my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type); + my $ini = $sub; + my $name = $sub; + + + if (index($sub, '::') == -1) { + $sub = "${pkg}::$sub"; + if (substr($name, 0, 1) eq '&') { + $name = substr($name, 1); + } + } else { + $name =~ s/.*:://; + } + + + # Figure if we're using lexical or package semantics and + # twiddle the appropriate bits. + + if (not $lexical) { + $Package_Fatal{$sub} = 1; + } + + # TODO - We *should* be able to do skipping, since we know when + # we've lexicalised / unlexicalised a subroutine. + + + warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; + croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; + + if (defined(&$sub)) { # user subroutine + + # NOTE: Previously we would localise $@ at this point, so + # the following calls to eval {} wouldn't interfere with anything + # that's already in $@. Unfortunately, it would also stop + # any of our croaks from triggering(!), which is even worse. + + # This could be something that we've fatalised that + # was in core. + + # Store the current sub in case we need to restore it. + $sref = \&$sub; + + if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { + + # Something we previously made Fatal that was core. + # This is safe to replace with an autodying to core + # version. + + $core = 1; + $call = "CORE::$name"; + $proto = $CORE_prototype_cache{$call}; + + # We return our $sref from this subroutine later + # on, indicating this subroutine should be placed + # back when we're finished. + + + + } else { + + # If this is something we've already fatalised or played with, + # then look-up the name of the original sub for the rest of + # our processing. + + if (exists($Is_fatalised_sub{$sref})) { + # $sub is one of our wrappers around a CORE sub or a + # user sub. Instead of wrapping our wrapper, lets just + # generate a new wrapper for the original sub. + # - NB: the current wrapper might be for a different class + # than the one we are generating now (e.g. some limited + # mixing between use Fatal + use autodie can occur). + # - Even for nested autodie, we need this as the leak guards + # differ. + my $s = $Is_fatalised_sub{$sref}; + if (defined($s)) { + # It is a wrapper for a user sub + $sub = $s; + } else { + # It is a wrapper for a CORE:: sub + $core = 1; + $call = "CORE::$name"; + $proto = $CORE_prototype_cache{$call}; + } + } + + # A regular user sub, or a user sub wrapping a + # core sub. + + if (!$core) { + # A non-CORE sub might have hints and such... + $proto = prototype($sref); + $call = '&$sref'; + require autodie::hints; + + $hints = autodie::hints->get_hints_for( $sref ); + + # If we've insisted on hints, but don't have them, then + # bail out! + + if ($insist and not $hints) { + croak(sprintf(ERROR_NOHINTS, $name)); + } + + # Otherwise, use the default hints if we don't have + # any. + + $hints ||= autodie::hints::DEFAULT_HINTS(); + } + + } + + } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { + # Stray user subroutine + croak(sprintf(ERROR_NOTSUB,$sub)); + + } elsif ($name eq 'system') { + + # If we're fatalising system, then we need to load + # helper code. + + # The business with $E is to avoid clobbering our caller's + # $@, and to avoid $@ being localised when we croak. + + my $E; + + { + local $@; + + eval { + require IPC::System::Simple; # Only load it if we need it. + require autodie::exception::system; + }; + $E = $@; + } + + if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } + + # Make sure we're using a recent version of ISS that actually + # support fatalised system. + if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { + croak sprintf( + ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, + $IPC::System::Simple::VERSION + ); + } + + $call = 'CORE::system'; + $core = 1; + + } elsif ($name eq 'exec') { + # Exec doesn't have a prototype. We don't care. This + # breaks the exotic form with lexical scope, and gives + # the regular form a "do or die" behavior as expected. + + $call = 'CORE::exec'; + $core = 1; + + } else { # CORE subroutine + $call = "CORE::$name"; + if (exists($CORE_prototype_cache{$call})) { + $proto = $CORE_prototype_cache{$call}; + } else { + my $E; + { + local $@; + $proto = eval { prototype $call }; + $E = $@; + } + croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; + croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; + $CORE_prototype_cache{$call} = $proto; + } + $core = 1; + } + + # TODO: This caching works, but I don't like using $void and + # $lexical as keys. In particular, I suspect our code may end up + # wrapping already wrapped code when autodie and Fatal are used + # together. + + # NB: We must use '$sub' (the name plus package) and not + # just '$name' (the short name) here. Failing to do so + # results code that's in the wrong package, and hence has + # access to the wrong package filehandles. + + $cache = $Cached_fatalised_sub{$class}{$sub}; + if ($lexical) { + $cache_type = CACHE_AUTODIE_LEAK_GUARD; + } else { + $cache_type = CACHE_FATAL_WRAPPER; + $cache_type = CACHE_FATAL_VOID if $void; + } + + if (my $subref = $cache->{$cache_type}) { + $install_subs->{$name} = $subref; + return $sref; + } + + # If our subroutine is reusable (ie, not package depdendent), + # then check to see if we've got a cached copy, and use that. + # See RT #46984. (Thanks to Niels Thykier for being awesome!) + + if ($core && exists $reusable_builtins{$call}) { + # For non-lexical subs, we can just use this cache directly + # - for lexical variants, we need a leak guard as well. + $code = $reusable_builtins{$call}{$lexical}; + if (!$lexical && defined($code)) { + $install_subs->{$name} = $code; + return $sref; + } + } + + if (!($lexical && $core) && !defined($code)) { + # No code available, generate it now. + my $wrapper_pkg = $pkg; + $wrapper_pkg = undef if (exists($reusable_builtins{$call})); + $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, + $void, $lexical, $sub, $sref, + $hints, $proto); + if (!defined($wrapper_pkg)) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + + # Now we need to wrap our fatalised sub inside an itty bitty + # closure, which can detect if we've leaked into another file. + # Luckily, we only need to do this for lexical (autodie) + # subs. Fatal subs can leak all they want, it's considered + # a "feature" (or at least backwards compatible). + + # TODO: Cache our leak guards! + + # TODO: This is pretty hairy code. A lot more tests would + # be really nice for this. + + my $installed_sub = $code; + + if ($lexical) { + $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, + $pkg, $proto); + } + + $cache->{$cache_type} = $code; + + $install_subs->{$name} = $installed_sub; + + # Cache that we've now overridden this sub. If we get called + # again, we may need to find that find subroutine again (eg, for hints). + + $Is_fatalised_sub{$installed_sub} = $sref; + + return $sref; + +} + +# This subroutine exists primarily so that child classes can override +# it to point to their own exception class. Doing this is significantly +# less complex than overriding throw() + +sub exception_class { return "autodie::exception" }; + +{ + my %exception_class_for; + my %class_loaded; + + sub throw { + my ($class, @args) = @_; + + # Find our exception class if we need it. + my $exception_class = + $exception_class_for{$class} ||= $class->exception_class; + + if (not $class_loaded{$exception_class}) { + if ($exception_class =~ /[^\w:']/) { + 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."; + } + + # Alas, Perl does turn barewords into modules unless they're + # actually barewords. As such, we're left doing a string eval + # to make sure we load our file correctly. + + my $E; + + { + local $@; # We can't clobber $@, it's wrong! + my $pm_file = $exception_class . ".pm"; + $pm_file =~ s{ (?: :: | ' ) }{/}gx; + eval { require $pm_file }; + $E = $@; # Save $E despite ending our local. + } + + # We need quotes around $@ to make sure it's stringified + # while still in scope. Without them, we run the risk of + # $@ having been cleared by us exiting the local() block. + + 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; + + $class_loaded{$exception_class}++; + + } + + return $exception_class->new(@args); + } +} + +# Creates and returns a leak guard (with prototype if needed). +sub _make_leak_guard { + my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_; + + # The leak guard is rather lengthly (in fact it makes up the most + # of _make_leak_guard). It is possible to split it into a large + # "generic" part and a small wrapper with call-specific + # information. This was done in v2.19 and profiling suggested + # that we ended up using a substantial amount of runtime in "goto" + # between the leak guard(s) and the final sub. Therefore, the two + # parts were merged into one to reduce the runtime overhead. + + my $leak_guard = sub { + my $caller_level = 0; + my $caller; + + while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { + + # If our filename is actually an eval, and we + # reach it, then go to our autodying code immediatately. + + last if ($caller eq $filename); + $caller_level++; + } + + # We're now out of the eval stack. + + if ($caller eq $filename) { + # No leak, call the wrapper. NB: In this case, it doesn't + # matter if it is a CORE sub or not. + if (!defined($wrapped_sub)) { + # CORE sub that we were too lazy to compile when we + # created this leak guard. + die "$call is not CORE::<something>" + if substr($call, 0, 6) ne 'CORE::'; + + my $name = substr($call, 6); + my $sub = $name; + my $lexical = 1; + my $wrapper_pkg = $pkg; + my $code; + if (exists($reusable_builtins{$call})) { + $code = $reusable_builtins{$call}{$lexical}; + $wrapper_pkg = undef; + } + if (!defined($code)) { + $code = $class->_compile_wrapper($wrapper_pkg, + 1, # core + $call, + $name, + 0, # void + $lexical, + $sub, + undef, # subref (not used for core) + undef, # hints (not used for core) + $proto); + + if (!defined($wrapper_pkg)) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + # As $wrapped_sub is "closed over", updating its value will + # be "remembered" for the next call. + $wrapped_sub = $code; + } + goto $wrapped_sub; + } + + # We leaked, time to call the original function. + # - for non-core functions that will be $orig_sub + # - for CORE functions, $orig_sub may be a trampoline + goto $orig_sub if defined($orig_sub); + + # We are wrapping a CORE sub and we do not have a trampoline + # yet. + # + # If we've cached a trampoline, then use it. Usually only + # resuable subs will have cache hits, but non-reusuably ones + # can get it as well in (very) rare cases. It is mostly in + # cases where a package uses autodie multiple times and leaks + # from multiple places. Possibly something like: + # + # package Pkg::With::LeakyCode; + # sub a { + # use autodie; + # code_that_leaks(); + # } + # + # sub b { + # use autodie; + # more_leaky_code(); + # } + # + # Note that we use "Fatal" as package name for reusable subs + # because A) that allows us to trivially re-use the + # trampolines as well and B) because the reusable sub is + # compiled into "package Fatal" as well. + + $pkg = 'Fatal' if exists $reusable_builtins{$call}; + $orig_sub = $Trampoline_cache{$pkg}{$call}; + + if (not $orig_sub) { + # If we don't have a trampoline, we need to build it. + # + # We only generate trampolines when we need them, and + # we can cache them by subroutine + package. + # + # As $orig_sub is "closed over", updating its value will + # be "remembered" for the next call. + + $orig_sub = make_core_trampoline($call, $pkg, $proto); + + # We still cache it despite remembering it in $orig_sub as + # well. In particularly, we rely on this to avoid + # re-compiling the reusable trampolines. + $Trampoline_cache{$pkg}{$call} = $orig_sub; + } + + # Bounce to our trampoline, which takes us to our core sub. + goto $orig_sub; + }; # <-- end of leak guard + + # If there is a prototype on the original sub, copy it to the leak + # guard. + if (defined $proto) { + # The "\&" may appear to be redundant but set_prototype + # croaks when it is removed. + set_prototype(\&$leak_guard, $proto); + } + + return $leak_guard; +} + +sub _compile_wrapper { + my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; + my $real_proto = ''; + my @protos; + my $code; + if (defined $proto) { + $real_proto = " ($proto)"; + } else { + $proto = '@'; + } + + @protos = fill_protos($proto); + $code = qq[ + sub$real_proto { + ]; + + if (!$lexical) { + $code .= q[ + local($", $!) = (', ', 0); + ]; + } + + # Don't have perl whine if exec fails, since we'll be handling + # the exception now. + $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; + + $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, + $sub, $sref, @protos); + $code .= "}\n"; + warn $code if $Debug; + + # I thought that changing package was a monumental waste of + # time for CORE subs, since they'll always be the same. However + # that's not the case, since they may refer to package-based + # filehandles (eg, with open). + # + # The %reusable_builtins hash defines ones we can aggressively + # cache as they never depend upon package-based symbols. + + my $E; + + { + no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + local $@; + if (defined($wrapper_pkg)) { + $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic + } else { + $code = eval("require Carp; $code"); ## no critic + + } + $E = $@; + } + + if (not $code) { + my $true_name = $core ? $call : $sub; + croak("Internal error in autodie/Fatal processing $true_name: $E"); + } + return $code; +} + +# For some reason, dying while replacing our subs doesn't +# kill our calling program. It simply stops the loading of +# autodie and keeps going with everything else. The _autocroak +# sub allows us to die with a vengeance. It should *only* ever be +# used for serious internal errors, since the results of it can't +# be captured. + +sub _autocroak { + warn Carp::longmess(@_); + exit(255); # Ugh! +} + +1; + +__END__ + +=head1 NAME + +Fatal - Replace functions with equivalents which succeed or die + +=head1 SYNOPSIS + + use Fatal qw(open close); + + open(my $fh, "<", $filename); # No need to check errors! + + use File::Copy qw(move); + use Fatal qw(move); + + move($file1, $file2); # No need to check errors! + + sub juggle { . . . } + Fatal->import('juggle'); + +=head1 BEST PRACTICE + +B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use +L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping, +throws real exception objects, and provides much nicer error messages. + +The use of C<:void> with Fatal is discouraged. + +=head1 DESCRIPTION + +C<Fatal> provides a way to conveniently replace +functions which normally return a false value when they fail with +equivalents which raise exceptions if they are not successful. This +lets you use these functions without having to test their return +values explicitly on each call. Exceptions can be caught using +C<eval{}>. See L<perlfunc> and L<perlvar> for details. + +The do-or-die equivalents are set up simply by calling Fatal's +C<import> routine, passing it the names of the functions to be +replaced. You may wrap both user-defined functions and overridable +CORE operators (except C<exec>, C<system>, C<print>, or any other +built-in that cannot be expressed via prototypes) in this way. + +If the symbol C<:void> appears in the import list, then functions +named later in that import list raise an exception only when +these are called in void context--that is, when their return +values are ignored. For example + + use Fatal qw/:void open close/; + + # properly checked, so no exception raised on error + if (not open(my $fh, '<', '/bogotic') { + warn "Can't open /bogotic: $!"; + } + + # not checked, so error raises an exception + close FH; + +The use of C<:void> is discouraged, as it can result in exceptions +not being thrown if you I<accidentally> call a method without +void context. Use L<autodie> instead if you need to be able to +disable autodying/Fatal behaviour for a small block of code. + +=head1 DIAGNOSTICS + +=over 4 + +=item Bad subroutine name for Fatal: %s + +You've called C<Fatal> with an argument that doesn't look like +a subroutine name, nor a switch that this version of Fatal +understands. + +=item %s is not a Perl subroutine + +You've asked C<Fatal> to try and replace a subroutine which does not +exist, or has not yet been defined. + +=item %s is neither a builtin, nor a Perl subroutine + +You've asked C<Fatal> to replace a subroutine, but it's not a Perl +built-in, and C<Fatal> couldn't find it as a regular subroutine. +It either doesn't exist or has not yet been defined. + +=item Cannot make the non-overridable %s fatal + +You've tried to use C<Fatal> on a Perl built-in that can't be +overridden, such as C<print> or C<system>, which means that +C<Fatal> can't help you, although some other modules might. +See the L</"SEE ALSO"> section of this documentation. + +=item Internal error: %s + +You've found a bug in C<Fatal>. Please report it using +the C<perlbug> command. + +=back + +=head1 BUGS + +C<Fatal> clobbers the context in which a function is called and always +makes it a scalar context, except when the C<:void> tag is used. +This problem does not exist in L<autodie>. + +"Used only once" warnings can be generated when C<autodie> or C<Fatal> +is used with package filehandles (eg, C<FILE>). It's strongly recommended +you use scalar filehandles instead. + +=head1 AUTHOR + +Original module by Lionel Cons (CERN). + +Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>. + +L<autodie> support, bugfixes, extended diagnostics, C<system> +support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au> + +=head1 LICENSE + +This module is free software, you may distribute it under the +same terms as Perl itself. + +=head1 SEE ALSO + +L<autodie> for a nicer way to use lexical Fatal. + +L<IPC::System::Simple> for a similar idea for calls to C<system()> +and backticks. + +=for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG + +=cut |