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