git-flavoured autodie 1.997 patch
[p5sagit/p5-mst-13.2.git] / lib / Fatal.pm
1 package Fatal;
2
3 use 5.008;  # 5.8.x needed for autodie
4 use Carp;
5 use strict;
6 use warnings;
7
8 use constant LEXICAL_TAG => q{:lexical};
9 use constant VOID_TAG    => q{:void};
10
11 use constant ERROR_NOARGS    => 'Cannot use lexical %s with no arguments';
12 use constant ERROR_VOID_LEX  => VOID_TAG.' cannot be used with lexical scope';
13 use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
14 use constant ERROR_NO_LEX    => "no %s can only start with ".LEXICAL_TAG;
15 use constant ERROR_BADNAME   => "Bad subroutine name for %s: %s";
16 use constant ERROR_NOTSUB    => "%s is not a Perl subroutine";
17 use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
18 use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
19
20 use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
21
22 use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system().  We only have version %f";
23
24 use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
25
26 use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
27
28 # Older versions of IPC::System::Simple don't support all the
29 # features we need.
30
31 use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
32
33 # All the Fatal/autodie modules share the same version number.
34 our $VERSION = '1.997';
35
36 our $Debug ||= 0;
37
38 # EWOULDBLOCK values for systems that don't supply their own.
39 # Even though this is defined with our, that's to help our
40 # test code.  Please don't rely upon this variable existing in
41 # the future.
42
43 our %_EWOULDBLOCK = (
44     MSWin32 => 33,
45 );
46
47 # We have some tags that can be passed in for use with import.
48 # These are all assumed to be CORE::
49
50 my %TAGS = (
51     ':io'      => [qw(:dbm :file :filesys :ipc :socket
52                        read seek sysread syswrite sysseek )],
53     ':dbm'     => [qw(dbmopen dbmclose)],
54     ':file'    => [qw(open close flock sysopen fcntl fileno binmode
55                      ioctl truncate)],
56     ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
57                       symlink rmdir readlink umask)],
58     ':ipc'     => [qw(:msg :semaphore :shm pipe)],
59     ':msg'     => [qw(msgctl msgget msgrcv msgsnd)],
60     ':threads' => [qw(fork)],
61     ':semaphore'=>[qw(semctl semget semop)],
62     ':shm'     => [qw(shmctl shmget shmread)],
63     ':system'  => [qw(system exec)],
64
65     # Can we use qw(getpeername getsockname)? What do they do on failure?
66     # XXX - Can socket return false?
67     ':socket'  => [qw(accept bind connect getsockopt listen recv send
68                    setsockopt shutdown socketpair)],
69
70     # Our defaults don't include system(), because it depends upon
71     # an optional module, and it breaks the exotic form.
72     #
73     # This *may* change in the future.  I'd love IPC::System::Simple
74     # to be a dependency rather than a recommendation, and hence for
75     # system() to be autodying by default.
76
77     ':default' => [qw(:io :threads)],
78
79     # Version specific tags.  These allow someone to specify
80     # use autodie qw(:1.994) and know exactly what they'll get.
81
82     ':1.994' => [qw(:default)],
83     ':1.995' => [qw(:default)],
84     ':1.996' => [qw(:default)],
85     ':1.997' => [qw(:default)],
86
87 );
88
89 $TAGS{':all'}  = [ keys %TAGS ];
90
91 # This hash contains subroutines for which we should
92 # subroutine() // die() rather than subroutine() || die()
93
94 my %Use_defined_or;
95
96 # CORE::open returns undef on failure.  It can legitimately return
97 # 0 on success, eg: open(my $fh, '-|') || exec(...);
98
99 @Use_defined_or{qw(
100     CORE::fork
101     CORE::recv
102     CORE::send
103     CORE::open
104     CORE::fileno
105     CORE::read
106     CORE::readlink
107     CORE::sysread
108     CORE::syswrite
109     CORE::sysseek
110     CORE::umask
111 )} = ();
112
113 # Cached_fatalised_sub caches the various versions of our
114 # fatalised subs as they're produced.  This means we don't
115 # have to build our own replacement of CORE::open and friends
116 # for every single package that wants to use them.
117
118 my %Cached_fatalised_sub = ();
119
120 # Every time we're called with package scope, we record the subroutine
121 # (including package or CORE::) in %Package_Fatal.  This allows us
122 # to detect illegal combinations of autodie and Fatal, and makes sure
123 # we don't accidently make a Fatal function autodying (which isn't
124 # very useful).
125
126 my %Package_Fatal = ();
127
128 # The first time we're called with a user-sub, we cache it here.
129 # In the case of a "no autodie ..." we put back the cached copy.
130
131 my %Original_user_sub = ();
132
133 # We use our package in a few hash-keys.  Having it in a scalar is
134 # convenient.  The "guard $PACKAGE" string is used as a key when
135 # setting up lexical guards.
136
137 my $PACKAGE       = __PACKAGE__;
138 my $PACKAGE_GUARD = "guard $PACKAGE";
139 my $NO_PACKAGE    = "no $PACKAGE";      # Used to detect 'no autodie'
140
141 # Here's where all the magic happens when someone write 'use Fatal'
142 # or 'use autodie'.
143
144 sub import {
145     my $class   = shift(@_);
146     my $void    = 0;
147     my $lexical = 0;
148
149     my ($pkg, $filename) = caller();
150
151     @_ or return;   # 'use Fatal' is a no-op.
152
153     # If we see the :lexical flag, then _all_ arguments are
154     # changed lexically
155
156     if ($_[0] eq LEXICAL_TAG) {
157         $lexical = 1;
158         shift @_;
159
160         # If we see no arguments and :lexical, we assume they
161         # wanted ':default'.
162
163         if (@_ == 0) {
164             push(@_, ':default');
165         }
166
167         # Don't allow :lexical with :void, it's needlessly confusing.
168         if ( grep { $_ eq VOID_TAG } @_ ) {
169             croak(ERROR_VOID_LEX);
170         }
171     }
172
173     if ( grep { $_ eq LEXICAL_TAG } @_ ) {
174         # If we see the lexical tag as the non-first argument, complain.
175         croak(ERROR_LEX_FIRST);
176     }
177
178     my @fatalise_these =  @_;
179
180     # Thiese subs will get unloaded at the end of lexical scope.
181     my %unload_later;
182
183     # This hash helps us track if we've alredy done work.
184     my %done_this;
185
186     # NB: we're using while/shift rather than foreach, since
187     # we'll be modifying the array as we walk through it.
188
189     while (my $func = shift @fatalise_these) {
190
191         if ($func eq VOID_TAG) {
192
193             # When we see :void, set the void flag.
194             $void = 1;
195
196         } elsif (exists $TAGS{$func}) {
197
198             # When it's a tag, expand it.
199             push(@fatalise_these, @{ $TAGS{$func} });
200
201         } else {
202
203             # Otherwise, fatalise it.
204
205             # If we've already made something fatal this call,
206             # then don't do it twice.
207
208             next if $done_this{$func};
209
210             # We're going to make a subroutine fatalistic.
211             # However if we're being invoked with 'use Fatal qw(x)'
212             # and we've already been called with 'no autodie qw(x)'
213             # in the same scope, we consider this to be an error.
214             # Mixing Fatal and autodie effects was considered to be
215             # needlessly confusing on p5p.
216
217             my $sub = $func;
218             $sub = "${pkg}::$sub" unless $sub =~ /::/;
219
220             # If we're being called as Fatal, and we've previously
221             # had a 'no X' in scope for the subroutine, then complain
222             # bitterly.
223
224             if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
225                  croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
226             }
227
228             # We're not being used in a confusing way, so make
229             # the sub fatal.  Note that _make_fatal returns the
230             # old (original) version of the sub, or undef for
231             # built-ins.
232
233             my $sub_ref = $class->_make_fatal(
234                 $func, $pkg, $void, $lexical, $filename
235             );
236
237             $done_this{$func}++;
238
239             $Original_user_sub{$sub} ||= $sub_ref;
240
241             # If we're making lexical changes, we need to arrange
242             # for them to be cleaned at the end of our scope, so
243             # record them here.
244
245             $unload_later{$func} = $sub_ref if $lexical;
246         }
247     }
248
249     if ($lexical) {
250
251         # Dark magic to have autodie work under 5.8
252         # Copied from namespace::clean, that copied it from
253         # autobox, that found it on an ancient scroll written
254         # in blood.
255
256         # This magic bit causes %^H to be lexically scoped.
257
258         $^H |= 0x020000;
259
260         # Our package guard gets invoked when we leave our lexical
261         # scope.
262
263         push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
264             $class->_install_subs($pkg, \%unload_later);
265         }));
266
267     }
268
269     return;
270
271 }
272
273 # The code here is originally lifted from namespace::clean,
274 # by Robert "phaylon" Sedlacek.
275 #
276 # It's been redesigned after feedback from ikegami on perlmonks.
277 # See http://perlmonks.org/?node_id=693338 .  Ikegami rocks.
278 #
279 # Given a package, and hash of (subname => subref) pairs,
280 # we install the given subroutines into the package.  If
281 # a subref is undef, the subroutine is removed.  Otherwise
282 # it replaces any existing subs which were already there.
283
284 sub _install_subs {
285     my ($class, $pkg, $subs_to_reinstate) = @_;
286
287     my $pkg_sym = "${pkg}::";
288
289     while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
290
291         my $full_path = $pkg_sym.$sub_name;
292
293         # Copy symbols across to temp area.
294
295         no strict 'refs';   ## no critic
296
297         local *__tmp = *{ $full_path };
298
299         # Nuke the old glob.
300         { no strict; delete $pkg_sym->{$sub_name}; }    ## no critic
301
302         # Copy innocent bystanders back.
303
304         foreach my $slot (qw( SCALAR ARRAY HASH IO FORMAT ) ) {
305             next unless defined *__tmp{ $slot };
306             *{ $full_path } = *__tmp{ $slot };
307         }
308
309         # Put back the old sub (if there was one).
310
311         if ($sub_ref) {
312
313             no strict;  ## no critic
314             *{ $pkg_sym . $sub_name } = $sub_ref;
315         }
316     }
317
318     return;
319 }
320
321 sub unimport {
322     my $class = shift;
323
324     # Calling "no Fatal" must start with ":lexical"
325     if ($_[0] ne LEXICAL_TAG) {
326         croak(sprintf(ERROR_NO_LEX,$class));
327     }
328
329     shift @_;   # Remove :lexical
330
331     my $pkg = (caller)[0];
332
333     # If we've been called with arguments, then the developer
334     # has explicitly stated 'no autodie qw(blah)',
335     # in which case, we disable Fatalistic behaviour for 'blah'.
336
337     my @unimport_these = @_ ? @_ : ':all';
338
339     while (my $symbol = shift @unimport_these) {
340
341         if ($symbol =~ /^:/) {
342
343             # Looks like a tag!  Expand it!
344             push(@unimport_these, @{ $TAGS{$symbol} });
345
346             next;
347         }
348
349         my $sub = $symbol;
350         $sub = "${pkg}::$sub" unless $sub =~ /::/;
351
352         # If 'blah' was already enabled with Fatal (which has package
353         # scope) then, this is considered an error.
354
355         if (exists $Package_Fatal{$sub}) {
356             croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
357         }
358
359         # Record 'no autodie qw($sub)' as being in effect.
360         # This is to catch conflicting semantics elsewhere
361         # (eg, mixing Fatal with no autodie)
362
363         $^H{$NO_PACKAGE}{$sub} = 1;
364
365         if (my $original_sub = $Original_user_sub{$sub}) {
366             # Hey, we've got an original one of these, put it back.
367             $class->_install_subs($pkg, { $symbol => $original_sub });
368             next;
369         }
370
371         # We don't have an original copy of the sub, on the assumption
372         # it's core (or doesn't exist), we'll just nuke it.
373
374         $class->_install_subs($pkg,{ $symbol => undef });
375
376     }
377
378     return;
379
380 }
381
382 # TODO - This is rather terribly inefficient right now.
383
384 # NB: Perl::Critic's dump-autodie-tag-contents depends upon this
385 # continuing to work.
386
387 {
388     my %tag_cache;
389
390     sub _expand_tag {
391         my ($class, $tag) = @_;
392
393         if (my $cached = $tag_cache{$tag}) {
394             return $cached;
395         }
396
397         if (not exists $TAGS{$tag}) {
398             croak "Invalid exception class $tag";
399         }
400
401         my @to_process = @{$TAGS{$tag}};
402
403         my @taglist = ();
404
405         while (my $item = shift @to_process) {
406             if ($item =~ /^:/) {
407                 push(@to_process, @{$TAGS{$item}} );
408             } else {
409                 push(@taglist, "CORE::$item");
410             }
411         }
412
413         $tag_cache{$tag} = \@taglist;
414
415         return \@taglist;
416
417     }
418
419 }
420
421 # This code is from the original Fatal.  It scares me.
422
423 sub fill_protos {
424     my $proto = shift;
425     my ($n, $isref, @out, @out1, $seen_semi) = -1;
426     while ($proto =~ /\S/) {
427         $n++;
428         push(@out1,[$n,@out]) if $seen_semi;
429         push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
430         push(@out, "\$_[$n]"),        next if $proto =~ s/^\s*([_*\$&])//;
431         push(@out, "\@_[$n..\$#_]"),  last if $proto =~ s/^\s*(;\s*)?\@//;
432         $seen_semi = 1, $n--,         next if $proto =~ s/^\s*;//; # XXXX ????
433         die "Internal error: Unknown prototype letters: \"$proto\"";
434     }
435     push(@out1,[$n+1,@out]);
436     return @out1;
437 }
438
439 # This generates the code that will become our fatalised subroutine.
440
441 sub write_invocation {
442     my ($class, $core, $call, $name, $void, $lexical, $sub, @argvs) = @_;
443
444     if (@argvs == 1) {        # No optional arguments
445
446         my @argv = @{$argvs[0]};
447         shift @argv;
448
449         return $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv);
450
451     } else {
452         my $else = "\t";
453         my (@out, @argv, $n);
454         while (@argvs) {
455             @argv = @{shift @argvs};
456             $n = shift @argv;
457
458             push @out, "${else}if (\@_ == $n) {\n";
459             $else = "\t} els";
460
461         push @out, $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv);
462         }
463         push @out, q[
464             }
465             die "Internal error: $name(\@_): Do not expect to get ", scalar \@_, " arguments";
466     ];
467
468         return join '', @out;
469     }
470 }
471
472 sub one_invocation {
473     my ($class, $core, $call, $name, $void, $sub, $back_compat, @argv) = @_;
474
475     # If someone is calling us directly (a child class perhaps?) then
476     # they could try to mix void without enabling backwards
477     # compatibility.  We just don't support this at all, so we gripe
478     # about it rather than doing something unwise.
479
480     if ($void and not $back_compat) {
481         Carp::confess("Internal error: :void mode not supported with $class");
482     }
483
484     # @argv only contains the results of the in-built prototype
485     # function, and is therefore safe to interpolate in the
486     # code generators below.
487
488     # TODO - The following clobbers context, but that's what the
489     #        old Fatal did.  Do we care?
490
491     if ($back_compat) {
492
493         # TODO - Use Fatal qw(system) is not yet supported.  It should be!
494
495         if ($call eq 'CORE::system') {
496             return q{
497                 croak("UNIMPLEMENTED: use Fatal qw(system) not yet supported.");
498             };
499         }
500
501         local $" = ', ';
502
503         if ($void) {
504             return qq/return (defined wantarray)?$call(@argv):
505                    $call(@argv) || croak "Can't $name(\@_)/ .
506                    ($core ? ': $!' : ', \$! is \"$!\"') . '"'
507         } else {
508             return qq{return $call(@argv) || croak "Can't $name(\@_)} .
509                    ($core ? ': $!' : ', \$! is \"$!\"') . '"';
510         }
511     }
512
513     # The name of our original function is:
514     #   $call if the function is CORE
515     #   $sub if our function is non-CORE
516
517     # The reason for this is that $call is what we're actualling
518     # calling.  For our core functions, this is always
519     # CORE::something.  However for user-defined subs, we're about to
520     # replace whatever it is that we're calling; as such, we actually
521     # calling a subroutine ref.
522
523     # Unfortunately, none of this tells us the *ultimate* name.
524     # For example, if I export 'copy' from File::Copy, I'd like my
525     # ultimate name to be File::Copy::copy.
526     #
527     # TODO - Is there any way to find the ultimate name of a sub, as
528     # described above?
529
530     my $true_sub_name = $core ? $call : $sub;
531
532     if ($call eq 'CORE::system') {
533
534         # Leverage IPC::System::Simple if we're making an autodying
535         # system.
536
537         local $" = ", ";
538
539         # We need to stash $@ into $E, rather than using
540         # local $@ for the whole sub.  If we don't then
541         # any exceptions from internal errors in autodie/Fatal
542         # will mysteriously disappear before propogating
543         # upwards.
544
545         return qq{
546             my \$retval;
547             my \$E;
548
549
550             {
551                 local \$@;
552
553                 eval {
554                     \$retval = IPC::System::Simple::system(@argv);
555                 };
556
557                 \$E = \$@;
558             }
559
560             if (\$E) {
561
562                 # XXX - TODO - This can't be overridden in child
563                 # classes!
564
565                 die autodie::exception::system->new(
566                     function => q{CORE::system}, args => [ @argv ],
567                     message => "\$E", errno => \$!,
568                 );
569             }
570
571             return \$retval;
572         };
573
574     }
575
576     # Should we be testing to see if our result is defined, or
577     # just true?
578     my $use_defined_or = exists ( $Use_defined_or{$call} );
579
580     local $" = ', ';
581
582     # If we're going to throw an exception, here's the code to use.
583     my $die = qq{
584         die $class->throw(
585             function => q{$true_sub_name}, args => [ @argv ],
586             pragma => q{$class}, errno => \$!,
587         )
588     };
589
590     if ($call eq 'CORE::flock') {
591
592         # flock needs special treatment.  When it fails with
593         # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
594         # means we couldn't get the lock right now.
595
596         require POSIX;      # For POSIX::EWOULDBLOCK
597
598         local $@;   # Don't blat anyone else's $@.
599
600         # Ensure that our vendor supports EWOULDBLOCK.  If they
601         # don't (eg, Windows), then we use known values for its
602         # equivalent on other systems.
603
604         my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
605                           || $_EWOULDBLOCK{$^O}
606                           || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
607
608         require Fcntl;      # For Fcntl::LOCK_NB
609
610         return qq{
611
612             # Try to flock.  If successful, return it immediately.
613
614             my \$retval = $call(@argv);
615             return \$retval if \$retval;
616
617             # If we failed, but we're using LOCK_NB and
618             # returned EWOULDBLOCK, it's not a real error.
619
620             if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) {
621                 return \$retval;
622             }
623
624             # Otherwise, we failed.  Die noisily.
625
626             $die;
627
628         };
629     }
630
631     # AFAIK everything that can be given an unopned filehandle
632     # will fail if it tries to use it, so we don't really need
633     # the 'unopened' warning class here.  Especially since they
634     # then report the wrong line number.
635
636     return qq{
637         no warnings qw(unopened);
638
639         if (wantarray) {
640             my \@results = $call(@argv);
641             # If we got back nothing, or we got back a single
642             # undef, we die.
643             if (! \@results or (\@results == 1 and ! defined \$results[0])) {
644                 $die;
645             };
646             return \@results;
647         }
648
649         # Otherwise, we're in scalar context.
650         # We're never in a void context, since we have to look
651         # at the result.
652
653         my \$result = $call(@argv);
654
655     } . ( $use_defined_or ? qq{
656
657         $die if not defined \$result;
658
659         return \$result;
660
661     } : qq{
662
663         return \$result || $die;
664
665     } ) ;
666
667 }
668
669 # This returns the old copy of the sub, so we can
670 # put it back at end of scope.
671
672 # TODO : Check to make sure prototypes are restored correctly.
673
674 # TODO: Taking a huge list of arguments is awful.  Rewriting to
675 #       take a hash would be lovely.
676
677 sub _make_fatal {
678     my($class, $sub, $pkg, $void, $lexical, $filename) = @_;
679     my($name, $code, $sref, $real_proto, $proto, $core, $call);
680     my $ini = $sub;
681
682     $sub = "${pkg}::$sub" unless $sub =~ /::/;
683
684     # Figure if we're using lexical or package semantics and
685     # twiddle the appropriate bits.
686
687     if (not $lexical) {
688         $Package_Fatal{$sub} = 1;
689     }
690
691     # TODO - We *should* be able to do skipping, since we know when
692     # we've lexicalised / unlexicalised a subroutine.
693
694     $name = $sub;
695     $name =~ s/.*::// or $name =~ s/^&//;
696
697     warn  "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
698     croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
699
700     if (defined(&$sub)) {   # user subroutine
701
702         # This could be something that we've fatalised that
703         # was in core.
704
705         local $@; # Don't clobber anyone else's $@
706
707         if ( $Package_Fatal{$sub} and eval { prototype "CORE::$name" } ) {
708
709             # Something we previously made Fatal that was core.
710             # This is safe to replace with an autodying to core
711             # version.
712
713             $core  = 1;
714             $call  = "CORE::$name";
715             $proto = prototype $call;
716
717             # We return our $sref from this subroutine later
718             # on, indicating this subroutine should be placed
719             # back when we're finished.
720
721             $sref = \&$sub;
722
723         } else {
724
725             # A regular user sub, or a user sub wrapping a
726             # core sub.
727
728             $sref = \&$sub;
729             $proto = prototype $sref;
730             $call = '&$sref';
731
732         }
733
734     } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
735         # Stray user subroutine
736         croak(sprintf(ERROR_NOTSUB,$sub));
737
738     } elsif ($name eq 'system') {
739
740         # If we're fatalising system, then we need to load
741         # helper code.
742
743         eval {
744             require IPC::System::Simple; # Only load it if we need it.
745             require autodie::exception::system;
746         };
747
748         if ($@) { croak ERROR_NO_IPC_SYS_SIMPLE; }
749
750             # Make sure we're using a recent version of ISS that actually
751             # support fatalised system.
752             if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
753                 croak sprintf(
754                 ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
755                 $IPC::System::Simple::VERSION
756                 );
757             }
758
759         $call = 'CORE::system';
760         $name = 'system';
761
762     } elsif ($name eq 'exec') {
763         # Exec doesn't have a prototype.  We don't care.  This
764         # breaks the exotic form with lexical scope, and gives
765         # the regular form a "do or die" beaviour as expected.
766
767         $call = 'CORE::exec';
768         $name = 'exec';
769         $core = 1;
770
771     } else {            # CORE subroutine
772         $proto = eval { prototype "CORE::$name" };
773         croak(sprintf(ERROR_NOT_BUILT,$name)) if $@;
774         croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
775         $core = 1;
776         $call = "CORE::$name";
777     }
778
779     if (defined $proto) {
780         $real_proto = " ($proto)";
781     } else {
782         $real_proto = '';
783         $proto = '@';
784     }
785
786     my $true_name = $core ? $call : $sub;
787
788     # TODO: This caching works, but I don't like using $void and
789     # $lexical as keys.  In particular, I suspect our code may end up
790     # wrapping already wrapped code when autodie and Fatal are used
791     # together.
792
793     # NB: We must use '$sub' (the name plus package) and not
794     # just '$name' (the short name) here.  Failing to do so
795     # results code that's in the wrong package, and hence has
796     # access to the wrong package filehandles.
797
798     if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
799         $class->_install_subs($pkg, { $name => $subref });
800         return $sref;
801     }
802
803     $code = qq[
804         sub$real_proto {
805             local(\$", \$!) = (', ', 0);    # TODO - Why do we do this?
806     ];
807
808     # Don't have perl whine if exec fails, since we'll be handling
809     # the exception now.
810     $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
811
812     my @protos = fill_protos($proto);
813     $code .= $class->write_invocation($core, $call, $name, $void, $lexical, $sub, @protos);
814     $code .= "}\n";
815     warn $code if $Debug;
816
817     # I thought that changing package was a monumental waste of
818     # time for CORE subs, since they'll always be the same.  However
819     # that's not the case, since they may refer to package-based
820     # filehandles (eg, with open).
821     #
822     # There is potential to more aggressively cache core subs
823     # that we know will never want to interact with package variables
824     # and filehandles.
825
826     {
827         local $@;
828         no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
829         $code = eval("package $pkg; use Carp; $code");  ## no critic
830         if (not $code) {
831
832             # For some reason, using a die, croak, or confess in here
833             # results in the error being completely surpressed. As such,
834             # we need to do our own reporting.
835             #
836             # TODO: Fix the above.
837
838             _autocroak("Internal error in autodie/Fatal processing $true_name: $@");
839
840         }
841     }
842
843     # Now we need to wrap our fatalised sub inside an itty bitty
844     # closure, which can detect if we've leaked into another file.
845     # Luckily, we only need to do this for lexical (autodie)
846     # subs.  Fatal subs can leak all they want, it's considered
847     # a "feature" (or at least backwards compatible).
848
849     # TODO: Cache our leak guards!
850
851     # TODO: This is pretty hairy code.  A lot more tests would
852     # be really nice for this.
853
854     my $leak_guard;
855
856     if ($lexical) {
857
858         $leak_guard = qq<
859             package $pkg;
860
861             sub$real_proto {
862
863                 # If we're called from the correct file, then use the
864                 # autodying code.
865                 goto &\$code if ((caller)[1] eq \$filename);
866
867                 # Oh bother, we've leaked into another file.  Call the
868                 # original code.  Note that \$sref may actually be a
869                 # reference to a Fatalised version of a core built-in.
870                 # That's okay, because Fatal *always* leaks between files.
871
872                 goto &\$sref if \$sref;
873         >;
874
875
876         # If we're here, it must have been a core subroutine called.
877         # Warning: The following code may disturb some viewers.
878
879         # TODO: It should be possible to combine this with
880         # write_invocation().
881
882         foreach my $proto (@protos) {
883             local $" = ", ";    # So @args is formatted correctly.
884             my ($count, @args) = @$proto;
885             $leak_guard .= qq<
886                 if (\@_ == $count) {
887                     return $call(@args);
888                 }
889             >;
890         }
891
892         $leak_guard .= qq< croak "Internal error in Fatal/autodie.  Leak-guard failure"; } >;
893
894         # warn "$leak_guard\n";
895
896         local $@;
897
898         $leak_guard = eval $leak_guard;  ## no critic
899
900         die "Internal error in $class: Leak-guard installation failure: $@" if $@;
901     }
902
903     $class->_install_subs($pkg, { $name => $leak_guard || $code });
904
905     $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $leak_guard || $code;
906
907     return $sref;
908
909 }
910
911 # This subroutine exists primarily so that child classes can override
912 # it to point to their own exception class.  Doing this is significantly
913 # less complex than overriding throw()
914
915 sub exception_class { return "autodie::exception" };
916
917 {
918     my %exception_class_for;
919     my %class_loaded;
920
921     sub throw {
922         my ($class, @args) = @_;
923
924         # Find our exception class if we need it.
925         my $exception_class =
926              $exception_class_for{$class} ||= $class->exception_class;
927
928         if (not $class_loaded{$exception_class}) {
929             if ($exception_class =~ /[^\w:']/) {
930                 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.";
931             }
932
933             # Alas, Perl does turn barewords into modules unless they're
934             # actually barewords.  As such, we're left doing a string eval
935             # to make sure we load our file correctly.
936
937             my $E;
938
939             {
940                 local $@;   # We can't clobber $@, it's wrong!
941                 eval "require $exception_class"; ## no critic
942                 $E = $@;    # Save $E despite ending our local.
943             }
944
945             # We need quotes around $@ to make sure it's stringified
946             # while still in scope.  Without them, we run the risk of
947             # $@ having been cleared by us exiting the local() block.
948
949             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;
950
951             $class_loaded{$exception_class}++;
952
953         }
954
955         return $exception_class->new(@args);
956     }
957 }
958
959 # For some reason, dying while replacing our subs doesn't
960 # kill our calling program.  It simply stops the loading of
961 # autodie and keeps going with everything else.  The _autocroak
962 # sub allows us to die with a vegence.  It should *only* ever be
963 # used for serious internal errors, since the results of it can't
964 # be captured.
965
966 sub _autocroak {
967     warn Carp::longmess(@_);
968     exit(255);  # Ugh!
969 }
970
971 package autodie::Scope::Guard;
972
973 # This code schedules the cleanup of subroutines at the end of
974 # scope.  It's directly inspired by chocolateboy's excellent
975 # Scope::Guard module.
976
977 sub new {
978     my ($class, $handler) = @_;
979
980     return bless $handler, $class;
981 }
982
983 sub DESTROY {
984     my ($self) = @_;
985
986     $self->();
987 }
988
989 1;
990
991 __END__
992
993 =head1 NAME
994
995 Fatal - Replace functions with equivalents which succeed or die
996
997 =head1 SYNOPSIS
998
999     use Fatal qw(open close);
1000
1001     open(my $fh, "<", $filename);  # No need to check errors!
1002
1003     use File::Copy qw(move);
1004     use Fatal qw(move);
1005
1006     move($file1, $file2); # No need to check errors!
1007
1008     sub juggle { . . . }
1009     Fatal->import('juggle');
1010
1011 =head1 BEST PRACTICE
1012
1013 B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
1014 L<autodie> in preference to C<Fatal>.  L<autodie> supports lexical scoping,
1015 throws real exception objects, and provides much nicer error messages.
1016
1017 The use of C<:void> with Fatal is discouraged.
1018
1019 =head1 DESCRIPTION
1020
1021 C<Fatal> provides a way to conveniently replace
1022 functions which normally return a false value when they fail with
1023 equivalents which raise exceptions if they are not successful.  This
1024 lets you use these functions without having to test their return
1025 values explicitly on each call.  Exceptions can be caught using
1026 C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
1027
1028 The do-or-die equivalents are set up simply by calling Fatal's
1029 C<import> routine, passing it the names of the functions to be
1030 replaced.  You may wrap both user-defined functions and overridable
1031 CORE operators (except C<exec>, C<system>, C<print>, or any other
1032 built-in that cannot be expressed via prototypes) in this way.
1033
1034 If the symbol C<:void> appears in the import list, then functions
1035 named later in that import list raise an exception only when
1036 these are called in void context--that is, when their return
1037 values are ignored.  For example
1038
1039     use Fatal qw/:void open close/;
1040
1041     # properly checked, so no exception raised on error
1042     if (not open(my $fh, '<' '/bogotic') {
1043         warn "Can't open /bogotic: $!";
1044     }
1045
1046     # not checked, so error raises an exception
1047     close FH;
1048
1049 The use of C<:void> is discouraged, as it can result in exceptions
1050 not being thrown if you I<accidentally> call a method without
1051 void context.  Use L<autodie> instead if you need to be able to
1052 disable autodying/Fatal behaviour for a small block of code.
1053
1054 =head1 DIAGNOSTICS
1055
1056 =over 4
1057
1058 =item Bad subroutine name for Fatal: %s
1059
1060 You've called C<Fatal> with an argument that doesn't look like
1061 a subroutine name, nor a switch that this version of Fatal
1062 understands.
1063
1064 =item %s is not a Perl subroutine
1065
1066 You've asked C<Fatal> to try and replace a subroutine which does not
1067 exist, or has not yet been defined.
1068
1069 =item %s is neither a builtin, nor a Perl subroutine
1070
1071 You've asked C<Fatal> to replace a subroutine, but it's not a Perl
1072 built-in, and C<Fatal> couldn't find it as a regular subroutine.
1073 It either doesn't exist or has not yet been defined.
1074
1075 =item Cannot make the non-overridable %s fatal
1076
1077 You've tried to use C<Fatal> on a Perl built-in that can't be
1078 overridden, such as C<print> or C<system>, which means that
1079 C<Fatal> can't help you, although some other modules might.
1080 See the L</"SEE ALSO"> section of this documentation.
1081
1082 =item Internal error: %s
1083
1084 You've found a bug in C<Fatal>.  Please report it using
1085 the C<perlbug> command.
1086
1087 =back
1088
1089 =head1 BUGS
1090
1091 C<Fatal> clobbers the context in which a function is called and always
1092 makes it a scalar context, except when the C<:void> tag is used.
1093 This problem does not exist in L<autodie>.
1094
1095 =head1 AUTHOR
1096
1097 Original module by Lionel Cons (CERN).
1098
1099 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
1100
1101 L<autodie> support, bugfixes, extended diagnostics, C<system>
1102 support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
1103
1104 =head1 LICENSE
1105
1106 This module is free software, you may distribute it under the
1107 same terms as Perl itself.
1108
1109 =head1 SEE ALSO
1110
1111 L<autodie> for a nicer way to use lexical Fatal.
1112
1113 L<IPC::System::Simple> for a similar idea for calls to C<system()>
1114 and backticks.
1115
1116 =cut