3 # ABSTRACT: Replace functions with equivalents which succeed or die
5 use 5.008; # 5.8.x needed for autodie
9 use Tie::RefHash; # To cache subroutine refs
11 use Scalar::Util qw(set_prototype);
17 on_end_of_compile_scope
20 use constant PERL510 => ( $] >= 5.010 );
22 use constant LEXICAL_TAG => q{:lexical};
23 use constant VOID_TAG => q{:void};
24 use constant INSIST_TAG => q{!};
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;
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";
41 use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
43 use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
45 use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
47 use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
49 use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
51 use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
53 # Older versions of IPC::System::Simple don't support all the
56 use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
58 our $VERSION = '2.28'; # VERSION: Generated by DZP::OurPkg::Version
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
71 $Carp::CarpInternal{'Fatal'} = 1;
72 $Carp::CarpInternal{'autodie'} = 1;
73 $Carp::CarpInternal{'autodie::exception'} = 1;
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;
79 # We have some tags that can be passed in for use with import.
80 # These are all assumed to be CORE::
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
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)],
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)],
102 # Our defaults don't include system(), because it depends upon
103 # an optional module, and it breaks the exotic form.
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.
109 ':default' => [qw(:io :threads)],
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)],
118 # Chmod was added in 2.13
119 ':v213' => [qw(:v207 chmod)],
121 # chown, utime, kill were added in 2.14
122 ':v214' => [qw(:v213 chown utime kill)],
124 # umask was removed in 2.26
125 ':v225' => [qw(:io :threads umask fileno)],
127 # Version specific tags. These allow someone to specify
128 # use autodie qw(:1.994) and know exactly what they'll get.
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)],
171 # Expand :all immediately by expanding and flattening all tags.
172 # _expand_tag is not really optimised for expanding the ":all"
173 # case (i.e. keys %TAGS, or values %TAGS for that matter), so we
176 # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being
180 !/^:/ && !$seen{$_}++
181 } map { @{$_} } values %TAGS;
182 $TAGS{':all'} = \@all;
185 # This hash contains subroutines for which we should
186 # subroutine() // die() rather than subroutine() || die()
190 # CORE::open returns undef on failure. It can legitimately return
191 # 0 on success, eg: open(my $fh, '-|') || exec(...);
207 # Some functions can return true because they changed *some* things, but
208 # not all of them. This is a list of offending functions, and how many
209 # items to subtract from @_ to determine the "success" value they return.
211 my %Returns_num_things_changed = (
214 'CORE::kill' => 1, # TODO: Could this return anything on negative args?
219 # Optional actions to take on the return value before returning it.
221 my %Retval_action = (
224 # apply the open pragma from our caller
225 if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) {
226 # Get the caller's hint hash
227 my $hints = (caller 0)[10];
229 # Decide if we're reading or writing and apply the appropriate encoding
230 # These keys are undocumented.
231 # Match what PerlIO_context_layers() does. Read gets the read layer,
232 # everything else gets the write layer.
233 my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"};
235 # Apply the encoding, if any.
237 binmode $_[0], $encoding;
242 "CORE::sysopen" => q{
244 # apply the open pragma from our caller
245 if( defined $retval ) {
246 # Get the caller's hint hash
247 my $hints = (caller 0)[10];
251 # Decide if we're reading or writing and apply the appropriate encoding.
252 # Match what PerlIO_context_layers() does. Read gets the read layer,
253 # everything else gets the write layer.
254 my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY());
255 my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"};
257 # Apply the encoding, if any.
259 binmode $_[0], $encoding;
266 my %reusable_builtins;
268 # "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can
269 # take file and directory handles, which are package depedent."
271 # You would be correct, except that prototype() returns signatures which don't
272 # allow for passing of globs, and nobody's complained about that. You can
273 # still use \*FILEHANDLE, but that results in a reference coming through,
274 # and it's already pointing to the filehandle in the caller's packge, so
277 @reusable_builtins{qw(
307 # Cached_fatalised_sub caches the various versions of our
308 # fatalised subs as they're produced. This means we don't
309 # have to build our own replacement of CORE::open and friends
310 # for every single package that wants to use them.
312 my %Cached_fatalised_sub = ();
314 # Every time we're called with package scope, we record the subroutine
315 # (including package or CORE::) in %Package_Fatal. This allows us
316 # to detect illegal combinations of autodie and Fatal, and makes sure
317 # we don't accidently make a Fatal function autodying (which isn't
320 my %Package_Fatal = ();
322 # The first time we're called with a user-sub, we cache it here.
323 # In the case of a "no autodie ..." we put back the cached copy.
325 my %Original_user_sub = ();
327 # Is_fatalised_sub simply records a big map of fatalised subroutine
328 # refs. It means we can avoid repeating work, or fatalising something
329 # we've already processed.
331 my %Is_fatalised_sub = ();
332 tie %Is_fatalised_sub, 'Tie::RefHash';
334 # Our trampoline cache allows us to cache trampolines which are used to
335 # bounce leaked wrapped core subroutines to their actual core counterparts.
337 my %Trampoline_cache;
339 # A cache mapping "CORE::<name>" to their prototype. Turns out that if
340 # you "use autodie;" enough times, this pays off.
341 my %CORE_prototype_cache;
343 # We use our package in a few hash-keys. Having it in a scalar is
344 # convenient. The "guard $PACKAGE" string is used as a key when
345 # setting up lexical guards.
347 my $PACKAGE = __PACKAGE__;
348 my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
350 # Here's where all the magic happens when someone write 'use Fatal'
354 my $class = shift(@_);
355 my @original_args = @_;
358 my $insist_hints = 0;
360 my ($pkg, $filename) = caller();
362 @_ or return; # 'use Fatal' is a no-op.
364 # If we see the :lexical flag, then _all_ arguments are
367 if ($_[0] eq LEXICAL_TAG) {
371 # It is currently an implementation detail that autodie is
372 # implemented as "use Fatal qw(:lexical ...)". For backwards
373 # compatibility, we allow it - but not without a warning.
374 # NB: Optimise for autodie as it is quite possibly the most
375 # freq. consumer of this case.
376 if ($class ne 'autodie' and not $class->isa('autodie')) {
377 if ($class eq 'Fatal') {
380 '[deprecated] The "use Fatal qw(:lexical ...)" '
381 . 'should be replaced by "use autodie qw(...)". '
382 . 'Seen' # warnif appends " at <...>"
387 "[deprecated] The class/Package $class is a "
388 . 'subclass of Fatal and used the :lexical. '
389 . 'If $class provides lexical error checking '
390 . 'it should extend autodie instead of using :lexical. '
391 . 'Seen' # warnif appends " at <...>"
394 # "Promote" the call to autodie from here on. This is
395 # already mostly the case (e.g. use Fatal qw(:lexical ...)
396 # would throw autodie::exceptions on error rather than the
399 # This requires that autodie is in fact loaded; otherwise
400 # the "$class->X()" method calls below will explode.
402 # TODO, when autodie and Fatal are cleanly separated, we
403 # should go a "goto &autodie::import" here instead.
406 # If we see no arguments and :lexical, we assume they
410 push(@_, ':default');
413 # Don't allow :lexical with :void, it's needlessly confusing.
414 if ( grep { $_ eq VOID_TAG } @_ ) {
415 croak(ERROR_VOID_LEX);
419 if ( grep { $_ eq LEXICAL_TAG } @_ ) {
420 # If we see the lexical tag as the non-first argument, complain.
421 croak(ERROR_LEX_FIRST);
424 my @fatalise_these = @_;
426 # These subs will get unloaded at the end of lexical scope.
428 # These subs are to be installed into callers namespace.
431 # Use _translate_import_args to expand tags for us. It will
432 # pass-through unknown tags (i.e. we have to manually handle
435 # NB: _translate_import_args re-orders everything for us, so
436 # we don't have to worry about stuff like:
440 # That will (correctly) translated into
442 # expand(:defaults-without-io) :void :io
444 # by _translate_import_args.
445 for my $func ($class->_translate_import_args(@fatalise_these)) {
447 if ($func eq VOID_TAG) {
449 # When we see :void, set the void flag.
452 } elsif ($func eq INSIST_TAG) {
458 # Otherwise, fatalise it.
460 # Check to see if there's an insist flag at the front.
461 # If so, remove it, and insist we have hints for this sub.
462 my $insist_this = $insist_hints;
464 if (substr($func, 0, 1) eq '!') {
465 $func = substr($func, 1);
469 # We're going to make a subroutine fatalistic.
470 # However if we're being invoked with 'use Fatal qw(x)'
471 # and we've already been called with 'no autodie qw(x)'
472 # in the same scope, we consider this to be an error.
473 # Mixing Fatal and autodie effects was considered to be
474 # needlessly confusing on p5p.
477 $sub = "${pkg}::$sub" unless $sub =~ /::/;
479 # If we're being called as Fatal, and we've previously
480 # had a 'no X' in scope for the subroutine, then complain
483 if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
484 croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
487 # We're not being used in a confusing way, so make
488 # the sub fatal. Note that _make_fatal returns the
489 # old (original) version of the sub, or undef for
492 my $sub_ref = $class->_make_fatal(
493 $func, $pkg, $void, $lexical, $filename,
494 $insist_this, \%install_subs,
497 $Original_user_sub{$sub} ||= $sub_ref;
499 # If we're making lexical changes, we need to arrange
500 # for them to be cleaned at the end of our scope, so
503 $unload_later{$func} = $sub_ref if $lexical;
507 install_subs($pkg, \%install_subs);
511 # Dark magic to have autodie work under 5.8
512 # Copied from namespace::clean, that copied it from
513 # autobox, that found it on an ancient scroll written
516 # This magic bit causes %^H to be lexically scoped.
520 # Our package guard gets invoked when we leave our lexical
523 on_end_of_compile_scope(sub {
524 install_subs($pkg, \%unload_later);
527 # To allow others to determine when autodie was in scope,
528 # and with what arguments, we also set a %^H hint which
529 # is how we were called.
531 # This feature should be considered EXPERIMENTAL, and
532 # may change without notice. Please e-mail pjf@cpan.org
533 # if you're actually using it.
535 $^H{autodie} = "$PACKAGE @original_args";
546 # Calling "no Fatal" must start with ":lexical"
547 if ($_[0] ne LEXICAL_TAG) {
548 croak(sprintf(ERROR_NO_LEX,$class));
551 shift @_; # Remove :lexical
553 my $pkg = (caller)[0];
555 # If we've been called with arguments, then the developer
556 # has explicitly stated 'no autodie qw(blah)',
557 # in which case, we disable Fatalistic behaviour for 'blah'.
559 my @unimport_these = @_ ? @_ : ':all';
560 my (%uninstall_subs, %reinstall_subs);
562 for my $symbol ($class->_translate_import_args(@unimport_these)) {
565 $sub = "${pkg}::$sub" unless $sub =~ /::/;
567 # If 'blah' was already enabled with Fatal (which has package
568 # scope) then, this is considered an error.
570 if (exists $Package_Fatal{$sub}) {
571 croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
574 # Record 'no autodie qw($sub)' as being in effect.
575 # This is to catch conflicting semantics elsewhere
576 # (eg, mixing Fatal with no autodie)
578 $^H{$NO_PACKAGE}{$sub} = 1;
579 # Record the current sub to be reinstalled at end of scope
580 # and then restore the original (can be undef for "CORE::"
582 $reinstall_subs{$symbol} = \&$sub;
583 $uninstall_subs{$symbol} = $Original_user_sub{$sub};
587 install_subs($pkg, \%uninstall_subs);
588 on_end_of_compile_scope(sub {
589 install_subs($pkg, \%reinstall_subs);
596 sub _translate_import_args {
597 my ($class, @args) = @_;
602 # Optimize for this case, as it is fairly common. (e.g. use
603 # autodie; or use autodie qw(:all); both trigger this).
606 # Not a (known) tag, pass through.
607 return @args unless exists($TAGS{$args[0]});
609 # Strip "CORE::" from all elements in the list as import and
610 # unimport does not handle the "CORE::" prefix too well.
612 # NB: we use substr as it is faster than s/^CORE::// and
613 # it does not change the elements.
614 return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) };
617 # We want to translate
623 # expanded(:threads) :void expanded(:io)
625 # We accomplish this by "reverse, expand + filter, reverse".
626 for my $a (reverse(@args)) {
627 if (exists $TAGS{$a}) {
628 my $expanded = $class->_expand_tag($a);
630 # Remove duplicates after ...
631 grep { !$seen{$_}++ }
632 # we have stripped CORE:: (see above)
633 map { substr($_, 6) }
634 # We take the elements in reverse order
635 # (as @result be reversed later).
636 reverse(@{$expanded}));
638 # pass through - no filtering here for tags.
640 # The reason for not filtering tags cases like:
642 # ":default :void :io :void :threads"
644 # As we have reversed args, we see this as:
646 # ":threads :void :io :void* :default*"
648 # (Entries marked with "*" will be filtered out completely). When
649 # reversed again, this will be:
651 # ":io :void :threads"
653 # But we would rather want it to be:
655 # ":void :io :threads" or ":void :io :void :threads"
658 my $letter = substr($a, 0, 1);
659 if ($letter ne ':' && $a ne INSIST_TAG) {
661 if ($letter eq '!' and $seen{substr($a, 1)}++) {
662 my $name = substr($a, 1);
663 # People are being silly and doing:
665 # use autodie qw(!a a);
667 # Enjoy this little O(n) clean up...
668 @result = grep { $_ ne $name } @result;
674 # Reverse the result to restore the input order
675 return reverse(@result);
679 # NB: Perl::Critic's dump-autodie-tag-contents depends upon this
680 # continuing to work.
683 # We assume that $TAGS{':all'} is pre-expanded and just fill it in
684 # from the beginning.
686 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}],
689 # Expand a given tag (e.g. ":default") into a listref containing
690 # all sub names covered by that tag. Each sub is returned as
691 # "CORE::<name>" (i.e. "CORE::open" rather than "open").
693 # NB: the listref must not be modified.
695 my ($class, $tag) = @_;
697 if (my $cached = $tag_cache{$tag}) {
701 if (not exists $TAGS{$tag}) {
702 croak "Invalid exception class $tag";
705 my @to_process = @{$TAGS{$tag}};
707 # If the tag is basically an alias of another tag (like e.g. ":2.11"),
708 # then just share the resulting reference with the original content (so
709 # we only pay for an extra reference for the alias memory-wise).
710 if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') {
711 # We could do this for "non-tags" as well, but that only occurs
712 # once at the time of writing (":threads" => ["fork"]), so
713 # probably not worth it.
714 my $expanded = $class->_expand_tag($to_process[0]);
715 $tag_cache{$tag} = $expanded;
722 for my $item (@to_process) {
723 # substr is more efficient than m/^:/ for stuff like this,
724 # at the price of being a bit more verbose/low-level.
725 if (substr($item, 0, 1) eq ':') {
726 # Use recursion here to ensure we expand a tag at most once.
728 my $expanded = $class->_expand_tag($item);
729 push @taglist, grep { !$seen{$_}++ } @{$expanded};
731 my $subname = "CORE::$item";
732 push @taglist, $subname
733 unless $seen{$subname}++;
737 $tag_cache{$tag} = \@taglist;
745 # This is a backwards compatible version of _write_invocation. It's
746 # recommended you don't use it.
748 sub write_invocation {
749 my ($core, $call, $name, $void, @args) = @_;
751 return Fatal->_write_invocation(
752 $core, $call, $name, $void,
754 undef, # Sub, unused in legacy mode
755 undef, # Subref, unused in legacy mode.
760 # This version of _write_invocation is used internally. It's not
761 # recommended you call it from external code, as the interface WILL
762 # change in the future.
764 sub _write_invocation {
766 my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
768 if (@argvs == 1) { # No optional arguments
770 my @argv = @{$argvs[0]};
773 return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
777 my (@out, @argv, $n);
779 @argv = @{shift @argvs};
782 my $condition = "\@_ == $n";
784 if (@argv and $argv[-1] =~ /[#@]_/) {
785 # This argv ends with '@' in the prototype, so it matches
786 # any number of args >= the number of expressions in the
788 $condition = "\@_ >= $n";
791 push @out, "${else}if ($condition) {\n";
795 push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
799 die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
802 return join '', @out;
807 # This is a slim interface to ensure backward compatibility with
808 # anyone doing very foolish things with old versions of Fatal.
811 my ($core, $call, $name, $void, @argv) = @_;
813 return Fatal->_one_invocation(
814 $core, $call, $name, $void,
815 undef, # Sub. Unused in back-compat mode.
816 1, # Back-compat flag
817 undef, # Subref, unused in back-compat mode.
823 # This is the internal interface that generates code.
824 # NOTE: This interface WILL change in the future. Please do not
825 # call this subroutine directly.
827 # TODO: Whatever's calling this code has already looked up hints. Pass
828 # them in, rather than look them up a second time.
830 sub _one_invocation {
831 my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
834 # If someone is calling us directly (a child class perhaps?) then
835 # they could try to mix void without enabling backwards
836 # compatibility. We just don't support this at all, so we gripe
837 # about it rather than doing something unwise.
839 if ($void and not $back_compat) {
840 Carp::confess("Internal error: :void mode not supported with $class");
843 # @argv only contains the results of the in-built prototype
844 # function, and is therefore safe to interpolate in the
845 # code generators below.
847 # TODO - The following clobbers context, but that's what the
848 # old Fatal did. Do we care?
852 # Use Fatal qw(system) will never be supported. It generated
853 # a compile-time error with legacy Fatal, and there's no reason
854 # to support it when autodie does a better job.
856 if ($call eq 'CORE::system') {
858 croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
865 return qq/return (defined wantarray)?$call(@argv):
866 $call(@argv) || Carp::croak("Can't $name(\@_)/ .
867 ($core ? ': $!' : ', \$! is \"$!\"') . '")'
869 return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
870 ($core ? ': $!' : ', \$! is \"$!\"') . '")';
874 # The name of our original function is:
875 # $call if the function is CORE
876 # $sub if our function is non-CORE
878 # The reason for this is that $call is what we're actually
879 # calling. For our core functions, this is always
880 # CORE::something. However for user-defined subs, we're about to
881 # replace whatever it is that we're calling; as such, we actually
882 # calling a subroutine ref.
884 my $human_sub_name = $core ? $call : $sub;
886 # Should we be testing to see if our result is defined, or
891 my $hints; # All user-sub hints, including list hints.
895 # Core hints are built into autodie.
897 $use_defined_or = exists ( $Use_defined_or{$call} );
902 # User sub hints are looked up using autodie::hints,
903 # since users may wish to add their own hints.
905 require autodie::hints;
907 $hints = autodie::hints->get_hints_for( $sref );
909 # We'll look up the sub's fullname. This means we
910 # get better reports of where it came from in our
911 # error messages, rather than what imported it.
913 $human_sub_name = autodie::hints->sub_fullname( $sref );
917 # Checks for special core subs.
919 if ($call eq 'CORE::system') {
921 # Leverage IPC::System::Simple if we're making an autodying
926 # We need to stash $@ into $E, rather than using
927 # local $@ for the whole sub. If we don't then
928 # any exceptions from internal errors in autodie/Fatal
929 # will mysteriously disappear before propagating
941 \$retval = IPC::System::Simple::system(@argv);
949 # TODO - This can't be overridden in child
952 die autodie::exception::system->new(
953 function => q{CORE::system}, args => [ @argv ],
954 message => "\$E", errno => \$!,
965 # If we're going to throw an exception, here's the code to use.
968 function => q{$human_sub_name}, args => [ @argv ],
969 pragma => q{$class}, errno => \$!,
970 context => \$context, return => \$retval,
975 if ($call eq 'CORE::flock') {
977 # flock needs special treatment. When it fails with
978 # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
979 # means we couldn't get the lock right now.
981 require POSIX; # For POSIX::EWOULDBLOCK
983 local $@; # Don't blat anyone else's $@.
985 # Ensure that our vendor supports EWOULDBLOCK. If they
986 # don't (eg, Windows), then we use known values for its
987 # equivalent on other systems.
989 my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
990 || $_EWOULDBLOCK{$^O}
991 || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
992 my $EAGAIN = $EWOULDBLOCK;
994 $EAGAIN = eval { POSIX::EAGAIN(); }
995 || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
998 require Fcntl; # For Fcntl::LOCK_NB
1002 my \$context = wantarray() ? "list" : "scalar";
1004 # Try to flock. If successful, return it immediately.
1006 my \$retval = $call(@argv);
1007 return \$retval if \$retval;
1009 # If we failed, but we're using LOCK_NB and
1010 # returned EWOULDBLOCK, it's not a real error.
1012 if (\$_[1] & Fcntl::LOCK_NB() and
1013 (\$! == $EWOULDBLOCK or
1014 ($try_EAGAIN and \$! == $EAGAIN ))) {
1018 # Otherwise, we failed. Die noisily.
1025 if (exists $Returns_num_things_changed{$call}) {
1027 # Some things return the number of things changed (like
1028 # chown, kill, chmod, etc). We only consider these successful
1029 # if *all* the things are changed.
1032 my \$num_things = \@_ - $Returns_num_things_changed{$call};
1033 my \$retval = $call(@argv);
1035 if (\$retval != \$num_things) {
1037 # We need \$context to throw an exception.
1038 # It's *always* set to scalar, because that's how
1039 # autodie calls chown() above.
1041 my \$context = "scalar";
1049 # AFAIK everything that can be given an unopned filehandle
1050 # will fail if it tries to use it, so we don't really need
1051 # the 'unopened' warning class here. Especially since they
1052 # then report the wrong line number.
1054 # Other warnings are disabled because they produce excessive
1055 # complaints from smart-match hints under 5.10.1.
1058 no warnings qw(unopened uninitialized numeric);
1059 no if \$\] >= 5.017011, warnings => "experimental::smartmatch";
1062 my \@results = $call(@argv);
1063 my \$retval = \\\@results;
1064 my \$context = "list";
1068 my $retval_action = $Retval_action{$call} || '';
1070 if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
1072 # NB: Subroutine hints are passed as a full list.
1073 # This differs from the 5.10.0 smart-match behaviour,
1074 # but means that context unaware subroutines can use
1075 # the same hints in both list and scalar context.
1078 if ( \$hints->{list}->(\@results) ) { $die };
1081 elsif ( PERL510 and $hints ) {
1083 if ( \@results ~~ \$hints->{list} ) { $die };
1087 croak sprintf(ERROR_58_HINTS, 'list', $sub);
1091 # An empty list, or a single undef is failure
1092 if (! \@results or (\@results == 1 and ! defined \$results[0])) {
1098 # Tidy up the end of our wantarray call.
1106 # Otherwise, we're in scalar context.
1107 # We're never in a void context, since we have to look
1111 my \$retval = $call(@argv);
1112 my \$context = "scalar";
1115 if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
1117 # We always call code refs directly, since that always
1118 # works in 5.8.x, and always works in 5.10.1
1121 if ( \$hints->{scalar}->(\$retval) ) { $die };
1127 elsif (PERL510 and $hints) {
1130 if ( \$retval ~~ \$hints->{scalar} ) { $die };
1136 croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
1140 ( $use_defined_or ? qq{
1142 $die if not defined \$retval;
1149 return \$retval || $die;
1155 # This returns the old copy of the sub, so we can
1156 # put it back at end of scope.
1158 # TODO : Check to make sure prototypes are restored correctly.
1160 # TODO: Taking a huge list of arguments is awful. Rewriting to
1161 # take a hash would be lovely.
1163 # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
1166 my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_;
1167 my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type);
1172 if (index($sub, '::') == -1) {
1173 $sub = "${pkg}::$sub";
1174 if (substr($name, 0, 1) eq '&') {
1175 $name = substr($name, 1);
1182 # Figure if we're using lexical or package semantics and
1183 # twiddle the appropriate bits.
1186 $Package_Fatal{$sub} = 1;
1189 # TODO - We *should* be able to do skipping, since we know when
1190 # we've lexicalised / unlexicalised a subroutine.
1193 warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
1194 croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
1196 if (defined(&$sub)) { # user subroutine
1198 # NOTE: Previously we would localise $@ at this point, so
1199 # the following calls to eval {} wouldn't interfere with anything
1200 # that's already in $@. Unfortunately, it would also stop
1201 # any of our croaks from triggering(!), which is even worse.
1203 # This could be something that we've fatalised that
1206 # Store the current sub in case we need to restore it.
1209 if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) {
1211 # Something we previously made Fatal that was core.
1212 # This is safe to replace with an autodying to core
1216 $call = "CORE::$name";
1217 $proto = $CORE_prototype_cache{$call};
1219 # We return our $sref from this subroutine later
1220 # on, indicating this subroutine should be placed
1221 # back when we're finished.
1227 # If this is something we've already fatalised or played with,
1228 # then look-up the name of the original sub for the rest of
1231 if (exists($Is_fatalised_sub{$sref})) {
1232 # $sub is one of our wrappers around a CORE sub or a
1233 # user sub. Instead of wrapping our wrapper, lets just
1234 # generate a new wrapper for the original sub.
1235 # - NB: the current wrapper might be for a different class
1236 # than the one we are generating now (e.g. some limited
1237 # mixing between use Fatal + use autodie can occur).
1238 # - Even for nested autodie, we need this as the leak guards
1240 my $s = $Is_fatalised_sub{$sref};
1242 # It is a wrapper for a user sub
1245 # It is a wrapper for a CORE:: sub
1247 $call = "CORE::$name";
1248 $proto = $CORE_prototype_cache{$call};
1252 # A regular user sub, or a user sub wrapping a
1256 # A non-CORE sub might have hints and such...
1257 $proto = prototype($sref);
1259 require autodie::hints;
1261 $hints = autodie::hints->get_hints_for( $sref );
1263 # If we've insisted on hints, but don't have them, then
1266 if ($insist and not $hints) {
1267 croak(sprintf(ERROR_NOHINTS, $name));
1270 # Otherwise, use the default hints if we don't have
1273 $hints ||= autodie::hints::DEFAULT_HINTS();
1278 } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
1279 # Stray user subroutine
1280 croak(sprintf(ERROR_NOTSUB,$sub));
1282 } elsif ($name eq 'system') {
1284 # If we're fatalising system, then we need to load
1287 # The business with $E is to avoid clobbering our caller's
1288 # $@, and to avoid $@ being localised when we croak.
1296 require IPC::System::Simple; # Only load it if we need it.
1297 require autodie::exception::system;
1302 if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
1304 # Make sure we're using a recent version of ISS that actually
1305 # support fatalised system.
1306 if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
1308 ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
1309 $IPC::System::Simple::VERSION
1313 $call = 'CORE::system';
1316 } elsif ($name eq 'exec') {
1317 # Exec doesn't have a prototype. We don't care. This
1318 # breaks the exotic form with lexical scope, and gives
1319 # the regular form a "do or die" behavior as expected.
1321 $call = 'CORE::exec';
1324 } else { # CORE subroutine
1325 $call = "CORE::$name";
1326 if (exists($CORE_prototype_cache{$call})) {
1327 $proto = $CORE_prototype_cache{$call};
1332 $proto = eval { prototype $call };
1335 croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
1336 croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
1337 $CORE_prototype_cache{$call} = $proto;
1342 # TODO: This caching works, but I don't like using $void and
1343 # $lexical as keys. In particular, I suspect our code may end up
1344 # wrapping already wrapped code when autodie and Fatal are used
1347 # NB: We must use '$sub' (the name plus package) and not
1348 # just '$name' (the short name) here. Failing to do so
1349 # results code that's in the wrong package, and hence has
1350 # access to the wrong package filehandles.
1352 $cache = $Cached_fatalised_sub{$class}{$sub};
1354 $cache_type = CACHE_AUTODIE_LEAK_GUARD;
1356 $cache_type = CACHE_FATAL_WRAPPER;
1357 $cache_type = CACHE_FATAL_VOID if $void;
1360 if (my $subref = $cache->{$cache_type}) {
1361 $install_subs->{$name} = $subref;
1365 # If our subroutine is reusable (ie, not package depdendent),
1366 # then check to see if we've got a cached copy, and use that.
1367 # See RT #46984. (Thanks to Niels Thykier for being awesome!)
1369 if ($core && exists $reusable_builtins{$call}) {
1370 # For non-lexical subs, we can just use this cache directly
1371 # - for lexical variants, we need a leak guard as well.
1372 $code = $reusable_builtins{$call}{$lexical};
1373 if (!$lexical && defined($code)) {
1374 $install_subs->{$name} = $code;
1379 if (!($lexical && $core) && !defined($code)) {
1380 # No code available, generate it now.
1381 my $wrapper_pkg = $pkg;
1382 $wrapper_pkg = undef if (exists($reusable_builtins{$call}));
1383 $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name,
1384 $void, $lexical, $sub, $sref,
1386 if (!defined($wrapper_pkg)) {
1387 # cache it so we don't recompile this part again
1388 $reusable_builtins{$call}{$lexical} = $code;
1392 # Now we need to wrap our fatalised sub inside an itty bitty
1393 # closure, which can detect if we've leaked into another file.
1394 # Luckily, we only need to do this for lexical (autodie)
1395 # subs. Fatal subs can leak all they want, it's considered
1396 # a "feature" (or at least backwards compatible).
1398 # TODO: Cache our leak guards!
1400 # TODO: This is pretty hairy code. A lot more tests would
1401 # be really nice for this.
1403 my $installed_sub = $code;
1406 $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call,
1410 $cache->{$cache_type} = $code;
1412 $install_subs->{$name} = $installed_sub;
1414 # Cache that we've now overridden this sub. If we get called
1415 # again, we may need to find that find subroutine again (eg, for hints).
1417 $Is_fatalised_sub{$installed_sub} = $sref;
1423 # This subroutine exists primarily so that child classes can override
1424 # it to point to their own exception class. Doing this is significantly
1425 # less complex than overriding throw()
1427 sub exception_class { return "autodie::exception" };
1430 my %exception_class_for;
1434 my ($class, @args) = @_;
1436 # Find our exception class if we need it.
1437 my $exception_class =
1438 $exception_class_for{$class} ||= $class->exception_class;
1440 if (not $class_loaded{$exception_class}) {
1441 if ($exception_class =~ /[^\w:']/) {
1442 confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
1445 # Alas, Perl does turn barewords into modules unless they're
1446 # actually barewords. As such, we're left doing a string eval
1447 # to make sure we load our file correctly.
1452 local $@; # We can't clobber $@, it's wrong!
1453 my $pm_file = $exception_class . ".pm";
1454 $pm_file =~ s{ (?: :: | ' ) }{/}gx;
1455 eval { require $pm_file };
1456 $E = $@; # Save $E despite ending our local.
1459 # We need quotes around $@ to make sure it's stringified
1460 # while still in scope. Without them, we run the risk of
1461 # $@ having been cleared by us exiting the local() block.
1463 confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
1465 $class_loaded{$exception_class}++;
1469 return $exception_class->new(@args);
1473 # Creates and returns a leak guard (with prototype if needed).
1474 sub _make_leak_guard {
1475 my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_;
1477 # The leak guard is rather lengthly (in fact it makes up the most
1478 # of _make_leak_guard). It is possible to split it into a large
1479 # "generic" part and a small wrapper with call-specific
1480 # information. This was done in v2.19 and profiling suggested
1481 # that we ended up using a substantial amount of runtime in "goto"
1482 # between the leak guard(s) and the final sub. Therefore, the two
1483 # parts were merged into one to reduce the runtime overhead.
1485 my $leak_guard = sub {
1486 my $caller_level = 0;
1489 while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) {
1491 # If our filename is actually an eval, and we
1492 # reach it, then go to our autodying code immediatately.
1494 last if ($caller eq $filename);
1498 # We're now out of the eval stack.
1500 if ($caller eq $filename) {
1501 # No leak, call the wrapper. NB: In this case, it doesn't
1502 # matter if it is a CORE sub or not.
1503 if (!defined($wrapped_sub)) {
1504 # CORE sub that we were too lazy to compile when we
1505 # created this leak guard.
1506 die "$call is not CORE::<something>"
1507 if substr($call, 0, 6) ne 'CORE::';
1509 my $name = substr($call, 6);
1512 my $wrapper_pkg = $pkg;
1514 if (exists($reusable_builtins{$call})) {
1515 $code = $reusable_builtins{$call}{$lexical};
1516 $wrapper_pkg = undef;
1518 if (!defined($code)) {
1519 $code = $class->_compile_wrapper($wrapper_pkg,
1526 undef, # subref (not used for core)
1527 undef, # hints (not used for core)
1530 if (!defined($wrapper_pkg)) {
1531 # cache it so we don't recompile this part again
1532 $reusable_builtins{$call}{$lexical} = $code;
1535 # As $wrapped_sub is "closed over", updating its value will
1536 # be "remembered" for the next call.
1537 $wrapped_sub = $code;
1542 # We leaked, time to call the original function.
1543 # - for non-core functions that will be $orig_sub
1544 # - for CORE functions, $orig_sub may be a trampoline
1545 goto $orig_sub if defined($orig_sub);
1547 # We are wrapping a CORE sub and we do not have a trampoline
1550 # If we've cached a trampoline, then use it. Usually only
1551 # resuable subs will have cache hits, but non-reusuably ones
1552 # can get it as well in (very) rare cases. It is mostly in
1553 # cases where a package uses autodie multiple times and leaks
1554 # from multiple places. Possibly something like:
1556 # package Pkg::With::LeakyCode;
1559 # code_that_leaks();
1564 # more_leaky_code();
1567 # Note that we use "Fatal" as package name for reusable subs
1568 # because A) that allows us to trivially re-use the
1569 # trampolines as well and B) because the reusable sub is
1570 # compiled into "package Fatal" as well.
1572 $pkg = 'Fatal' if exists $reusable_builtins{$call};
1573 $orig_sub = $Trampoline_cache{$pkg}{$call};
1575 if (not $orig_sub) {
1576 # If we don't have a trampoline, we need to build it.
1578 # We only generate trampolines when we need them, and
1579 # we can cache them by subroutine + package.
1581 # As $orig_sub is "closed over", updating its value will
1582 # be "remembered" for the next call.
1584 $orig_sub = make_core_trampoline($call, $pkg, $proto);
1586 # We still cache it despite remembering it in $orig_sub as
1587 # well. In particularly, we rely on this to avoid
1588 # re-compiling the reusable trampolines.
1589 $Trampoline_cache{$pkg}{$call} = $orig_sub;
1592 # Bounce to our trampoline, which takes us to our core sub.
1594 }; # <-- end of leak guard
1596 # If there is a prototype on the original sub, copy it to the leak
1598 if (defined $proto) {
1599 # The "\&" may appear to be redundant but set_prototype
1600 # croaks when it is removed.
1601 set_prototype(\&$leak_guard, $proto);
1607 sub _compile_wrapper {
1608 my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_;
1609 my $real_proto = '';
1612 if (defined $proto) {
1613 $real_proto = " ($proto)";
1618 @protos = fill_protos($proto);
1625 local($", $!) = (', ', 0);
1629 # Don't have perl whine if exec fails, since we'll be handling
1630 # the exception now.
1631 $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
1633 $code .= $class->_write_invocation($core, $call, $name, $void, $lexical,
1634 $sub, $sref, @protos);
1636 warn $code if $Debug;
1638 # I thought that changing package was a monumental waste of
1639 # time for CORE subs, since they'll always be the same. However
1640 # that's not the case, since they may refer to package-based
1641 # filehandles (eg, with open).
1643 # The %reusable_builtins hash defines ones we can aggressively
1644 # cache as they never depend upon package-based symbols.
1649 no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
1651 if (defined($wrapper_pkg)) {
1652 $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic
1654 $code = eval("require Carp; $code"); ## no critic
1661 my $true_name = $core ? $call : $sub;
1662 croak("Internal error in autodie/Fatal processing $true_name: $E");
1667 # For some reason, dying while replacing our subs doesn't
1668 # kill our calling program. It simply stops the loading of
1669 # autodie and keeps going with everything else. The _autocroak
1670 # sub allows us to die with a vengeance. It should *only* ever be
1671 # used for serious internal errors, since the results of it can't
1675 warn Carp::longmess(@_);
1685 Fatal - Replace functions with equivalents which succeed or die
1689 use Fatal qw(open close);
1691 open(my $fh, "<", $filename); # No need to check errors!
1693 use File::Copy qw(move);
1696 move($file1, $file2); # No need to check errors!
1698 sub juggle { . . . }
1699 Fatal->import('juggle');
1701 =head1 BEST PRACTICE
1703 B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
1704 L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
1705 throws real exception objects, and provides much nicer error messages.
1707 The use of C<:void> with Fatal is discouraged.
1711 C<Fatal> provides a way to conveniently replace
1712 functions which normally return a false value when they fail with
1713 equivalents which raise exceptions if they are not successful. This
1714 lets you use these functions without having to test their return
1715 values explicitly on each call. Exceptions can be caught using
1716 C<eval{}>. See L<perlfunc> and L<perlvar> for details.
1718 The do-or-die equivalents are set up simply by calling Fatal's
1719 C<import> routine, passing it the names of the functions to be
1720 replaced. You may wrap both user-defined functions and overridable
1721 CORE operators (except C<exec>, C<system>, C<print>, or any other
1722 built-in that cannot be expressed via prototypes) in this way.
1724 If the symbol C<:void> appears in the import list, then functions
1725 named later in that import list raise an exception only when
1726 these are called in void context--that is, when their return
1727 values are ignored. For example
1729 use Fatal qw/:void open close/;
1731 # properly checked, so no exception raised on error
1732 if (not open(my $fh, '<', '/bogotic') {
1733 warn "Can't open /bogotic: $!";
1736 # not checked, so error raises an exception
1739 The use of C<:void> is discouraged, as it can result in exceptions
1740 not being thrown if you I<accidentally> call a method without
1741 void context. Use L<autodie> instead if you need to be able to
1742 disable autodying/Fatal behaviour for a small block of code.
1748 =item Bad subroutine name for Fatal: %s
1750 You've called C<Fatal> with an argument that doesn't look like
1751 a subroutine name, nor a switch that this version of Fatal
1754 =item %s is not a Perl subroutine
1756 You've asked C<Fatal> to try and replace a subroutine which does not
1757 exist, or has not yet been defined.
1759 =item %s is neither a builtin, nor a Perl subroutine
1761 You've asked C<Fatal> to replace a subroutine, but it's not a Perl
1762 built-in, and C<Fatal> couldn't find it as a regular subroutine.
1763 It either doesn't exist or has not yet been defined.
1765 =item Cannot make the non-overridable %s fatal
1767 You've tried to use C<Fatal> on a Perl built-in that can't be
1768 overridden, such as C<print> or C<system>, which means that
1769 C<Fatal> can't help you, although some other modules might.
1770 See the L</"SEE ALSO"> section of this documentation.
1772 =item Internal error: %s
1774 You've found a bug in C<Fatal>. Please report it using
1775 the C<perlbug> command.
1781 C<Fatal> clobbers the context in which a function is called and always
1782 makes it a scalar context, except when the C<:void> tag is used.
1783 This problem does not exist in L<autodie>.
1785 "Used only once" warnings can be generated when C<autodie> or C<Fatal>
1786 is used with package filehandles (eg, C<FILE>). It's strongly recommended
1787 you use scalar filehandles instead.
1791 Original module by Lionel Cons (CERN).
1793 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
1795 L<autodie> support, bugfixes, extended diagnostics, C<system>
1796 support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
1800 This module is free software, you may distribute it under the
1801 same terms as Perl itself.
1805 L<autodie> for a nicer way to use lexical Fatal.
1807 L<IPC::System::Simple> for a similar idea for calls to C<system()>
1810 =for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG