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