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