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.999';
  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     ':1.998' => [qw(:default)],
  87     ':1.999' => [qw(:default)],
  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
  96 my %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
 120 my %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
 128 my %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
 133 my %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
 139 my $PACKAGE       = __PACKAGE__;
 140 my $PACKAGE_GUARD = "guard $PACKAGE";
 141 my $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'.
 145
 146 sub import {
 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
 286 sub _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
 323 sub 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
 421 }
 422
 423 # This code is from the original Fatal.  It scares me.
 424
 425 sub fill_protos {
 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;
 439 }
 440
 441 # This generates the code that will become our fatalised subroutine.
 442
 443 sub write_invocation {
 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     }
 472 }
 473
 474 sub one_invocation {
 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
 669 }
 670
 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
 679 sub _make_fatal {
 680     my($class, $sub, $pkg, $void, $lexical, $filename) = @_;
 681     my($name, $code, $sref, $real_proto, $proto, $core, $call);
 682     my $ini = $sub;
 683
 684     $sub = "${pkg}::$sub" unless $sub =~ /::/;
 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
 696     $name = $sub;
 697     $name =~ s/.*::// or $name =~ s/^&//;
 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
 736     } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
 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';
 763         $core = 1;
 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
 775         $proto = eval { prototype "CORE::$name" };
 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";
 780     }
 781
 782     if (defined $proto) {
 783         $real_proto = " ($proto)";
 784     } else {
 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;
 804     }
 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
 815     my @protos = fill_protos($proto);
 816     $code .= $class->write_invocation($core, $call, $name, $void, $lexical, $sub, @protos);
 817     $code .= "}\n";
 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
 829     {
 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
 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
 876                 # If we're called from the correct file, then use the
 877                 # autodying code.
 878                 goto &\$code if ((caller \$caller_level)[1] eq \$filename);
 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
 928 sub 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);
 969     }
 970 }
 971
 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
 979 sub _autocroak {
 980     warn Carp::longmess(@_);
 981     exit(255);  # Ugh!
 982 }
 983
 984 package 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
 990 sub new {
 991     my ($class, $handler) = @_;
 992
 993     return bless $handler, $class;
 994 }
 995
 996 sub DESTROY {
 997     my ($self) = @_;
 998
 999     $self->();
1000 }
1001
1002 1;
1003
1004 __END__
1005
1006 =head1 NAME
1007
1008 Fatal - Replace functions with equivalents which succeed or die
1009
1010 =head1 SYNOPSIS
1011
1012     use Fatal qw(open close);
1013
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
1021     sub juggle { . . . }
1022     Fatal->import('juggle');
1023
1024 =head1 BEST PRACTICE
1025
1026 B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
1027 L<autodie> in preference to C<Fatal>.  L<autodie> supports lexical scoping,
1028 throws real exception objects, and provides much nicer error messages.
1029
1030 The use of C<:void> with Fatal is discouraged.
1031
1032 =head1 DESCRIPTION
1033
1034 C<Fatal> provides a way to conveniently replace
1035 functions which normally return a false value when they fail with
1036 equivalents which raise exceptions if they are not successful.  This
1037 lets you use these functions without having to test their return
1038 values explicitly on each call.  Exceptions can be caught using
1039 C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
1040
1041 The do-or-die equivalents are set up simply by calling Fatal's
1042 C<import> routine, passing it the names of the functions to be
1043 replaced.  You may wrap both user-defined functions and overridable
1044 CORE operators (except C<exec>, C<system>, C<print>, or any other
1045 built-in that cannot be expressed via prototypes) in this way.
1046
1047 If the symbol C<:void> appears in the import list, then functions
1048 named later in that import list raise an exception only when
1049 these are called in void context--that is, when their return
1050 values are ignored.  For example
1051
1052     use Fatal qw/:void open close/;
1053
1054     # properly checked, so no exception raised on error
1055     if (not open(my $fh, '<' '/bogotic') {
1056         warn "Can't open /bogotic: $!";
1057     }
1058
1059     # not checked, so error raises an exception
1060     close FH;
1061
1062 The use of C<:void> is discouraged, as it can result in exceptions
1063 not being thrown if you I<accidentally> call a method without
1064 void context.  Use L<autodie> instead if you need to be able to
1065 disable 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
1073 You've called C<Fatal> with an argument that doesn't look like
1074 a subroutine name, nor a switch that this version of Fatal
1075 understands.
1076
1077 =item %s is not a Perl subroutine
1078
1079 You've asked C<Fatal> to try and replace a subroutine which does not
1080 exist, or has not yet been defined.
1081
1082 =item %s is neither a builtin, nor a Perl subroutine
1083
1084 You've asked C<Fatal> to replace a subroutine, but it's not a Perl
1085 built-in, and C<Fatal> couldn't find it as a regular subroutine.
1086 It either doesn't exist or has not yet been defined.
1087
1088 =item Cannot make the non-overridable %s fatal
1089
1090 You've tried to use C<Fatal> on a Perl built-in that can't be
1091 overridden, such as C<print> or C<system>, which means that
1092 C<Fatal> can't help you, although some other modules might.
1093 See the L</"SEE ALSO"> section of this documentation.
1094
1095 =item Internal error: %s
1096
1097 You've found a bug in C<Fatal>.  Please report it using
1098 the C<perlbug> command.
1099
1100 =back
1101
1102 =head1 BUGS
1103
1104 C<Fatal> clobbers the context in which a function is called and always
1105 makes it a scalar context, except when the C<:void> tag is used.
1106 This problem does not exist in L<autodie>.
1107
1108 "Used only once" warnings can be generated when C<autodie> or C<Fatal>
1109 is used with package filehandles (eg, C<FILE>).  It's strongly recommended
1110 you use scalar filehandles instead.
1111
1112 =head1 AUTHOR
1113
1114 Original module by Lionel Cons (CERN).
1115
1116 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
1117
1118 L<autodie> support, bugfixes, extended diagnostics, C<system>
1119 support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
1120
1121 =head1 LICENSE
1122
1123 This module is free software, you may distribute it under the
1124 same terms as Perl itself.
1125
1126 =head1 SEE ALSO
1127
1128 L<autodie> for a nicer way to use lexical Fatal.
1129
1130 L<IPC::System::Simple> for a similar idea for calls to C<system()>
1131 and backticks.
1132
1133 =cut