This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence "smartmatch is experimental" warnings in autodie
[perl5.git] / cpan / autodie / lib / Fatal.pm
CommitLineData
e92e55da
MB
1package Fatal;
2
0b09a93a 3use 5.008; # 5.8.x needed for autodie
e92e55da
MB
4use Carp;
5use strict;
0b09a93a 6use warnings;
9b657a62 7use Tie::RefHash; # To cache subroutine refs
a009834b 8use Config;
9b657a62
PF
9
10use constant PERL510 => ( $] >= 5.010 );
e92e55da 11
0b09a93a
PF
12use constant LEXICAL_TAG => q{:lexical};
13use constant VOID_TAG => q{:void};
9b657a62 14use constant INSIST_TAG => q{!};
e92e55da 15
0b09a93a
PF
16use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
17use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
18use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
19use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
20use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
21use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
22use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
9b657a62
PF
23use constant ERROR_NOHINTS => "No user hints defined for %s";
24
0b09a93a
PF
25use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
26
27use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
28
29use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
30
31use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
32
33use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
34
9b657a62
PF
35use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
36
0b09a93a
PF
37# Older versions of IPC::System::Simple don't support all the
38# features we need.
39
40use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
41
42# All the Fatal/autodie modules share the same version number.
91d419ac 43our $VERSION = '2.13';
0b09a93a
PF
44
45our $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
52our %_EWOULDBLOCK = (
53 MSWin32 => 33,
54);
55
a009834b
CBW
56# the linux parisc port has separate EAGAIN and EWOULDBLOCK,
57# and the kernel returns EAGAIN
58my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
59
0b09a93a
PF
60# We have some tags that can be passed in for use with import.
61# These are all assumed to be CORE::
62
63my %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
a009834b 68 ioctl truncate chmod)],
0b09a93a
PF
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?
9b657a62 79 # TODO - Can socket return false?
0b09a93a
PF
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
a009834b
CBW
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
0b09a93a
PF
97 # Version specific tags. These allow someone to specify
98 # use autodie qw(:1.994) and know exactly what they'll get.
99
a009834b
CBW
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)],
32374c8c 119 ':2.11' => [qw(:default)],
20da2e5b 120 ':2.12' => [qw(:default)],
91d419ac 121 ':2.13' => [qw(:default)],
0b09a93a
PF
122);
123
a009834b
CBW
124# chmod was only introduced in 2.07
125
0b09a93a
PF
126$TAGS{':all'} = [ keys %TAGS ];
127
128# This hash contains subroutines for which we should
129# subroutine() // die() rather than subroutine() || die()
130
131my %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
20da2e5b
CBW
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
157my %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
0b09a93a
PF
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
207my %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
215my %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
220my %Original_user_sub = ();
221
9b657a62
PF
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
226my %Is_fatalised_sub = ();
227tie %Is_fatalised_sub, 'Tie::RefHash';
228
0b09a93a
PF
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
233my $PACKAGE = __PACKAGE__;
234my $PACKAGE_GUARD = "guard $PACKAGE";
235my $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'.
e92e55da
MB
239
240sub import {
9b657a62 241 my $class = shift(@_);
a009834b 242 my @original_args = @_;
9b657a62
PF
243 my $void = 0;
244 my $lexical = 0;
245 my $insist_hints = 0;
0b09a93a
PF
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
9b657a62
PF
294 } elsif ($func eq INSIST_TAG) {
295
296 $insist_hints = 1;
297
0b09a93a
PF
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
9b657a62
PF
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
0b09a93a
PF
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(
9b657a62
PF
347 $func, $pkg, $void, $lexical, $filename,
348 ( $insist_this || $insist_hints )
0b09a93a
PF
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
a009834b
CBW
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
0b09a93a
PF
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
408sub _install_subs {
409 my ($class, $pkg, $subs_to_reinstate) = @_;
410
411 my $pkg_sym = "${pkg}::";
412
91d419ac
YO
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};
0b09a93a
PF
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
9b657a62
PF
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.
0b09a93a 432
9b657a62 433 foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
0b09a93a
PF
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
450sub 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 =~ /^:/) {
a009834b 536 # Expand :tags
0b09a93a 537 push(@to_process, @{$TAGS{$item}} );
a009834b
CBW
538 }
539 else {
0b09a93a
PF
540 push(@taglist, "CORE::$item");
541 }
542 }
543
544 $tag_cache{$tag} = \@taglist;
545
546 return \@taglist;
547
548 }
549
e92e55da
MB
550}
551
0b09a93a 552# This code is from the original Fatal. It scares me.
9b657a62
PF
553# It is 100% compatible with the 5.10.0 Fatal module, right down
554# to the scary 'XXXX' comment. ;)
0b09a93a 555
e92e55da 556sub fill_protos {
0b09a93a
PF
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;
e92e55da
MB
570}
571
9b657a62
PF
572# This is a backwards compatible version of _write_invocation. It's
573# recommended you don't use it.
0b09a93a 574
e92e55da 575sub write_invocation {
9b657a62
PF
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
591sub _write_invocation {
592
593 my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
0b09a93a
PF
594
595 if (@argvs == 1) { # No optional arguments
596
597 my @argv = @{$argvs[0]};
598 shift @argv;
599
9b657a62 600 return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
0b09a93a
PF
601
602 } else {
603 my $else = "\t";
604 my (@out, @argv, $n);
605 while (@argvs) {
606 @argv = @{shift @argvs};
607 $n = shift @argv;
608
a009834b
CBW
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
0b09a93a
PF
620 $else = "\t} els";
621
9b657a62 622 push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
0b09a93a 623 }
9b657a62 624 push @out, qq[
0b09a93a 625 }
9b657a62 626 die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
0b09a93a
PF
627 ];
628
629 return join '', @out;
630 }
e92e55da
MB
631}
632
9b657a62
PF
633
634# This is a slim interface to ensure backward compatibility with
635# anyone doing very foolish things with old versions of Fatal.
636
e92e55da 637sub one_invocation {
9b657a62
PF
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
657sub _one_invocation {
658 my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
659
0b09a93a
PF
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
9b657a62
PF
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.
0b09a93a
PF
682
683 if ($call eq 'CORE::system') {
684 return q{
9b657a62 685 croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
0b09a93a
PF
686 };
687 }
688
689 local $" = ', ';
690
691 if ($void) {
692 return qq/return (defined wantarray)?$call(@argv):
a009834b
CBW
693 $call(@argv) || Carp::croak("Can't $name(\@_)/ .
694 ($core ? ': $!' : ', \$! is \"$!\"') . '")'
0b09a93a 695 } else {
a009834b
CBW
696 return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
697 ($core ? ': $!' : ', \$! is \"$!\"') . '")';
0b09a93a
PF
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
9b657a62
PF
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 );
eb8d423f
PF
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
9b657a62 742 }
0b09a93a 743
9b657a62 744 # Checks for special core subs.
0b09a93a
PF
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
9b657a62 776 # TODO - This can't be overridden in child
0b09a93a
PF
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
0b09a93a
PF
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(
9b657a62 795 function => q{$human_sub_name}, args => [ @argv ],
0b09a93a 796 pragma => q{$class}, errno => \$!,
eb8d423f 797 context => \$context, return => \$retval,
7840a289 798 eval_error => \$@
0b09a93a
PF
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.");
a009834b
CBW
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 }
0b09a93a
PF
824
825 require Fcntl; # For Fcntl::LOCK_NB
826
827 return qq{
828
eb8d423f
PF
829 my \$context = wantarray() ? "list" : "scalar";
830
0b09a93a
PF
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
a009834b
CBW
839 if (\$_[1] & Fcntl::LOCK_NB() and
840 (\$! == $EWOULDBLOCK or
841 ($try_EAGAIN and \$! == $EAGAIN ))) {
0b09a93a
PF
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
eb8d423f
PF
857 # Other warnings are disabled because they produce excessive
858 # complaints from smart-match hints under 5.10.1.
859
9b657a62 860 my $code = qq[
eb8d423f 861 no warnings qw(unopened uninitialized numeric);
3f5e3f2f 862 no if \$\] >= 5.017011, warnings => "experimental::smartmatch";
0b09a93a
PF
863
864 if (wantarray) {
865 my \@results = $call(@argv);
eb8d423f
PF
866 my \$retval = \\\@results;
867 my \$context = "list";
9b657a62
PF
868
869 ];
870
20da2e5b
CBW
871 my $retval_action = $Retval_action{$call} || '';
872
9b657a62
PF
873 if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
874
875 # NB: Subroutine hints are passed as a full list.
876 # This differs from the 5.10.0 smart-match behaviour,
877 # but means that context unaware subroutines can use
878 # the same hints in both list and scalar context.
879
880 $code .= qq{
881 if ( \$hints->{list}->(\@results) ) { $die };
882 };
883 }
884 elsif ( PERL510 and $hints ) {
885 $code .= qq{
886 if ( \@results ~~ \$hints->{list} ) { $die };
887 };
888 }
889 elsif ( $hints ) {
890 croak sprintf(ERROR_58_HINTS, 'list', $sub);
891 }
892 else {
893 $code .= qq{
894 # An empty list, or a single undef is failure
0b09a93a
PF
895 if (! \@results or (\@results == 1 and ! defined \$results[0])) {
896 $die;
9b657a62
PF
897 }
898 }
899 }
900
901 # Tidy up the end of our wantarray call.
902
903 $code .= qq[
0b09a93a
PF
904 return \@results;
905 }
9b657a62 906 ];
0b09a93a 907
0b09a93a 908
9b657a62
PF
909 # Otherwise, we're in scalar context.
910 # We're never in a void context, since we have to look
911 # at the result.
912
913 $code .= qq{
eb8d423f
PF
914 my \$retval = $call(@argv);
915 my \$context = "scalar";
9b657a62
PF
916 };
917
918 if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
919
920 # We always call code refs directly, since that always
921 # works in 5.8.x, and always works in 5.10.1
922
923 return $code .= qq{
eb8d423f 924 if ( \$hints->{scalar}->(\$retval) ) { $die };
20da2e5b 925 $retval_action
eb8d423f 926 return \$retval;
9b657a62 927 };
0b09a93a 928
9b657a62
PF
929 }
930 elsif (PERL510 and $hints) {
931 return $code . qq{
932
eb8d423f 933 if ( \$retval ~~ \$hints->{scalar} ) { $die };
20da2e5b 934 $retval_action
eb8d423f 935 return \$retval;
9b657a62
PF
936 };
937 }
938 elsif ( $hints ) {
939 croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
940 }
941
942 return $code .
943 ( $use_defined_or ? qq{
0b09a93a 944
eb8d423f 945 $die if not defined \$retval;
20da2e5b 946 $retval_action
eb8d423f 947 return \$retval;
0b09a93a
PF
948
949 } : qq{
950
20da2e5b 951 $retval_action
eb8d423f 952 return \$retval || $die;
0b09a93a
PF
953
954 } ) ;
955
e92e55da
MB
956}
957
0b09a93a
PF
958# This returns the old copy of the sub, so we can
959# put it back at end of scope.
960
961# TODO : Check to make sure prototypes are restored correctly.
962
963# TODO: Taking a huge list of arguments is awful. Rewriting to
964# take a hash would be lovely.
965
9b657a62
PF
966# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
967
e92e55da 968sub _make_fatal {
9b657a62
PF
969 my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
970 my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
e92e55da
MB
971 my $ini = $sub;
972
973 $sub = "${pkg}::$sub" unless $sub =~ /::/;
0b09a93a
PF
974
975 # Figure if we're using lexical or package semantics and
976 # twiddle the appropriate bits.
977
978 if (not $lexical) {
979 $Package_Fatal{$sub} = 1;
980 }
981
982 # TODO - We *should* be able to do skipping, since we know when
983 # we've lexicalised / unlexicalised a subroutine.
984
e92e55da
MB
985 $name = $sub;
986 $name =~ s/.*::// or $name =~ s/^&//;
0b09a93a
PF
987
988 warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
989 croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
990
991 if (defined(&$sub)) { # user subroutine
992
9b657a62
PF
993 # NOTE: Previously we would localise $@ at this point, so
994 # the following calls to eval {} wouldn't interfere with anything
995 # that's already in $@. Unfortunately, it would also stop
996 # any of our croaks from triggering(!), which is even worse.
997
0b09a93a
PF
998 # This could be something that we've fatalised that
999 # was in core.
1000
9b657a62 1001 if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
0b09a93a
PF
1002
1003 # Something we previously made Fatal that was core.
1004 # This is safe to replace with an autodying to core
1005 # version.
1006
1007 $core = 1;
1008 $call = "CORE::$name";
1009 $proto = prototype $call;
1010
1011 # We return our $sref from this subroutine later
1012 # on, indicating this subroutine should be placed
1013 # back when we're finished.
1014
1015 $sref = \&$sub;
1016
1017 } else {
1018
9b657a62
PF
1019 # If this is something we've already fatalised or played with,
1020 # then look-up the name of the original sub for the rest of
1021 # our processing.
1022
1023 $sub = $Is_fatalised_sub{\&$sub} || $sub;
1024
0b09a93a
PF
1025 # A regular user sub, or a user sub wrapping a
1026 # core sub.
1027
1028 $sref = \&$sub;
1029 $proto = prototype $sref;
1030 $call = '&$sref';
9b657a62
PF
1031 require autodie::hints;
1032
1033 $hints = autodie::hints->get_hints_for( $sref );
1034
1035 # If we've insisted on hints, but don't have them, then
1036 # bail out!
1037
1038 if ($insist and not $hints) {
1039 croak(sprintf(ERROR_NOHINTS, $name));
1040 }
1041
1042 # Otherwise, use the default hints if we don't have
1043 # any.
1044
1045 $hints ||= autodie::hints::DEFAULT_HINTS();
0b09a93a
PF
1046
1047 }
1048
910ad8dd 1049 } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
0b09a93a
PF
1050 # Stray user subroutine
1051 croak(sprintf(ERROR_NOTSUB,$sub));
1052
1053 } elsif ($name eq 'system') {
1054
1055 # If we're fatalising system, then we need to load
1056 # helper code.
1057
9b657a62
PF
1058 # The business with $E is to avoid clobbering our caller's
1059 # $@, and to avoid $@ being localised when we croak.
0b09a93a 1060
9b657a62 1061 my $E;
0b09a93a 1062
9b657a62
PF
1063 {
1064 local $@;
1065
1066 eval {
1067 require IPC::System::Simple; # Only load it if we need it.
1068 require autodie::exception::system;
1069 };
1070 $E = $@;
1071 }
1072
1073 if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
1074
1075 # Make sure we're using a recent version of ISS that actually
1076 # support fatalised system.
1077 if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
1078 croak sprintf(
1079 ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
1080 $IPC::System::Simple::VERSION
1081 );
1082 }
0b09a93a
PF
1083
1084 $call = 'CORE::system';
1085 $name = 'system';
db4e6d09 1086 $core = 1;
0b09a93a
PF
1087
1088 } elsif ($name eq 'exec') {
1089 # Exec doesn't have a prototype. We don't care. This
1090 # breaks the exotic form with lexical scope, and gives
1091 # the regular form a "do or die" beaviour as expected.
1092
1093 $call = 'CORE::exec';
1094 $name = 'exec';
1095 $core = 1;
1096
1097 } else { # CORE subroutine
9b657a62
PF
1098 my $E;
1099 {
1100 local $@;
1101 $proto = eval { prototype "CORE::$name" };
1102 $E = $@;
1103 }
1104 croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
0b09a93a
PF
1105 croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
1106 $core = 1;
1107 $call = "CORE::$name";
e92e55da 1108 }
0b09a93a 1109
e92e55da 1110 if (defined $proto) {
0b09a93a 1111 $real_proto = " ($proto)";
e92e55da 1112 } else {
0b09a93a
PF
1113 $real_proto = '';
1114 $proto = '@';
1115 }
1116
1117 my $true_name = $core ? $call : $sub;
1118
1119 # TODO: This caching works, but I don't like using $void and
1120 # $lexical as keys. In particular, I suspect our code may end up
1121 # wrapping already wrapped code when autodie and Fatal are used
1122 # together.
1123
1124 # NB: We must use '$sub' (the name plus package) and not
1125 # just '$name' (the short name) here. Failing to do so
1126 # results code that's in the wrong package, and hence has
1127 # access to the wrong package filehandles.
1128
1129 if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
1130 $class->_install_subs($pkg, { $name => $subref });
1131 return $sref;
e92e55da 1132 }
0b09a93a
PF
1133
1134 $code = qq[
1135 sub$real_proto {
1136 local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
1137 ];
1138
1139 # Don't have perl whine if exec fails, since we'll be handling
1140 # the exception now.
1141 $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
1142
e92e55da 1143 my @protos = fill_protos($proto);
9b657a62 1144 $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
e92e55da 1145 $code .= "}\n";
0b09a93a
PF
1146 warn $code if $Debug;
1147
1148 # I thought that changing package was a monumental waste of
1149 # time for CORE subs, since they'll always be the same. However
1150 # that's not the case, since they may refer to package-based
1151 # filehandles (eg, with open).
1152 #
1153 # There is potential to more aggressively cache core subs
1154 # that we know will never want to interact with package variables
1155 # and filehandles.
1156
2ba6ecf4 1157 {
0b09a93a 1158 no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
0b09a93a 1159
9b657a62
PF
1160 my $E;
1161
1162 {
1163 local $@;
a009834b 1164 $code = eval("package $pkg; require Carp; $code"); ## no critic
9b657a62
PF
1165 $E = $@;
1166 }
0b09a93a 1167
9b657a62
PF
1168 if (not $code) {
1169 croak("Internal error in autodie/Fatal processing $true_name: $E");
0b09a93a
PF
1170
1171 }
1172 }
1173
1174 # Now we need to wrap our fatalised sub inside an itty bitty
1175 # closure, which can detect if we've leaked into another file.
1176 # Luckily, we only need to do this for lexical (autodie)
1177 # subs. Fatal subs can leak all they want, it's considered
1178 # a "feature" (or at least backwards compatible).
1179
1180 # TODO: Cache our leak guards!
1181
1182 # TODO: This is pretty hairy code. A lot more tests would
1183 # be really nice for this.
1184
1185 my $leak_guard;
1186
1187 if ($lexical) {
1188
1189 $leak_guard = qq<
1190 package $pkg;
1191
1192 sub$real_proto {
1193
db4e6d09
PF
1194 # If we're inside a string eval, we can end up with a
1195 # whacky filename. The following code allows autodie
1196 # to propagate correctly into string evals.
1197
1198 my \$caller_level = 0;
1199
b0745470
PF
1200 my \$caller;
1201
1202 while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
1203
1204 # If our filename is actually an eval, and we
1205 # reach it, then go to our autodying code immediatately.
1206
1207 goto &\$code if (\$caller eq \$filename);
db4e6d09
PF
1208 \$caller_level++;
1209 }
1210
b0745470
PF
1211 # We're now out of the eval stack.
1212
0b09a93a
PF
1213 # If we're called from the correct file, then use the
1214 # autodying code.
db4e6d09 1215 goto &\$code if ((caller \$caller_level)[1] eq \$filename);
0b09a93a
PF
1216
1217 # Oh bother, we've leaked into another file. Call the
1218 # original code. Note that \$sref may actually be a
1219 # reference to a Fatalised version of a core built-in.
1220 # That's okay, because Fatal *always* leaks between files.
1221
1222 goto &\$sref if \$sref;
1223 >;
1224
1225
1226 # If we're here, it must have been a core subroutine called.
1227 # Warning: The following code may disturb some viewers.
1228
1229 # TODO: It should be possible to combine this with
1230 # write_invocation().
1231
1232 foreach my $proto (@protos) {
1233 local $" = ", "; # So @args is formatted correctly.
1234 my ($count, @args) = @$proto;
1235 $leak_guard .= qq<
1236 if (\@_ == $count) {
1237 return $call(@args);
1238 }
1239 >;
1240 }
1241
a009834b 1242 $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >;
0b09a93a
PF
1243
1244 # warn "$leak_guard\n";
1245
9b657a62
PF
1246 my $E;
1247 {
1248 local $@;
1249
1250 $leak_guard = eval $leak_guard; ## no critic
0b09a93a 1251
9b657a62
PF
1252 $E = $@;
1253 }
0b09a93a 1254
9b657a62 1255 die "Internal error in $class: Leak-guard installation failure: $E" if $E;
0b09a93a
PF
1256 }
1257
9b657a62
PF
1258 my $installed_sub = $leak_guard || $code;
1259
1260 $class->_install_subs($pkg, { $name => $installed_sub });
1261
1262 $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
1263
1264 # Cache that we've now overriddent this sub. If we get called
1265 # again, we may need to find that find subroutine again (eg, for hints).
0b09a93a 1266
9b657a62 1267 $Is_fatalised_sub{$installed_sub} = $sref;
0b09a93a
PF
1268
1269 return $sref;
1270
1271}
1272
1273# This subroutine exists primarily so that child classes can override
1274# it to point to their own exception class. Doing this is significantly
1275# less complex than overriding throw()
1276
1277sub exception_class { return "autodie::exception" };
1278
1279{
1280 my %exception_class_for;
1281 my %class_loaded;
1282
1283 sub throw {
1284 my ($class, @args) = @_;
1285
1286 # Find our exception class if we need it.
1287 my $exception_class =
1288 $exception_class_for{$class} ||= $class->exception_class;
1289
1290 if (not $class_loaded{$exception_class}) {
1291 if ($exception_class =~ /[^\w:']/) {
1292 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.";
1293 }
1294
1295 # Alas, Perl does turn barewords into modules unless they're
1296 # actually barewords. As such, we're left doing a string eval
1297 # to make sure we load our file correctly.
1298
1299 my $E;
1300
1301 {
1302 local $@; # We can't clobber $@, it's wrong!
32374c8c
CBW
1303 my $pm_file = $exception_class . ".pm";
1304 $pm_file =~ s{ (?: :: | ' ) }{/}gx;
1305 eval { require $pm_file };
0b09a93a
PF
1306 $E = $@; # Save $E despite ending our local.
1307 }
1308
1309 # We need quotes around $@ to make sure it's stringified
1310 # while still in scope. Without them, we run the risk of
1311 # $@ having been cleared by us exiting the local() block.
1312
1313 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;
1314
1315 $class_loaded{$exception_class}++;
1316
1317 }
1318
1319 return $exception_class->new(@args);
2ba6ecf4 1320 }
e92e55da
MB
1321}
1322
0b09a93a
PF
1323# For some reason, dying while replacing our subs doesn't
1324# kill our calling program. It simply stops the loading of
1325# autodie and keeps going with everything else. The _autocroak
1326# sub allows us to die with a vegence. It should *only* ever be
1327# used for serious internal errors, since the results of it can't
1328# be captured.
1329
1330sub _autocroak {
1331 warn Carp::longmess(@_);
1332 exit(255); # Ugh!
1333}
1334
1335package autodie::Scope::Guard;
1336
1337# This code schedules the cleanup of subroutines at the end of
1338# scope. It's directly inspired by chocolateboy's excellent
1339# Scope::Guard module.
1340
1341sub new {
1342 my ($class, $handler) = @_;
1343
1344 return bless $handler, $class;
1345}
1346
1347sub DESTROY {
1348 my ($self) = @_;
1349
1350 $self->();
1351}
1352
e92e55da
MB
13531;
1354
1355__END__
1356
1357=head1 NAME
1358
0b09a93a 1359Fatal - Replace functions with equivalents which succeed or die
e92e55da
MB
1360
1361=head1 SYNOPSIS
1362
1363 use Fatal qw(open close);
1364
0b09a93a
PF
1365 open(my $fh, "<", $filename); # No need to check errors!
1366
1367 use File::Copy qw(move);
1368 use Fatal qw(move);
1369
1370 move($file1, $file2); # No need to check errors!
1371
e92e55da 1372 sub juggle { . . . }
0b09a93a
PF
1373 Fatal->import('juggle');
1374
1375=head1 BEST PRACTICE
1376
1377B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
1378L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
1379throws real exception objects, and provides much nicer error messages.
1380
1381The use of C<:void> with Fatal is discouraged.
e92e55da
MB
1382
1383=head1 DESCRIPTION
1384
0b09a93a
PF
1385C<Fatal> provides a way to conveniently replace
1386functions which normally return a false value when they fail with
1387equivalents which raise exceptions if they are not successful. This
1388lets you use these functions without having to test their return
1389values explicitly on each call. Exceptions can be caught using
1390C<eval{}>. See L<perlfunc> and L<perlvar> for details.
e92e55da
MB
1391
1392The do-or-die equivalents are set up simply by calling Fatal's
1393C<import> routine, passing it the names of the functions to be
1394replaced. You may wrap both user-defined functions and overridable
0b09a93a
PF
1395CORE operators (except C<exec>, C<system>, C<print>, or any other
1396built-in that cannot be expressed via prototypes) in this way.
e92e55da 1397
91c7a880
GS
1398If the symbol C<:void> appears in the import list, then functions
1399named later in that import list raise an exception only when
1400these are called in void context--that is, when their return
1401values are ignored. For example
1402
0b09a93a 1403 use Fatal qw/:void open close/;
91c7a880 1404
0b09a93a 1405 # properly checked, so no exception raised on error
9b657a62 1406 if (not open(my $fh, '<', '/bogotic') {
0b09a93a
PF
1407 warn "Can't open /bogotic: $!";
1408 }
91c7a880 1409
0b09a93a
PF
1410 # not checked, so error raises an exception
1411 close FH;
1412
1413The use of C<:void> is discouraged, as it can result in exceptions
1414not being thrown if you I<accidentally> call a method without
1415void context. Use L<autodie> instead if you need to be able to
1416disable autodying/Fatal behaviour for a small block of code.
1417
1418=head1 DIAGNOSTICS
1419
1420=over 4
1421
1422=item Bad subroutine name for Fatal: %s
1423
1424You've called C<Fatal> with an argument that doesn't look like
1425a subroutine name, nor a switch that this version of Fatal
1426understands.
1427
1428=item %s is not a Perl subroutine
1429
1430You've asked C<Fatal> to try and replace a subroutine which does not
1431exist, or has not yet been defined.
1432
1433=item %s is neither a builtin, nor a Perl subroutine
1434
1435You've asked C<Fatal> to replace a subroutine, but it's not a Perl
1436built-in, and C<Fatal> couldn't find it as a regular subroutine.
1437It either doesn't exist or has not yet been defined.
1438
1439=item Cannot make the non-overridable %s fatal
1440
1441You've tried to use C<Fatal> on a Perl built-in that can't be
1442overridden, such as C<print> or C<system>, which means that
1443C<Fatal> can't help you, although some other modules might.
1444See the L</"SEE ALSO"> section of this documentation.
1445
1446=item Internal error: %s
1447
1448You've found a bug in C<Fatal>. Please report it using
1449the C<perlbug> command.
1450
1451=back
91c7a880 1452
a6fd7f3f
RGS
1453=head1 BUGS
1454
0b09a93a
PF
1455C<Fatal> clobbers the context in which a function is called and always
1456makes it a scalar context, except when the C<:void> tag is used.
1457This problem does not exist in L<autodie>.
a6fd7f3f 1458
3776a202
PF
1459"Used only once" warnings can be generated when C<autodie> or C<Fatal>
1460is used with package filehandles (eg, C<FILE>). It's strongly recommended
1461you use scalar filehandles instead.
1462
e92e55da
MB
1463=head1 AUTHOR
1464
0b09a93a 1465Original module by Lionel Cons (CERN).
e92e55da 1466
10af26ed 1467Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
e92e55da 1468
0b09a93a
PF
1469L<autodie> support, bugfixes, extended diagnostics, C<system>
1470support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
1471
1472=head1 LICENSE
1473
1474This module is free software, you may distribute it under the
1475same terms as Perl itself.
1476
1477=head1 SEE ALSO
1478
1479L<autodie> for a nicer way to use lexical Fatal.
1480
1481L<IPC::System::Simple> for a similar idea for calls to C<system()>
1482and backticks.
1483
e92e55da 1484=cut