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