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