3 use 5.008; # 5.8.x needed for autodie
7 use Tie::RefHash; # To cache subroutine refs
9 use constant PERL510 => ( $] >= 5.010 );
11 use constant LEXICAL_TAG => q{:lexical};
12 use constant VOID_TAG => q{:void};
13 use constant INSIST_TAG => q{!};
15 use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
16 use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
17 use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
18 use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
19 use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
20 use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
21 use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
22 use constant ERROR_NOHINTS => "No user hints defined for %s";
24 use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
26 use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
28 use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
30 use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
32 use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
34 use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
36 # Older versions of IPC::System::Simple don't support all the
39 use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
41 # All the Fatal/autodie modules share the same version number.
42 our $VERSION = '2.06_01';
46 # EWOULDBLOCK values for systems that don't supply their own.
47 # Even though this is defined with our, that's to help our
48 # test code. Please don't rely upon this variable existing in
55 # We have some tags that can be passed in for use with import.
56 # These are all assumed to be CORE::
59 ':io' => [qw(:dbm :file :filesys :ipc :socket
60 read seek sysread syswrite sysseek )],
61 ':dbm' => [qw(dbmopen dbmclose)],
62 ':file' => [qw(open close flock sysopen fcntl fileno binmode
64 ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
65 symlink rmdir readlink umask)],
66 ':ipc' => [qw(:msg :semaphore :shm pipe)],
67 ':msg' => [qw(msgctl msgget msgrcv msgsnd)],
68 ':threads' => [qw(fork)],
69 ':semaphore'=>[qw(semctl semget semop)],
70 ':shm' => [qw(shmctl shmget shmread)],
71 ':system' => [qw(system exec)],
73 # Can we use qw(getpeername getsockname)? What do they do on failure?
74 # TODO - Can socket return false?
75 ':socket' => [qw(accept bind connect getsockopt listen recv send
76 setsockopt shutdown socketpair)],
78 # Our defaults don't include system(), because it depends upon
79 # an optional module, and it breaks the exotic form.
81 # This *may* change in the future. I'd love IPC::System::Simple
82 # to be a dependency rather than a recommendation, and hence for
83 # system() to be autodying by default.
85 ':default' => [qw(:io :threads)],
87 # Version specific tags. These allow someone to specify
88 # use autodie qw(:1.994) and know exactly what they'll get.
90 ':1.994' => [qw(:default)],
91 ':1.995' => [qw(:default)],
92 ':1.996' => [qw(:default)],
93 ':1.997' => [qw(:default)],
94 ':1.998' => [qw(:default)],
95 ':1.999' => [qw(:default)],
96 ':1.999_01' => [qw(:default)],
97 ':2.00' => [qw(:default)],
98 ':2.01' => [qw(:default)],
99 ':2.02' => [qw(:default)],
100 ':2.03' => [qw(:default)],
101 ':2.04' => [qw(:default)],
102 ':2.05' => [qw(:default)],
103 ':2.06' => [qw(:default)],
104 ':2.06_01' => [qw(:default)],
107 $TAGS{':all'} = [ keys %TAGS ];
109 # This hash contains subroutines for which we should
110 # subroutine() // die() rather than subroutine() || die()
114 # CORE::open returns undef on failure. It can legitimately return
115 # 0 on success, eg: open(my $fh, '-|') || exec(...);
131 # Cached_fatalised_sub caches the various versions of our
132 # fatalised subs as they're produced. This means we don't
133 # have to build our own replacement of CORE::open and friends
134 # for every single package that wants to use them.
136 my %Cached_fatalised_sub = ();
138 # Every time we're called with package scope, we record the subroutine
139 # (including package or CORE::) in %Package_Fatal. This allows us
140 # to detect illegal combinations of autodie and Fatal, and makes sure
141 # we don't accidently make a Fatal function autodying (which isn't
144 my %Package_Fatal = ();
146 # The first time we're called with a user-sub, we cache it here.
147 # In the case of a "no autodie ..." we put back the cached copy.
149 my %Original_user_sub = ();
151 # Is_fatalised_sub simply records a big map of fatalised subroutine
152 # refs. It means we can avoid repeating work, or fatalising something
153 # we've already processed.
155 my %Is_fatalised_sub = ();
156 tie %Is_fatalised_sub, 'Tie::RefHash';
158 # We use our package in a few hash-keys. Having it in a scalar is
159 # convenient. The "guard $PACKAGE" string is used as a key when
160 # setting up lexical guards.
162 my $PACKAGE = __PACKAGE__;
163 my $PACKAGE_GUARD = "guard $PACKAGE";
164 my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
166 # Here's where all the magic happens when someone write 'use Fatal'
170 my $class = shift(@_);
173 my $insist_hints = 0;
175 my ($pkg, $filename) = caller();
177 @_ or return; # 'use Fatal' is a no-op.
179 # If we see the :lexical flag, then _all_ arguments are
182 if ($_[0] eq LEXICAL_TAG) {
186 # If we see no arguments and :lexical, we assume they
190 push(@_, ':default');
193 # Don't allow :lexical with :void, it's needlessly confusing.
194 if ( grep { $_ eq VOID_TAG } @_ ) {
195 croak(ERROR_VOID_LEX);
199 if ( grep { $_ eq LEXICAL_TAG } @_ ) {
200 # If we see the lexical tag as the non-first argument, complain.
201 croak(ERROR_LEX_FIRST);
204 my @fatalise_these = @_;
206 # Thiese subs will get unloaded at the end of lexical scope.
209 # This hash helps us track if we've alredy done work.
212 # NB: we're using while/shift rather than foreach, since
213 # we'll be modifying the array as we walk through it.
215 while (my $func = shift @fatalise_these) {
217 if ($func eq VOID_TAG) {
219 # When we see :void, set the void flag.
222 } elsif ($func eq INSIST_TAG) {
226 } elsif (exists $TAGS{$func}) {
228 # When it's a tag, expand it.
229 push(@fatalise_these, @{ $TAGS{$func} });
233 # Otherwise, fatalise it.
235 # Check to see if there's an insist flag at the front.
236 # If so, remove it, and insist we have hints for this sub.
239 if ($func =~ s/^!//) {
243 # TODO: Even if we've already fatalised, we should
244 # check we've done it with hints (if $insist_hints).
246 # If we've already made something fatal this call,
247 # then don't do it twice.
249 next if $done_this{$func};
251 # We're going to make a subroutine fatalistic.
252 # However if we're being invoked with 'use Fatal qw(x)'
253 # and we've already been called with 'no autodie qw(x)'
254 # in the same scope, we consider this to be an error.
255 # Mixing Fatal and autodie effects was considered to be
256 # needlessly confusing on p5p.
259 $sub = "${pkg}::$sub" unless $sub =~ /::/;
261 # If we're being called as Fatal, and we've previously
262 # had a 'no X' in scope for the subroutine, then complain
265 if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
266 croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
269 # We're not being used in a confusing way, so make
270 # the sub fatal. Note that _make_fatal returns the
271 # old (original) version of the sub, or undef for
274 my $sub_ref = $class->_make_fatal(
275 $func, $pkg, $void, $lexical, $filename,
276 ( $insist_this || $insist_hints )
281 $Original_user_sub{$sub} ||= $sub_ref;
283 # If we're making lexical changes, we need to arrange
284 # for them to be cleaned at the end of our scope, so
287 $unload_later{$func} = $sub_ref if $lexical;
293 # Dark magic to have autodie work under 5.8
294 # Copied from namespace::clean, that copied it from
295 # autobox, that found it on an ancient scroll written
298 # This magic bit causes %^H to be lexically scoped.
302 # Our package guard gets invoked when we leave our lexical
305 push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
306 $class->_install_subs($pkg, \%unload_later);
315 # The code here is originally lifted from namespace::clean,
316 # by Robert "phaylon" Sedlacek.
318 # It's been redesigned after feedback from ikegami on perlmonks.
319 # See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
321 # Given a package, and hash of (subname => subref) pairs,
322 # we install the given subroutines into the package. If
323 # a subref is undef, the subroutine is removed. Otherwise
324 # it replaces any existing subs which were already there.
327 my ($class, $pkg, $subs_to_reinstate) = @_;
329 my $pkg_sym = "${pkg}::";
331 while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
333 my $full_path = $pkg_sym.$sub_name;
335 # Copy symbols across to temp area.
337 no strict 'refs'; ## no critic
339 local *__tmp = *{ $full_path };
342 { no strict; delete $pkg_sym->{$sub_name}; } ## no critic
344 # Copy innocent bystanders back. Note that we lose
345 # formats; it seems that Perl versions up to 5.10.0
346 # have a bug which causes copying formats to end up in
347 # the scalar slot. Thanks to Ben Morrow for spotting this.
349 foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
350 next unless defined *__tmp{ $slot };
351 *{ $full_path } = *__tmp{ $slot };
354 # Put back the old sub (if there was one).
358 no strict; ## no critic
359 *{ $pkg_sym . $sub_name } = $sub_ref;
369 # Calling "no Fatal" must start with ":lexical"
370 if ($_[0] ne LEXICAL_TAG) {
371 croak(sprintf(ERROR_NO_LEX,$class));
374 shift @_; # Remove :lexical
376 my $pkg = (caller)[0];
378 # If we've been called with arguments, then the developer
379 # has explicitly stated 'no autodie qw(blah)',
380 # in which case, we disable Fatalistic behaviour for 'blah'.
382 my @unimport_these = @_ ? @_ : ':all';
384 while (my $symbol = shift @unimport_these) {
386 if ($symbol =~ /^:/) {
388 # Looks like a tag! Expand it!
389 push(@unimport_these, @{ $TAGS{$symbol} });
395 $sub = "${pkg}::$sub" unless $sub =~ /::/;
397 # If 'blah' was already enabled with Fatal (which has package
398 # scope) then, this is considered an error.
400 if (exists $Package_Fatal{$sub}) {
401 croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
404 # Record 'no autodie qw($sub)' as being in effect.
405 # This is to catch conflicting semantics elsewhere
406 # (eg, mixing Fatal with no autodie)
408 $^H{$NO_PACKAGE}{$sub} = 1;
410 if (my $original_sub = $Original_user_sub{$sub}) {
411 # Hey, we've got an original one of these, put it back.
412 $class->_install_subs($pkg, { $symbol => $original_sub });
416 # We don't have an original copy of the sub, on the assumption
417 # it's core (or doesn't exist), we'll just nuke it.
419 $class->_install_subs($pkg,{ $symbol => undef });
427 # TODO - This is rather terribly inefficient right now.
429 # NB: Perl::Critic's dump-autodie-tag-contents depends upon this
430 # continuing to work.
436 my ($class, $tag) = @_;
438 if (my $cached = $tag_cache{$tag}) {
442 if (not exists $TAGS{$tag}) {
443 croak "Invalid exception class $tag";
446 my @to_process = @{$TAGS{$tag}};
450 while (my $item = shift @to_process) {
452 push(@to_process, @{$TAGS{$item}} );
454 push(@taglist, "CORE::$item");
458 $tag_cache{$tag} = \@taglist;
466 # This code is from the original Fatal. It scares me.
467 # It is 100% compatible with the 5.10.0 Fatal module, right down
468 # to the scary 'XXXX' comment. ;)
472 my ($n, $isref, @out, @out1, $seen_semi) = -1;
473 while ($proto =~ /\S/) {
475 push(@out1,[$n,@out]) if $seen_semi;
476 push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
477 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
478 push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
479 $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
480 die "Internal error: Unknown prototype letters: \"$proto\"";
482 push(@out1,[$n+1,@out]);
486 # This is a backwards compatible version of _write_invocation. It's
487 # recommended you don't use it.
489 sub write_invocation {
490 my ($core, $call, $name, $void, @args) = @_;
492 return Fatal->_write_invocation(
493 $core, $call, $name, $void,
495 undef, # Sub, unused in legacy mode
496 undef, # Subref, unused in legacy mode.
501 # This version of _write_invocation is used internally. It's not
502 # recommended you call it from external code, as the interface WILL
503 # change in the future.
505 sub _write_invocation {
507 my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
509 if (@argvs == 1) { # No optional arguments
511 my @argv = @{$argvs[0]};
514 return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
518 my (@out, @argv, $n);
520 @argv = @{shift @argvs};
523 push @out, "${else}if (\@_ == $n) {\n";
526 push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
530 die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
533 return join '', @out;
538 # This is a slim interface to ensure backward compatibility with
539 # anyone doing very foolish things with old versions of Fatal.
542 my ($core, $call, $name, $void, @argv) = @_;
544 return Fatal->_one_invocation(
545 $core, $call, $name, $void,
546 undef, # Sub. Unused in back-compat mode.
547 1, # Back-compat flag
548 undef, # Subref, unused in back-compat mode.
554 # This is the internal interface that generates code.
555 # NOTE: This interface WILL change in the future. Please do not
556 # call this subroutine directly.
558 # TODO: Whatever's calling this code has already looked up hints. Pass
559 # them in, rather than look them up a second time.
561 sub _one_invocation {
562 my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
565 # If someone is calling us directly (a child class perhaps?) then
566 # they could try to mix void without enabling backwards
567 # compatibility. We just don't support this at all, so we gripe
568 # about it rather than doing something unwise.
570 if ($void and not $back_compat) {
571 Carp::confess("Internal error: :void mode not supported with $class");
574 # @argv only contains the results of the in-built prototype
575 # function, and is therefore safe to interpolate in the
576 # code generators below.
578 # TODO - The following clobbers context, but that's what the
579 # old Fatal did. Do we care?
583 # Use Fatal qw(system) will never be supported. It generated
584 # a compile-time error with legacy Fatal, and there's no reason
585 # to support it when autodie does a better job.
587 if ($call eq 'CORE::system') {
589 croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
596 return qq/return (defined wantarray)?$call(@argv):
597 $call(@argv) || croak "Can't $name(\@_)/ .
598 ($core ? ': $!' : ', \$! is \"$!\"') . '"'
600 return qq{return $call(@argv) || croak "Can't $name(\@_)} .
601 ($core ? ': $!' : ', \$! is \"$!\"') . '"';
605 # The name of our original function is:
606 # $call if the function is CORE
607 # $sub if our function is non-CORE
609 # The reason for this is that $call is what we're actualling
610 # calling. For our core functions, this is always
611 # CORE::something. However for user-defined subs, we're about to
612 # replace whatever it is that we're calling; as such, we actually
613 # calling a subroutine ref.
615 my $human_sub_name = $core ? $call : $sub;
617 # Should we be testing to see if our result is defined, or
622 my $hints; # All user-sub hints, including list hints.
626 # Core hints are built into autodie.
628 $use_defined_or = exists ( $Use_defined_or{$call} );
633 # User sub hints are looked up using autodie::hints,
634 # since users may wish to add their own hints.
636 require autodie::hints;
638 $hints = autodie::hints->get_hints_for( $sref );
640 # We'll look up the sub's fullname. This means we
641 # get better reports of where it came from in our
642 # error messages, rather than what imported it.
644 $human_sub_name = autodie::hints->sub_fullname( $sref );
648 # Checks for special core subs.
650 if ($call eq 'CORE::system') {
652 # Leverage IPC::System::Simple if we're making an autodying
657 # We need to stash $@ into $E, rather than using
658 # local $@ for the whole sub. If we don't then
659 # any exceptions from internal errors in autodie/Fatal
660 # will mysteriously disappear before propogating
672 \$retval = IPC::System::Simple::system(@argv);
680 # TODO - This can't be overridden in child
683 die autodie::exception::system->new(
684 function => q{CORE::system}, args => [ @argv ],
685 message => "\$E", errno => \$!,
696 # If we're going to throw an exception, here's the code to use.
699 function => q{$human_sub_name}, args => [ @argv ],
700 pragma => q{$class}, errno => \$!,
701 context => \$context, return => \$retval,
706 if ($call eq 'CORE::flock') {
708 # flock needs special treatment. When it fails with
709 # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
710 # means we couldn't get the lock right now.
712 require POSIX; # For POSIX::EWOULDBLOCK
714 local $@; # Don't blat anyone else's $@.
716 # Ensure that our vendor supports EWOULDBLOCK. If they
717 # don't (eg, Windows), then we use known values for its
718 # equivalent on other systems.
720 my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
721 || $_EWOULDBLOCK{$^O}
722 || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
724 require Fcntl; # For Fcntl::LOCK_NB
728 my \$context = wantarray() ? "list" : "scalar";
730 # Try to flock. If successful, return it immediately.
732 my \$retval = $call(@argv);
733 return \$retval if \$retval;
735 # If we failed, but we're using LOCK_NB and
736 # returned EWOULDBLOCK, it's not a real error.
738 if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) {
742 # Otherwise, we failed. Die noisily.
749 # AFAIK everything that can be given an unopned filehandle
750 # will fail if it tries to use it, so we don't really need
751 # the 'unopened' warning class here. Especially since they
752 # then report the wrong line number.
754 # Other warnings are disabled because they produce excessive
755 # complaints from smart-match hints under 5.10.1.
758 no warnings qw(unopened uninitialized numeric);
761 my \@results = $call(@argv);
762 my \$retval = \\\@results;
763 my \$context = "list";
767 if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
769 # NB: Subroutine hints are passed as a full list.
770 # This differs from the 5.10.0 smart-match behaviour,
771 # but means that context unaware subroutines can use
772 # the same hints in both list and scalar context.
775 if ( \$hints->{list}->(\@results) ) { $die };
778 elsif ( PERL510 and $hints ) {
780 if ( \@results ~~ \$hints->{list} ) { $die };
784 croak sprintf(ERROR_58_HINTS, 'list', $sub);
788 # An empty list, or a single undef is failure
789 if (! \@results or (\@results == 1 and ! defined \$results[0])) {
795 # Tidy up the end of our wantarray call.
803 # Otherwise, we're in scalar context.
804 # We're never in a void context, since we have to look
808 my \$retval = $call(@argv);
809 my \$context = "scalar";
812 if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
814 # We always call code refs directly, since that always
815 # works in 5.8.x, and always works in 5.10.1
818 if ( \$hints->{scalar}->(\$retval) ) { $die };
823 elsif (PERL510 and $hints) {
826 if ( \$retval ~~ \$hints->{scalar} ) { $die };
832 croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
836 ( $use_defined_or ? qq{
838 $die if not defined \$retval;
844 return \$retval || $die;
850 # This returns the old copy of the sub, so we can
851 # put it back at end of scope.
853 # TODO : Check to make sure prototypes are restored correctly.
855 # TODO: Taking a huge list of arguments is awful. Rewriting to
856 # take a hash would be lovely.
858 # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
861 my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
862 my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
865 $sub = "${pkg}::$sub" unless $sub =~ /::/;
867 # Figure if we're using lexical or package semantics and
868 # twiddle the appropriate bits.
871 $Package_Fatal{$sub} = 1;
874 # TODO - We *should* be able to do skipping, since we know when
875 # we've lexicalised / unlexicalised a subroutine.
878 $name =~ s/.*::// or $name =~ s/^&//;
880 warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
881 croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
883 if (defined(&$sub)) { # user subroutine
885 # NOTE: Previously we would localise $@ at this point, so
886 # the following calls to eval {} wouldn't interfere with anything
887 # that's already in $@. Unfortunately, it would also stop
888 # any of our croaks from triggering(!), which is even worse.
890 # This could be something that we've fatalised that
893 if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
895 # Something we previously made Fatal that was core.
896 # This is safe to replace with an autodying to core
900 $call = "CORE::$name";
901 $proto = prototype $call;
903 # We return our $sref from this subroutine later
904 # on, indicating this subroutine should be placed
905 # back when we're finished.
911 # If this is something we've already fatalised or played with,
912 # then look-up the name of the original sub for the rest of
915 $sub = $Is_fatalised_sub{\&$sub} || $sub;
917 # A regular user sub, or a user sub wrapping a
921 $proto = prototype $sref;
923 require autodie::hints;
925 $hints = autodie::hints->get_hints_for( $sref );
927 # If we've insisted on hints, but don't have them, then
930 if ($insist and not $hints) {
931 croak(sprintf(ERROR_NOHINTS, $name));
934 # Otherwise, use the default hints if we don't have
937 $hints ||= autodie::hints::DEFAULT_HINTS();
941 } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
942 # Stray user subroutine
943 croak(sprintf(ERROR_NOTSUB,$sub));
945 } elsif ($name eq 'system') {
947 # If we're fatalising system, then we need to load
950 # The business with $E is to avoid clobbering our caller's
951 # $@, and to avoid $@ being localised when we croak.
959 require IPC::System::Simple; # Only load it if we need it.
960 require autodie::exception::system;
965 if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
967 # Make sure we're using a recent version of ISS that actually
968 # support fatalised system.
969 if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
971 ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
972 $IPC::System::Simple::VERSION
976 $call = 'CORE::system';
980 } elsif ($name eq 'exec') {
981 # Exec doesn't have a prototype. We don't care. This
982 # breaks the exotic form with lexical scope, and gives
983 # the regular form a "do or die" beaviour as expected.
985 $call = 'CORE::exec';
989 } else { # CORE subroutine
993 $proto = eval { prototype "CORE::$name" };
996 croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
997 croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
999 $call = "CORE::$name";
1002 if (defined $proto) {
1003 $real_proto = " ($proto)";
1009 my $true_name = $core ? $call : $sub;
1011 # TODO: This caching works, but I don't like using $void and
1012 # $lexical as keys. In particular, I suspect our code may end up
1013 # wrapping already wrapped code when autodie and Fatal are used
1016 # NB: We must use '$sub' (the name plus package) and not
1017 # just '$name' (the short name) here. Failing to do so
1018 # results code that's in the wrong package, and hence has
1019 # access to the wrong package filehandles.
1021 if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
1022 $class->_install_subs($pkg, { $name => $subref });
1028 local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
1031 # Don't have perl whine if exec fails, since we'll be handling
1032 # the exception now.
1033 $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
1035 my @protos = fill_protos($proto);
1036 $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
1038 warn $code if $Debug;
1040 # I thought that changing package was a monumental waste of
1041 # time for CORE subs, since they'll always be the same. However
1042 # that's not the case, since they may refer to package-based
1043 # filehandles (eg, with open).
1045 # There is potential to more aggressively cache core subs
1046 # that we know will never want to interact with package variables
1050 no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
1056 $code = eval("package $pkg; use Carp; $code"); ## no critic
1061 croak("Internal error in autodie/Fatal processing $true_name: $E");
1066 # Now we need to wrap our fatalised sub inside an itty bitty
1067 # closure, which can detect if we've leaked into another file.
1068 # Luckily, we only need to do this for lexical (autodie)
1069 # subs. Fatal subs can leak all they want, it's considered
1070 # a "feature" (or at least backwards compatible).
1072 # TODO: Cache our leak guards!
1074 # TODO: This is pretty hairy code. A lot more tests would
1075 # be really nice for this.
1086 # If we're inside a string eval, we can end up with a
1087 # whacky filename. The following code allows autodie
1088 # to propagate correctly into string evals.
1090 my \$caller_level = 0;
1094 while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
1096 # If our filename is actually an eval, and we
1097 # reach it, then go to our autodying code immediatately.
1099 goto &\$code if (\$caller eq \$filename);
1103 # We're now out of the eval stack.
1105 # If we're called from the correct file, then use the
1107 goto &\$code if ((caller \$caller_level)[1] eq \$filename);
1109 # Oh bother, we've leaked into another file. Call the
1110 # original code. Note that \$sref may actually be a
1111 # reference to a Fatalised version of a core built-in.
1112 # That's okay, because Fatal *always* leaks between files.
1114 goto &\$sref if \$sref;
1118 # If we're here, it must have been a core subroutine called.
1119 # Warning: The following code may disturb some viewers.
1121 # TODO: It should be possible to combine this with
1122 # write_invocation().
1124 foreach my $proto (@protos) {
1125 local $" = ", "; # So @args is formatted correctly.
1126 my ($count, @args) = @$proto;
1128 if (\@_ == $count) {
1129 return $call(@args);
1134 $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >;
1136 # warn "$leak_guard\n";
1142 $leak_guard = eval $leak_guard; ## no critic
1147 die "Internal error in $class: Leak-guard installation failure: $E" if $E;
1150 my $installed_sub = $leak_guard || $code;
1152 $class->_install_subs($pkg, { $name => $installed_sub });
1154 $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
1156 # Cache that we've now overriddent this sub. If we get called
1157 # again, we may need to find that find subroutine again (eg, for hints).
1159 $Is_fatalised_sub{$installed_sub} = $sref;
1165 # This subroutine exists primarily so that child classes can override
1166 # it to point to their own exception class. Doing this is significantly
1167 # less complex than overriding throw()
1169 sub exception_class { return "autodie::exception" };
1172 my %exception_class_for;
1176 my ($class, @args) = @_;
1178 # Find our exception class if we need it.
1179 my $exception_class =
1180 $exception_class_for{$class} ||= $class->exception_class;
1182 if (not $class_loaded{$exception_class}) {
1183 if ($exception_class =~ /[^\w:']/) {
1184 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.";
1187 # Alas, Perl does turn barewords into modules unless they're
1188 # actually barewords. As such, we're left doing a string eval
1189 # to make sure we load our file correctly.
1194 local $@; # We can't clobber $@, it's wrong!
1195 eval "require $exception_class"; ## no critic
1196 $E = $@; # Save $E despite ending our local.
1199 # We need quotes around $@ to make sure it's stringified
1200 # while still in scope. Without them, we run the risk of
1201 # $@ having been cleared by us exiting the local() block.
1203 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;
1205 $class_loaded{$exception_class}++;
1209 return $exception_class->new(@args);
1213 # For some reason, dying while replacing our subs doesn't
1214 # kill our calling program. It simply stops the loading of
1215 # autodie and keeps going with everything else. The _autocroak
1216 # sub allows us to die with a vegence. It should *only* ever be
1217 # used for serious internal errors, since the results of it can't
1221 warn Carp::longmess(@_);
1225 package autodie::Scope::Guard;
1227 # This code schedules the cleanup of subroutines at the end of
1228 # scope. It's directly inspired by chocolateboy's excellent
1229 # Scope::Guard module.
1232 my ($class, $handler) = @_;
1234 return bless $handler, $class;
1249 Fatal - Replace functions with equivalents which succeed or die
1253 use Fatal qw(open close);
1255 open(my $fh, "<", $filename); # No need to check errors!
1257 use File::Copy qw(move);
1260 move($file1, $file2); # No need to check errors!
1262 sub juggle { . . . }
1263 Fatal->import('juggle');
1265 =head1 BEST PRACTICE
1267 B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
1268 L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
1269 throws real exception objects, and provides much nicer error messages.
1271 The use of C<:void> with Fatal is discouraged.
1275 C<Fatal> provides a way to conveniently replace
1276 functions which normally return a false value when they fail with
1277 equivalents which raise exceptions if they are not successful. This
1278 lets you use these functions without having to test their return
1279 values explicitly on each call. Exceptions can be caught using
1280 C<eval{}>. See L<perlfunc> and L<perlvar> for details.
1282 The do-or-die equivalents are set up simply by calling Fatal's
1283 C<import> routine, passing it the names of the functions to be
1284 replaced. You may wrap both user-defined functions and overridable
1285 CORE operators (except C<exec>, C<system>, C<print>, or any other
1286 built-in that cannot be expressed via prototypes) in this way.
1288 If the symbol C<:void> appears in the import list, then functions
1289 named later in that import list raise an exception only when
1290 these are called in void context--that is, when their return
1291 values are ignored. For example
1293 use Fatal qw/:void open close/;
1295 # properly checked, so no exception raised on error
1296 if (not open(my $fh, '<', '/bogotic') {
1297 warn "Can't open /bogotic: $!";
1300 # not checked, so error raises an exception
1303 The use of C<:void> is discouraged, as it can result in exceptions
1304 not being thrown if you I<accidentally> call a method without
1305 void context. Use L<autodie> instead if you need to be able to
1306 disable autodying/Fatal behaviour for a small block of code.
1312 =item Bad subroutine name for Fatal: %s
1314 You've called C<Fatal> with an argument that doesn't look like
1315 a subroutine name, nor a switch that this version of Fatal
1318 =item %s is not a Perl subroutine
1320 You've asked C<Fatal> to try and replace a subroutine which does not
1321 exist, or has not yet been defined.
1323 =item %s is neither a builtin, nor a Perl subroutine
1325 You've asked C<Fatal> to replace a subroutine, but it's not a Perl
1326 built-in, and C<Fatal> couldn't find it as a regular subroutine.
1327 It either doesn't exist or has not yet been defined.
1329 =item Cannot make the non-overridable %s fatal
1331 You've tried to use C<Fatal> on a Perl built-in that can't be
1332 overridden, such as C<print> or C<system>, which means that
1333 C<Fatal> can't help you, although some other modules might.
1334 See the L</"SEE ALSO"> section of this documentation.
1336 =item Internal error: %s
1338 You've found a bug in C<Fatal>. Please report it using
1339 the C<perlbug> command.
1345 C<Fatal> clobbers the context in which a function is called and always
1346 makes it a scalar context, except when the C<:void> tag is used.
1347 This problem does not exist in L<autodie>.
1349 "Used only once" warnings can be generated when C<autodie> or C<Fatal>
1350 is used with package filehandles (eg, C<FILE>). It's strongly recommended
1351 you use scalar filehandles instead.
1355 Original module by Lionel Cons (CERN).
1357 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
1359 L<autodie> support, bugfixes, extended diagnostics, C<system>
1360 support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
1364 This module is free software, you may distribute it under the
1365 same terms as Perl itself.
1369 L<autodie> for a nicer way to use lexical Fatal.
1371 L<IPC::System::Simple> for a similar idea for calls to C<system()>