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