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