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