lib/Fatal.pm

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