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