lib/Fatal.pm

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