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