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