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