1package Fatal; 2 3# ABSTRACT: Replace functions with equivalents which succeed or die 4 5use 5.008; # 5.8.x needed for autodie 6use Carp; 7use strict; 8use warnings; 9use Tie::RefHash; # To cache subroutine refs 10use Config; 11use Scalar::Util qw(set_prototype looks_like_number); 12 13use autodie::Util qw( 14 fill_protos 15 install_subs 16 make_core_trampoline 17 on_end_of_compile_scope 18); 19 20use constant PERL510 => ( $] >= 5.010 ); 21 22use constant LEXICAL_TAG => q{:lexical}; 23use constant VOID_TAG => q{:void}; 24use constant INSIST_TAG => q{!}; 25 26# Keys for %Cached_fatalised_sub (used in 3rd level) 27use constant CACHE_AUTODIE_LEAK_GUARD => 0; 28use constant CACHE_FATAL_WRAPPER => 1; 29use constant CACHE_FATAL_VOID => 2; 30 31 32use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; 33use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; 34use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; 35use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG; 36use constant ERROR_BADNAME => "Bad subroutine name for %s: %s"; 37use constant ERROR_NOTSUB => "%s is not a Perl subroutine"; 38use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine"; 39use constant ERROR_NOHINTS => "No user hints defined for %s"; 40 41use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal"; 42 43use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()"; 44 45use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f"; 46 47use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect}; 48 49use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect}; 50 51use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x}; 52 53# Older versions of IPC::System::Simple don't support all the 54# features we need. 55 56use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; 57 58our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg::Version 59 60our $Debug ||= 0; 61 62# EWOULDBLOCK values for systems that don't supply their own. 63# Even though this is defined with our, that's to help our 64# test code. Please don't rely upon this variable existing in 65# the future. 66 67our %_EWOULDBLOCK = ( 68 MSWin32 => 33, 69); 70 71$Carp::CarpInternal{'Fatal'} = 1; 72$Carp::CarpInternal{'autodie'} = 1; 73$Carp::CarpInternal{'autodie::exception'} = 1; 74 75# the linux parisc port has separate EAGAIN and EWOULDBLOCK, 76# and the kernel returns EAGAIN 77my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; 78 79# We have some tags that can be passed in for use with import. 80# These are all assumed to be CORE:: 81 82my %TAGS = ( 83 ':io' => [qw(:dbm :file :filesys :ipc :socket 84 read seek sysread syswrite sysseek )], 85 ':dbm' => [qw(dbmopen dbmclose)], 86 ':file' => [qw(open close flock sysopen fcntl binmode 87 ioctl truncate)], 88 ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir 89 symlink rmdir readlink chmod chown utime)], 90 ':ipc' => [qw(:msg :semaphore :shm pipe kill)], 91 ':msg' => [qw(msgctl msgget msgrcv msgsnd)], 92 ':threads' => [qw(fork)], 93 ':semaphore'=>[qw(semctl semget semop)], 94 ':shm' => [qw(shmctl shmget shmread)], 95 ':system' => [qw(system exec)], 96 97 # Can we use qw(getpeername getsockname)? What do they do on failure? 98 # TODO - Can socket return false? 99 ':socket' => [qw(accept bind connect getsockopt listen recv send 100 setsockopt shutdown socketpair)], 101 102 # Our defaults don't include system(), because it depends upon 103 # an optional module, and it breaks the exotic form. 104 # 105 # This *may* change in the future. I'd love IPC::System::Simple 106 # to be a dependency rather than a recommendation, and hence for 107 # system() to be autodying by default. 108 109 ':default' => [qw(:io :threads)], 110 111 # Everything in v2.07 and before. This was :default less chmod and chown 112 ':v207' => [qw(:threads :dbm :socket read seek sysread 113 syswrite sysseek open close flock sysopen fcntl fileno 114 binmode ioctl truncate opendir closedir chdir link unlink 115 rename mkdir symlink rmdir readlink umask 116 :msg :semaphore :shm pipe)], 117 118 # Chmod was added in 2.13 119 ':v213' => [qw(:v207 chmod)], 120 121 # chown, utime, kill were added in 2.14 122 ':v214' => [qw(:v213 chown utime kill)], 123 124 # umask was removed in 2.26 125 ':v225' => [qw(:io :threads umask fileno)], 126 127 # Version specific tags. These allow someone to specify 128 # use autodie qw(:1.994) and know exactly what they'll get. 129 130 ':1.994' => [qw(:v207)], 131 ':1.995' => [qw(:v207)], 132 ':1.996' => [qw(:v207)], 133 ':1.997' => [qw(:v207)], 134 ':1.998' => [qw(:v207)], 135 ':1.999' => [qw(:v207)], 136 ':1.999_01' => [qw(:v207)], 137 ':2.00' => [qw(:v207)], 138 ':2.01' => [qw(:v207)], 139 ':2.02' => [qw(:v207)], 140 ':2.03' => [qw(:v207)], 141 ':2.04' => [qw(:v207)], 142 ':2.05' => [qw(:v207)], 143 ':2.06' => [qw(:v207)], 144 ':2.06_01' => [qw(:v207)], 145 ':2.07' => [qw(:v207)], # Last release without chmod 146 ':2.08' => [qw(:v213)], 147 ':2.09' => [qw(:v213)], 148 ':2.10' => [qw(:v213)], 149 ':2.11' => [qw(:v213)], 150 ':2.12' => [qw(:v213)], 151 ':2.13' => [qw(:v213)], # Last release without chown 152 ':2.14' => [qw(:v225)], 153 ':2.15' => [qw(:v225)], 154 ':2.16' => [qw(:v225)], 155 ':2.17' => [qw(:v225)], 156 ':2.18' => [qw(:v225)], 157 ':2.19' => [qw(:v225)], 158 ':2.20' => [qw(:v225)], 159 ':2.21' => [qw(:v225)], 160 ':2.22' => [qw(:v225)], 161 ':2.23' => [qw(:v225)], 162 ':2.24' => [qw(:v225)], 163 ':2.25' => [qw(:v225)], 164 ':2.26' => [qw(:default)], 165 ':2.27' => [qw(:default)], 166 ':2.28' => [qw(:default)], 167 ':2.29' => [qw(:default)], 168 ':2.30' => [qw(:default)], 169 ':2.31' => [qw(:default)], 170 ':2.32' => [qw(:default)], 171); 172 173 174{ 175 # Expand :all immediately by expanding and flattening all tags. 176 # _expand_tag is not really optimised for expanding the ":all" 177 # case (i.e. keys %TAGS, or values %TAGS for that matter), so we 178 # just do it here. 179 # 180 # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being 181 # pre-expanded. 182 my %seen; 183 my @all = grep { 184 !/^:/ && !$seen{$_}++ 185 } map { @{$_} } values %TAGS; 186 $TAGS{':all'} = \@all; 187} 188 189# This hash contains subroutines for which we should 190# subroutine() // die() rather than subroutine() || die() 191 192my %Use_defined_or; 193 194# CORE::open returns undef on failure. It can legitimately return 195# 0 on success, eg: open(my $fh, '-|') || exec(...); 196 197@Use_defined_or{qw( 198 CORE::fork 199 CORE::recv 200 CORE::send 201 CORE::open 202 CORE::fileno 203 CORE::read 204 CORE::readlink 205 CORE::sysread 206 CORE::syswrite 207 CORE::sysseek 208 CORE::umask 209)} = (); 210 211# Some functions can return true because they changed *some* things, but 212# not all of them. This is a list of offending functions, and how many 213# items to subtract from @_ to determine the "success" value they return. 214 215my %Returns_num_things_changed = ( 216 'CORE::chmod' => 1, 217 'CORE::chown' => 2, 218 'CORE::kill' => 1, # TODO: Could this return anything on negative args? 219 'CORE::unlink' => 0, 220 'CORE::utime' => 2, 221); 222 223# Optional actions to take on the return value before returning it. 224 225my %Retval_action = ( 226 "CORE::open" => q{ 227 228 # apply the open pragma from our caller 229 if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) { 230 # Get the caller's hint hash 231 my $hints = (caller 0)[10]; 232 233 # Decide if we're reading or writing and apply the appropriate encoding 234 # These keys are undocumented. 235 # Match what PerlIO_context_layers() does. Read gets the read layer, 236 # everything else gets the write layer. 237 my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; 238 239 # Apply the encoding, if any. 240 if( $encoding ) { 241 binmode $_[0], $encoding; 242 } 243 } 244 245}, 246 "CORE::sysopen" => q{ 247 248 # apply the open pragma from our caller 249 if( defined $retval ) { 250 # Get the caller's hint hash 251 my $hints = (caller 0)[10]; 252 253 require Fcntl; 254 255 # Decide if we're reading or writing and apply the appropriate encoding. 256 # Match what PerlIO_context_layers() does. Read gets the read layer, 257 # everything else gets the write layer. 258 my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); 259 my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; 260 261 # Apply the encoding, if any. 262 if( $encoding ) { 263 binmode $_[0], $encoding; 264 } 265 } 266 267}, 268); 269 270my %reusable_builtins; 271 272# "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can 273# take file and directory handles, which are package depedent." 274# 275# You would be correct, except that prototype() returns signatures which don't 276# allow for passing of globs, and nobody's complained about that. You can 277# still use \*FILEHANDLE, but that results in a reference coming through, 278# and it's already pointing to the filehandle in the caller's packge, so 279# it's all okay. 280 281@reusable_builtins{qw( 282 CORE::fork 283 CORE::kill 284 CORE::truncate 285 CORE::chdir 286 CORE::link 287 CORE::unlink 288 CORE::rename 289 CORE::mkdir 290 CORE::symlink 291 CORE::rmdir 292 CORE::readlink 293 CORE::umask 294 CORE::chmod 295 CORE::chown 296 CORE::utime 297 CORE::msgctl 298 CORE::msgget 299 CORE::msgrcv 300 CORE::msgsnd 301 CORE::semctl 302 CORE::semget 303 CORE::semop 304 CORE::shmctl 305 CORE::shmget 306 CORE::shmread 307 CORE::exec 308 CORE::system 309)} = (); 310 311# Cached_fatalised_sub caches the various versions of our 312# fatalised subs as they're produced. This means we don't 313# have to build our own replacement of CORE::open and friends 314# for every single package that wants to use them. 315 316my %Cached_fatalised_sub = (); 317 318# Every time we're called with package scope, we record the subroutine 319# (including package or CORE::) in %Package_Fatal. This allows us 320# to detect illegal combinations of autodie and Fatal, and makes sure 321# we don't accidently make a Fatal function autodying (which isn't 322# very useful). 323 324my %Package_Fatal = (); 325 326# The first time we're called with a user-sub, we cache it here. 327# In the case of a "no autodie ..." we put back the cached copy. 328 329my %Original_user_sub = (); 330 331# Is_fatalised_sub simply records a big map of fatalised subroutine 332# refs. It means we can avoid repeating work, or fatalising something 333# we've already processed. 334 335my %Is_fatalised_sub = (); 336tie %Is_fatalised_sub, 'Tie::RefHash'; 337 338# Our trampoline cache allows us to cache trampolines which are used to 339# bounce leaked wrapped core subroutines to their actual core counterparts. 340 341my %Trampoline_cache; 342 343# A cache mapping "CORE::<name>" to their prototype. Turns out that if 344# you "use autodie;" enough times, this pays off. 345my %CORE_prototype_cache; 346 347# We use our package in a few hash-keys. Having it in a scalar is 348# convenient. The "guard $PACKAGE" string is used as a key when 349# setting up lexical guards. 350 351my $PACKAGE = __PACKAGE__; 352my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' 353 354# Here's where all the magic happens when someone write 'use Fatal' 355# or 'use autodie'. 356 357sub import { 358 my $class = shift(@_); 359 my @original_args = @_; 360 my $void = 0; 361 my $lexical = 0; 362 my $insist_hints = 0; 363 364 my ($pkg, $filename) = caller(); 365 366 @_ or return; # 'use Fatal' is a no-op. 367 368 # If we see the :lexical flag, then _all_ arguments are 369 # changed lexically 370 371 if ($_[0] eq LEXICAL_TAG) { 372 $lexical = 1; 373 shift @_; 374 375 # It is currently an implementation detail that autodie is 376 # implemented as "use Fatal qw(:lexical ...)". For backwards 377 # compatibility, we allow it - but not without a warning. 378 # NB: Optimise for autodie as it is quite possibly the most 379 # freq. consumer of this case. 380 if ($class ne 'autodie' and not $class->isa('autodie')) { 381 if ($class eq 'Fatal') { 382 warnings::warnif( 383 'deprecated', 384 '[deprecated] The "use Fatal qw(:lexical ...)" ' 385 . 'should be replaced by "use autodie qw(...)". ' 386 . 'Seen' # warnif appends " at <...>" 387 ); 388 } else { 389 warnings::warnif( 390 'deprecated', 391 "[deprecated] The class/Package $class is a " 392 . 'subclass of Fatal and used the :lexical. ' 393 . 'If $class provides lexical error checking ' 394 . 'it should extend autodie instead of using :lexical. ' 395 . 'Seen' # warnif appends " at <...>" 396 ); 397 } 398 # "Promote" the call to autodie from here on. This is 399 # already mostly the case (e.g. use Fatal qw(:lexical ...) 400 # would throw autodie::exceptions on error rather than the 401 # Fatal errors. 402 $class = 'autodie'; 403 # This requires that autodie is in fact loaded; otherwise 404 # the "$class->X()" method calls below will explode. 405 require autodie; 406 # TODO, when autodie and Fatal are cleanly separated, we 407 # should go a "goto &autodie::import" here instead. 408 } 409 410 # If we see no arguments and :lexical, we assume they 411 # wanted ':default'. 412 413 if (@_ == 0) { 414 push(@_, ':default'); 415 } 416 417 # Don't allow :lexical with :void, it's needlessly confusing. 418 if ( grep { $_ eq VOID_TAG } @_ ) { 419 croak(ERROR_VOID_LEX); 420 } 421 } 422 423 if ( grep { $_ eq LEXICAL_TAG } @_ ) { 424 # If we see the lexical tag as the non-first argument, complain. 425 croak(ERROR_LEX_FIRST); 426 } 427 428 my @fatalise_these = @_; 429 430 # These subs will get unloaded at the end of lexical scope. 431 my %unload_later; 432 # These subs are to be installed into callers namespace. 433 my %install_subs; 434 435 # Use _translate_import_args to expand tags for us. It will 436 # pass-through unknown tags (i.e. we have to manually handle 437 # VOID_TAG). 438 # 439 # NB: _translate_import_args re-orders everything for us, so 440 # we don't have to worry about stuff like: 441 # 442 # :default :void :io 443 # 444 # That will (correctly) translated into 445 # 446 # expand(:defaults-without-io) :void :io 447 # 448 # by _translate_import_args. 449 for my $func ($class->_translate_import_args(@fatalise_these)) { 450 451 if ($func eq VOID_TAG) { 452 453 # When we see :void, set the void flag. 454 $void = 1; 455 456 } elsif ($func eq INSIST_TAG) { 457 458 $insist_hints = 1; 459 460 } else { 461 462 # Otherwise, fatalise it. 463 464 # Check to see if there's an insist flag at the front. 465 # If so, remove it, and insist we have hints for this sub. 466 my $insist_this = $insist_hints; 467 468 if (substr($func, 0, 1) eq '!') { 469 $func = substr($func, 1); 470 $insist_this = 1; 471 } 472 473 # We're going to make a subroutine fatalistic. 474 # However if we're being invoked with 'use Fatal qw(x)' 475 # and we've already been called with 'no autodie qw(x)' 476 # in the same scope, we consider this to be an error. 477 # Mixing Fatal and autodie effects was considered to be 478 # needlessly confusing on p5p. 479 480 my $sub = $func; 481 $sub = "${pkg}::$sub" unless $sub =~ /::/; 482 483 # If we're being called as Fatal, and we've previously 484 # had a 'no X' in scope for the subroutine, then complain 485 # bitterly. 486 487 if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { 488 croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); 489 } 490 491 # We're not being used in a confusing way, so make 492 # the sub fatal. Note that _make_fatal returns the 493 # old (original) version of the sub, or undef for 494 # built-ins. 495 496 my $sub_ref = $class->_make_fatal( 497 $func, $pkg, $void, $lexical, $filename, 498 $insist_this, \%install_subs, 499 ); 500 501 $Original_user_sub{$sub} ||= $sub_ref; 502 503 # If we're making lexical changes, we need to arrange 504 # for them to be cleaned at the end of our scope, so 505 # record them here. 506 507 $unload_later{$func} = $sub_ref if $lexical; 508 } 509 } 510 511 install_subs($pkg, \%install_subs); 512 513 if ($lexical) { 514 515 # Dark magic to have autodie work under 5.8 516 # Copied from namespace::clean, that copied it from 517 # autobox, that found it on an ancient scroll written 518 # in blood. 519 520 # This magic bit causes %^H to be lexically scoped. 521 522 $^H |= 0x020000; 523 524 # Our package guard gets invoked when we leave our lexical 525 # scope. 526 527 on_end_of_compile_scope(sub { 528 install_subs($pkg, \%unload_later); 529 }); 530 531 # To allow others to determine when autodie was in scope, 532 # and with what arguments, we also set a %^H hint which 533 # is how we were called. 534 535 # This feature should be considered EXPERIMENTAL, and 536 # may change without notice. Please e-mail pjf@cpan.org 537 # if you're actually using it. 538 539 $^H{autodie} = "$PACKAGE @original_args"; 540 541 } 542 543 return; 544 545} 546 547sub unimport { 548 my $class = shift; 549 550 # Calling "no Fatal" must start with ":lexical" 551 if ($_[0] ne LEXICAL_TAG) { 552 croak(sprintf(ERROR_NO_LEX,$class)); 553 } 554 555 shift @_; # Remove :lexical 556 557 my $pkg = (caller)[0]; 558 559 # If we've been called with arguments, then the developer 560 # has explicitly stated 'no autodie qw(blah)', 561 # in which case, we disable Fatalistic behaviour for 'blah'. 562 563 my @unimport_these = @_ ? @_ : ':all'; 564 my (%uninstall_subs, %reinstall_subs); 565 566 for my $symbol ($class->_translate_import_args(@unimport_these)) { 567 568 my $sub = $symbol; 569 $sub = "${pkg}::$sub" unless $sub =~ /::/; 570 571 # If 'blah' was already enabled with Fatal (which has package 572 # scope) then, this is considered an error. 573 574 if (exists $Package_Fatal{$sub}) { 575 croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); 576 } 577 578 # Record 'no autodie qw($sub)' as being in effect. 579 # This is to catch conflicting semantics elsewhere 580 # (eg, mixing Fatal with no autodie) 581 582 $^H{$NO_PACKAGE}{$sub} = 1; 583 # Record the current sub to be reinstalled at end of scope 584 # and then restore the original (can be undef for "CORE::" 585 # subs) 586 587 { 588 no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... 589 $reinstall_subs{$symbol} = \&$sub 590 if exists ${"${pkg}::"}{$symbol}; 591 } 592 $uninstall_subs{$symbol} = $Original_user_sub{$sub}; 593 594 } 595 596 install_subs($pkg, \%uninstall_subs); 597 on_end_of_compile_scope(sub { 598 install_subs($pkg, \%reinstall_subs); 599 }); 600 601 return; 602 603} 604 605sub _translate_import_args { 606 my ($class, @args) = @_; 607 my @result; 608 my %seen; 609 610 if (@args < 2) { 611 # Optimize for this case, as it is fairly common. (e.g. use 612 # autodie; or use autodie qw(:all); both trigger this). 613 return unless @args; 614 615 # Not a (known) tag, pass through. 616 return @args unless exists($TAGS{$args[0]}); 617 618 # Strip "CORE::" from all elements in the list as import and 619 # unimport does not handle the "CORE::" prefix too well. 620 # 621 # NB: we use substr as it is faster than s/^CORE::// and 622 # it does not change the elements. 623 return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; 624 } 625 626 # We want to translate 627 # 628 # :default :void :io 629 # 630 # into (pseudo-ish): 631 # 632 # expanded(:threads) :void expanded(:io) 633 # 634 # We accomplish this by "reverse, expand + filter, reverse". 635 for my $a (reverse(@args)) { 636 if (exists $TAGS{$a}) { 637 my $expanded = $class->_expand_tag($a); 638 push(@result, 639 # Remove duplicates after ... 640 grep { !$seen{$_}++ } 641 # we have stripped CORE:: (see above) 642 map { substr($_, 6) } 643 # We take the elements in reverse order 644 # (as @result be reversed later). 645 reverse(@{$expanded})); 646 } else { 647 # pass through - no filtering here for tags. 648 # 649 # The reason for not filtering tags cases like: 650 # 651 # ":default :void :io :void :threads" 652 # 653 # As we have reversed args, we see this as: 654 # 655 # ":threads :void :io :void* :default*" 656 # 657 # (Entries marked with "*" will be filtered out completely). When 658 # reversed again, this will be: 659 # 660 # ":io :void :threads" 661 # 662 # But we would rather want it to be: 663 # 664 # ":void :io :threads" or ":void :io :void :threads" 665 # 666 667 my $letter = substr($a, 0, 1); 668 if ($letter ne ':' && $a ne INSIST_TAG) { 669 next if $seen{$a}++; 670 if ($letter eq '!' and $seen{substr($a, 1)}++) { 671 my $name = substr($a, 1); 672 # People are being silly and doing: 673 # 674 # use autodie qw(!a a); 675 # 676 # Enjoy this little O(n) clean up... 677 @result = grep { $_ ne $name } @result; 678 } 679 } 680 push @result, $a; 681 } 682 } 683 # Reverse the result to restore the input order 684 return reverse(@result); 685} 686 687 688# NB: Perl::Critic's dump-autodie-tag-contents depends upon this 689# continuing to work. 690 691{ 692 # We assume that $TAGS{':all'} is pre-expanded and just fill it in 693 # from the beginning. 694 my %tag_cache = ( 695 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], 696 ); 697 698 # Expand a given tag (e.g. ":default") into a listref containing 699 # all sub names covered by that tag. Each sub is returned as 700 # "CORE::<name>" (i.e. "CORE::open" rather than "open"). 701 # 702 # NB: the listref must not be modified. 703 sub _expand_tag { 704 my ($class, $tag) = @_; 705 706 if (my $cached = $tag_cache{$tag}) { 707 return $cached; 708 } 709 710 if (not exists $TAGS{$tag}) { 711 croak "Invalid exception class $tag"; 712 } 713 714 my @to_process = @{$TAGS{$tag}}; 715 716 # If the tag is basically an alias of another tag (like e.g. ":2.11"), 717 # then just share the resulting reference with the original content (so 718 # we only pay for an extra reference for the alias memory-wise). 719 if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { 720 # We could do this for "non-tags" as well, but that only occurs 721 # once at the time of writing (":threads" => ["fork"]), so 722 # probably not worth it. 723 my $expanded = $class->_expand_tag($to_process[0]); 724 $tag_cache{$tag} = $expanded; 725 return $expanded; 726 } 727 728 my %seen = (); 729 my @taglist = (); 730 731 for my $item (@to_process) { 732 # substr is more efficient than m/^:/ for stuff like this, 733 # at the price of being a bit more verbose/low-level. 734 if (substr($item, 0, 1) eq ':') { 735 # Use recursion here to ensure we expand a tag at most once. 736 737 my $expanded = $class->_expand_tag($item); 738 push @taglist, grep { !$seen{$_}++ } @{$expanded}; 739 } else { 740 my $subname = "CORE::$item"; 741 push @taglist, $subname 742 unless $seen{$subname}++; 743 } 744 } 745 746 $tag_cache{$tag} = \@taglist; 747 748 return \@taglist; 749 750 } 751 752} 753 754# This is a backwards compatible version of _write_invocation. It's 755# recommended you don't use it. 756 757sub write_invocation { 758 my ($core, $call, $name, $void, @args) = @_; 759 760 return Fatal->_write_invocation( 761 $core, $call, $name, $void, 762 0, # Lexical flag 763 undef, # Sub, unused in legacy mode 764 undef, # Subref, unused in legacy mode. 765 @args 766 ); 767} 768 769# This version of _write_invocation is used internally. It's not 770# recommended you call it from external code, as the interface WILL 771# change in the future. 772 773sub _write_invocation { 774 775 my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; 776 777 if (@argvs == 1) { # No optional arguments 778 779 my @argv = @{$argvs[0]}; 780 shift @argv; 781 782 return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); 783 784 } else { 785 my $else = "\t"; 786 my (@out, @argv, $n); 787 while (@argvs) { 788 @argv = @{shift @argvs}; 789 $n = shift @argv; 790 791 my $condition = "\@_ == $n"; 792 793 if (@argv and $argv[-1] =~ /[#@]_/) { 794 # This argv ends with '@' in the prototype, so it matches 795 # any number of args >= the number of expressions in the 796 # argv. 797 $condition = "\@_ >= $n"; 798 } 799 800 push @out, "${else}if ($condition) {\n"; 801 802 $else = "\t} els"; 803 804 push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); 805 } 806 push @out, qq[ 807 } 808 die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; 809 ]; 810 811 return join '', @out; 812 } 813} 814 815 816# This is a slim interface to ensure backward compatibility with 817# anyone doing very foolish things with old versions of Fatal. 818 819sub one_invocation { 820 my ($core, $call, $name, $void, @argv) = @_; 821 822 return Fatal->_one_invocation( 823 $core, $call, $name, $void, 824 undef, # Sub. Unused in back-compat mode. 825 1, # Back-compat flag 826 undef, # Subref, unused in back-compat mode. 827 @argv 828 ); 829 830} 831 832# This is the internal interface that generates code. 833# NOTE: This interface WILL change in the future. Please do not 834# call this subroutine directly. 835 836# TODO: Whatever's calling this code has already looked up hints. Pass 837# them in, rather than look them up a second time. 838 839sub _one_invocation { 840 my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; 841 842 843 # If someone is calling us directly (a child class perhaps?) then 844 # they could try to mix void without enabling backwards 845 # compatibility. We just don't support this at all, so we gripe 846 # about it rather than doing something unwise. 847 848 if ($void and not $back_compat) { 849 Carp::confess("Internal error: :void mode not supported with $class"); 850 } 851 852 # @argv only contains the results of the in-built prototype 853 # function, and is therefore safe to interpolate in the 854 # code generators below. 855 856 # TODO - The following clobbers context, but that's what the 857 # old Fatal did. Do we care? 858 859 if ($back_compat) { 860 861 # Use Fatal qw(system) will never be supported. It generated 862 # a compile-time error with legacy Fatal, and there's no reason 863 # to support it when autodie does a better job. 864 865 if ($call eq 'CORE::system') { 866 return q{ 867 croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); 868 }; 869 } 870 871 local $" = ', '; 872 873 if ($void) { 874 return qq/return (defined wantarray)?$call(@argv): 875 $call(@argv) || Carp::croak("Can't $name(\@_)/ . 876 ($core ? ': $!' : ', \$! is \"$!\"') . '")' 877 } else { 878 return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . 879 ($core ? ': $!' : ', \$! is \"$!\"') . '")'; 880 } 881 } 882 883 # The name of our original function is: 884 # $call if the function is CORE 885 # $sub if our function is non-CORE 886 887 # The reason for this is that $call is what we're actually 888 # calling. For our core functions, this is always 889 # CORE::something. However for user-defined subs, we're about to 890 # replace whatever it is that we're calling; as such, we actually 891 # calling a subroutine ref. 892 893 my $human_sub_name = $core ? $call : $sub; 894 895 # Should we be testing to see if our result is defined, or 896 # just true? 897 898 my $use_defined_or; 899 900 my $hints; # All user-sub hints, including list hints. 901 902 if ( $core ) { 903 904 # Core hints are built into autodie. 905 906 $use_defined_or = exists ( $Use_defined_or{$call} ); 907 908 } 909 else { 910 911 # User sub hints are looked up using autodie::hints, 912 # since users may wish to add their own hints. 913 914 require autodie::hints; 915 916 $hints = autodie::hints->get_hints_for( $sref ); 917 918 # We'll look up the sub's fullname. This means we 919 # get better reports of where it came from in our 920 # error messages, rather than what imported it. 921 922 $human_sub_name = autodie::hints->sub_fullname( $sref ); 923 924 } 925 926 # Checks for special core subs. 927 928 if ($call eq 'CORE::system') { 929 930 # Leverage IPC::System::Simple if we're making an autodying 931 # system. 932 933 local $" = ", "; 934 935 # We need to stash $@ into $E, rather than using 936 # local $@ for the whole sub. If we don't then 937 # any exceptions from internal errors in autodie/Fatal 938 # will mysteriously disappear before propagating 939 # upwards. 940 941 return qq{ 942 my \$retval; 943 my \$E; 944 945 946 { 947 local \$@; 948 949 eval { 950 \$retval = IPC::System::Simple::system(@argv); 951 }; 952 953 \$E = \$@; 954 } 955 956 if (\$E) { 957 958 # TODO - This can't be overridden in child 959 # classes! 960 961 die autodie::exception::system->new( 962 function => q{CORE::system}, args => [ @argv ], 963 message => "\$E", errno => \$!, 964 ); 965 } 966 967 return \$retval; 968 }; 969 970 } 971 972 local $" = ', '; 973 974 # If we're going to throw an exception, here's the code to use. 975 my $die = qq{ 976 die $class->throw( 977 function => q{$human_sub_name}, args => [ @argv ], 978 pragma => q{$class}, errno => \$!, 979 context => \$context, return => \$retval, 980 eval_error => \$@ 981 ) 982 }; 983 984 if ($call eq 'CORE::flock') { 985 986 # flock needs special treatment. When it fails with 987 # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just 988 # means we couldn't get the lock right now. 989 990 require POSIX; # For POSIX::EWOULDBLOCK 991 992 local $@; # Don't blat anyone else's $@. 993 994 # Ensure that our vendor supports EWOULDBLOCK. If they 995 # don't (eg, Windows), then we use known values for its 996 # equivalent on other systems. 997 998 my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } 999 || $_EWOULDBLOCK{$^O} 1000 || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); 1001 my $EAGAIN = $EWOULDBLOCK; 1002 if ($try_EAGAIN) { 1003 $EAGAIN = eval { POSIX::EAGAIN(); } 1004 || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); 1005 } 1006 1007 require Fcntl; # For Fcntl::LOCK_NB 1008 1009 return qq{ 1010 1011 my \$context = wantarray() ? "list" : "scalar"; 1012 1013 # Try to flock. If successful, return it immediately. 1014 1015 my \$retval = $call(@argv); 1016 return \$retval if \$retval; 1017 1018 # If we failed, but we're using LOCK_NB and 1019 # returned EWOULDBLOCK, it's not a real error. 1020 1021 if (\$_[1] & Fcntl::LOCK_NB() and 1022 (\$! == $EWOULDBLOCK or 1023 ($try_EAGAIN and \$! == $EAGAIN ))) { 1024 return \$retval; 1025 } 1026 1027 # Otherwise, we failed. Die noisily. 1028 1029 $die; 1030 1031 }; 1032 } 1033 1034 if ($call eq 'CORE::kill') { 1035 1036 return qq[ 1037 1038 my \$num_things = \@_ - $Returns_num_things_changed{$call}; 1039 my \$context = ! defined wantarray() ? 'void' : 'scalar'; 1040 my \$signal = \$_[0]; 1041 my \$retval = $call(@argv); 1042 my \$sigzero = looks_like_number( \$signal ) && \$signal == 0; 1043 1044 if ( ( \$sigzero && \$context eq 'void' ) 1045 or ( ! \$sigzero && \$retval != \$num_things ) ) { 1046 1047 $die; 1048 } 1049 1050 return \$retval; 1051 ]; 1052 } 1053 1054 if (exists $Returns_num_things_changed{$call}) { 1055 1056 # Some things return the number of things changed (like 1057 # chown, kill, chmod, etc). We only consider these successful 1058 # if *all* the things are changed. 1059 1060 return qq[ 1061 my \$num_things = \@_ - $Returns_num_things_changed{$call}; 1062 my \$retval = $call(@argv); 1063 1064 if (\$retval != \$num_things) { 1065 1066 # We need \$context to throw an exception. 1067 # It's *always* set to scalar, because that's how 1068 # autodie calls chown() above. 1069 1070 my \$context = "scalar"; 1071 $die; 1072 } 1073 1074 return \$retval; 1075 ]; 1076 } 1077 1078 # AFAIK everything that can be given an unopned filehandle 1079 # will fail if it tries to use it, so we don't really need 1080 # the 'unopened' warning class here. Especially since they 1081 # then report the wrong line number. 1082 1083 # Other warnings are disabled because they produce excessive 1084 # complaints from smart-match hints under 5.10.1. 1085 1086 my $code = qq[ 1087 no warnings qw(unopened uninitialized numeric); 1088 no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; 1089 1090 if (wantarray) { 1091 my \@results = $call(@argv); 1092 my \$retval = \\\@results; 1093 my \$context = "list"; 1094 1095 ]; 1096 1097 my $retval_action = $Retval_action{$call} || ''; 1098 1099 if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { 1100 1101 # NB: Subroutine hints are passed as a full list. 1102 # This differs from the 5.10.0 smart-match behaviour, 1103 # but means that context unaware subroutines can use 1104 # the same hints in both list and scalar context. 1105 1106 $code .= qq{ 1107 if ( \$hints->{list}->(\@results) ) { $die }; 1108 }; 1109 } 1110 elsif ( PERL510 and $hints ) { 1111 $code .= qq{ 1112 if ( \@results ~~ \$hints->{list} ) { $die }; 1113 }; 1114 } 1115 elsif ( $hints ) { 1116 croak sprintf(ERROR_58_HINTS, 'list', $sub); 1117 } 1118 else { 1119 $code .= qq{ 1120 # An empty list, or a single undef is failure 1121 if (! \@results or (\@results == 1 and ! defined \$results[0])) { 1122 $die; 1123 } 1124 } 1125 } 1126 1127 # Tidy up the end of our wantarray call. 1128 1129 $code .= qq[ 1130 return \@results; 1131 } 1132 ]; 1133 1134 1135 # Otherwise, we're in scalar context. 1136 # We're never in a void context, since we have to look 1137 # at the result. 1138 1139 $code .= qq{ 1140 my \$retval = $call(@argv); 1141 my \$context = "scalar"; 1142 }; 1143 1144 if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { 1145 1146 # We always call code refs directly, since that always 1147 # works in 5.8.x, and always works in 5.10.1 1148 1149 return $code .= qq{ 1150 if ( \$hints->{scalar}->(\$retval) ) { $die }; 1151 $retval_action 1152 return \$retval; 1153 }; 1154 1155 } 1156 elsif (PERL510 and $hints) { 1157 return $code . qq{ 1158 1159 if ( \$retval ~~ \$hints->{scalar} ) { $die }; 1160 $retval_action 1161 return \$retval; 1162 }; 1163 } 1164 elsif ( $hints ) { 1165 croak sprintf(ERROR_58_HINTS, 'scalar', $sub); 1166 } 1167 1168 return $code . 1169 ( $use_defined_or ? qq{ 1170 1171 $die if not defined \$retval; 1172 $retval_action 1173 return \$retval; 1174 1175 } : qq{ 1176 1177 $retval_action 1178 return \$retval || $die; 1179 1180 } ) ; 1181 1182} 1183 1184# This returns the old copy of the sub, so we can 1185# put it back at end of scope. 1186 1187# TODO : Check to make sure prototypes are restored correctly. 1188 1189# TODO: Taking a huge list of arguments is awful. Rewriting to 1190# take a hash would be lovely. 1191 1192# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 1193 1194sub _make_fatal { 1195 my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; 1196 my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type); 1197 my $ini = $sub; 1198 my $name = $sub; 1199 1200 1201 if (index($sub, '::') == -1) { 1202 $sub = "${pkg}::$sub"; 1203 if (substr($name, 0, 1) eq '&') { 1204 $name = substr($name, 1); 1205 } 1206 } else { 1207 $name =~ s/.*:://; 1208 } 1209 1210 1211 # Figure if we're using lexical or package semantics and 1212 # twiddle the appropriate bits. 1213 1214 if (not $lexical) { 1215 $Package_Fatal{$sub} = 1; 1216 } 1217 1218 # TODO - We *should* be able to do skipping, since we know when 1219 # we've lexicalised / unlexicalised a subroutine. 1220 1221 1222 warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; 1223 croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; 1224 1225 if (defined(&$sub)) { # user subroutine 1226 1227 # NOTE: Previously we would localise $@ at this point, so 1228 # the following calls to eval {} wouldn't interfere with anything 1229 # that's already in $@. Unfortunately, it would also stop 1230 # any of our croaks from triggering(!), which is even worse. 1231 1232 # This could be something that we've fatalised that 1233 # was in core. 1234 1235 # Store the current sub in case we need to restore it. 1236 $sref = \&$sub; 1237 1238 if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { 1239 1240 # Something we previously made Fatal that was core. 1241 # This is safe to replace with an autodying to core 1242 # version. 1243 1244 $core = 1; 1245 $call = "CORE::$name"; 1246 $proto = $CORE_prototype_cache{$call}; 1247 1248 # We return our $sref from this subroutine later 1249 # on, indicating this subroutine should be placed 1250 # back when we're finished. 1251 1252 1253 1254 } else { 1255 1256 # If this is something we've already fatalised or played with, 1257 # then look-up the name of the original sub for the rest of 1258 # our processing. 1259 1260 if (exists($Is_fatalised_sub{$sref})) { 1261 # $sub is one of our wrappers around a CORE sub or a 1262 # user sub. Instead of wrapping our wrapper, lets just 1263 # generate a new wrapper for the original sub. 1264 # - NB: the current wrapper might be for a different class 1265 # than the one we are generating now (e.g. some limited 1266 # mixing between use Fatal + use autodie can occur). 1267 # - Even for nested autodie, we need this as the leak guards 1268 # differ. 1269 my $s = $Is_fatalised_sub{$sref}; 1270 if (defined($s)) { 1271 # It is a wrapper for a user sub 1272 $sub = $s; 1273 } else { 1274 # It is a wrapper for a CORE:: sub 1275 $core = 1; 1276 $call = "CORE::$name"; 1277 $proto = $CORE_prototype_cache{$call}; 1278 } 1279 } 1280 1281 # A regular user sub, or a user sub wrapping a 1282 # core sub. 1283 1284 if (!$core) { 1285 # A non-CORE sub might have hints and such... 1286 $proto = prototype($sref); 1287 $call = '&$sref'; 1288 require autodie::hints; 1289 1290 $hints = autodie::hints->get_hints_for( $sref ); 1291 1292 # If we've insisted on hints, but don't have them, then 1293 # bail out! 1294 1295 if ($insist and not $hints) { 1296 croak(sprintf(ERROR_NOHINTS, $name)); 1297 } 1298 1299 # Otherwise, use the default hints if we don't have 1300 # any. 1301 1302 $hints ||= autodie::hints::DEFAULT_HINTS(); 1303 } 1304 1305 } 1306 1307 } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { 1308 # Stray user subroutine 1309 croak(sprintf(ERROR_NOTSUB,$sub)); 1310 1311 } elsif ($name eq 'system') { 1312 1313 # If we're fatalising system, then we need to load 1314 # helper code. 1315 1316 # The business with $E is to avoid clobbering our caller's 1317 # $@, and to avoid $@ being localised when we croak. 1318 1319 my $E; 1320 1321 { 1322 local $@; 1323 1324 eval { 1325 require IPC::System::Simple; # Only load it if we need it. 1326 require autodie::exception::system; 1327 }; 1328 $E = $@; 1329 } 1330 1331 if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } 1332 1333 # Make sure we're using a recent version of ISS that actually 1334 # support fatalised system. 1335 if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { 1336 croak sprintf( 1337 ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, 1338 $IPC::System::Simple::VERSION 1339 ); 1340 } 1341 1342 $call = 'CORE::system'; 1343 $core = 1; 1344 1345 } elsif ($name eq 'exec') { 1346 # Exec doesn't have a prototype. We don't care. This 1347 # breaks the exotic form with lexical scope, and gives 1348 # the regular form a "do or die" behavior as expected. 1349 1350 $call = 'CORE::exec'; 1351 $core = 1; 1352 1353 } else { # CORE subroutine 1354 $call = "CORE::$name"; 1355 if (exists($CORE_prototype_cache{$call})) { 1356 $proto = $CORE_prototype_cache{$call}; 1357 } else { 1358 my $E; 1359 { 1360 local $@; 1361 $proto = eval { prototype $call }; 1362 $E = $@; 1363 } 1364 croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; 1365 croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; 1366 $CORE_prototype_cache{$call} = $proto; 1367 } 1368 $core = 1; 1369 } 1370 1371 # TODO: This caching works, but I don't like using $void and 1372 # $lexical as keys. In particular, I suspect our code may end up 1373 # wrapping already wrapped code when autodie and Fatal are used 1374 # together. 1375 1376 # NB: We must use '$sub' (the name plus package) and not 1377 # just '$name' (the short name) here. Failing to do so 1378 # results code that's in the wrong package, and hence has 1379 # access to the wrong package filehandles. 1380 1381 $cache = $Cached_fatalised_sub{$class}{$sub}; 1382 if ($lexical) { 1383 $cache_type = CACHE_AUTODIE_LEAK_GUARD; 1384 } else { 1385 $cache_type = CACHE_FATAL_WRAPPER; 1386 $cache_type = CACHE_FATAL_VOID if $void; 1387 } 1388 1389 if (my $subref = $cache->{$cache_type}) { 1390 $install_subs->{$name} = $subref; 1391 return $sref; 1392 } 1393 1394 # If our subroutine is reusable (ie, not package depdendent), 1395 # then check to see if we've got a cached copy, and use that. 1396 # See RT #46984. (Thanks to Niels Thykier for being awesome!) 1397 1398 if ($core && exists $reusable_builtins{$call}) { 1399 # For non-lexical subs, we can just use this cache directly 1400 # - for lexical variants, we need a leak guard as well. 1401 $code = $reusable_builtins{$call}{$lexical}; 1402 if (!$lexical && defined($code)) { 1403 $install_subs->{$name} = $code; 1404 return $sref; 1405 } 1406 } 1407 1408 if (!($lexical && $core) && !defined($code)) { 1409 # No code available, generate it now. 1410 my $wrapper_pkg = $pkg; 1411 $wrapper_pkg = undef if (exists($reusable_builtins{$call})); 1412 $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, 1413 $void, $lexical, $sub, $sref, 1414 $hints, $proto); 1415 if (!defined($wrapper_pkg)) { 1416 # cache it so we don't recompile this part again 1417 $reusable_builtins{$call}{$lexical} = $code; 1418 } 1419 } 1420 1421 # Now we need to wrap our fatalised sub inside an itty bitty 1422 # closure, which can detect if we've leaked into another file. 1423 # Luckily, we only need to do this for lexical (autodie) 1424 # subs. Fatal subs can leak all they want, it's considered 1425 # a "feature" (or at least backwards compatible). 1426 1427 # TODO: Cache our leak guards! 1428 1429 # TODO: This is pretty hairy code. A lot more tests would 1430 # be really nice for this. 1431 1432 my $installed_sub = $code; 1433 1434 if ($lexical) { 1435 $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, 1436 $pkg, $proto); 1437 } 1438 1439 $cache->{$cache_type} = $code; 1440 1441 $install_subs->{$name} = $installed_sub; 1442 1443 # Cache that we've now overridden this sub. If we get called 1444 # again, we may need to find that find subroutine again (eg, for hints). 1445 1446 $Is_fatalised_sub{$installed_sub} = $sref; 1447 1448 return $sref; 1449 1450} 1451 1452# This subroutine exists primarily so that child classes can override 1453# it to point to their own exception class. Doing this is significantly 1454# less complex than overriding throw() 1455 1456sub exception_class { return "autodie::exception" }; 1457 1458{ 1459 my %exception_class_for; 1460 my %class_loaded; 1461 1462 sub throw { 1463 my ($class, @args) = @_; 1464 1465 # Find our exception class if we need it. 1466 my $exception_class = 1467 $exception_class_for{$class} ||= $class->exception_class; 1468 1469 if (not $class_loaded{$exception_class}) { 1470 if ($exception_class =~ /[^\w:']/) { 1471 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."; 1472 } 1473 1474 # Alas, Perl does turn barewords into modules unless they're 1475 # actually barewords. As such, we're left doing a string eval 1476 # to make sure we load our file correctly. 1477 1478 my $E; 1479 1480 { 1481 local $@; # We can't clobber $@, it's wrong! 1482 my $pm_file = $exception_class . ".pm"; 1483 $pm_file =~ s{ (?: :: | ' ) }{/}gx; 1484 eval { require $pm_file }; 1485 $E = $@; # Save $E despite ending our local. 1486 } 1487 1488 # We need quotes around $@ to make sure it's stringified 1489 # while still in scope. Without them, we run the risk of 1490 # $@ having been cleared by us exiting the local() block. 1491 1492 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; 1493 1494 $class_loaded{$exception_class}++; 1495 1496 } 1497 1498 return $exception_class->new(@args); 1499 } 1500} 1501 1502# Creates and returns a leak guard (with prototype if needed). 1503sub _make_leak_guard { 1504 my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_; 1505 1506 # The leak guard is rather lengthly (in fact it makes up the most 1507 # of _make_leak_guard). It is possible to split it into a large 1508 # "generic" part and a small wrapper with call-specific 1509 # information. This was done in v2.19 and profiling suggested 1510 # that we ended up using a substantial amount of runtime in "goto" 1511 # between the leak guard(s) and the final sub. Therefore, the two 1512 # parts were merged into one to reduce the runtime overhead. 1513 1514 my $leak_guard = sub { 1515 my $caller_level = 0; 1516 my $caller; 1517 1518 while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { 1519 1520 # If our filename is actually an eval, and we 1521 # reach it, then go to our autodying code immediatately. 1522 1523 last if ($caller eq $filename); 1524 $caller_level++; 1525 } 1526 1527 # We're now out of the eval stack. 1528 1529 if ($caller eq $filename) { 1530 # No leak, call the wrapper. NB: In this case, it doesn't 1531 # matter if it is a CORE sub or not. 1532 if (!defined($wrapped_sub)) { 1533 # CORE sub that we were too lazy to compile when we 1534 # created this leak guard. 1535 die "$call is not CORE::<something>" 1536 if substr($call, 0, 6) ne 'CORE::'; 1537 1538 my $name = substr($call, 6); 1539 my $sub = $name; 1540 my $lexical = 1; 1541 my $wrapper_pkg = $pkg; 1542 my $code; 1543 if (exists($reusable_builtins{$call})) { 1544 $code = $reusable_builtins{$call}{$lexical}; 1545 $wrapper_pkg = undef; 1546 } 1547 if (!defined($code)) { 1548 $code = $class->_compile_wrapper($wrapper_pkg, 1549 1, # core 1550 $call, 1551 $name, 1552 0, # void 1553 $lexical, 1554 $sub, 1555 undef, # subref (not used for core) 1556 undef, # hints (not used for core) 1557 $proto); 1558 1559 if (!defined($wrapper_pkg)) { 1560 # cache it so we don't recompile this part again 1561 $reusable_builtins{$call}{$lexical} = $code; 1562 } 1563 } 1564 # As $wrapped_sub is "closed over", updating its value will 1565 # be "remembered" for the next call. 1566 $wrapped_sub = $code; 1567 } 1568 goto $wrapped_sub; 1569 } 1570 1571 # We leaked, time to call the original function. 1572 # - for non-core functions that will be $orig_sub 1573 # - for CORE functions, $orig_sub may be a trampoline 1574 goto $orig_sub if defined($orig_sub); 1575 1576 # We are wrapping a CORE sub and we do not have a trampoline 1577 # yet. 1578 # 1579 # If we've cached a trampoline, then use it. Usually only 1580 # resuable subs will have cache hits, but non-reusuably ones 1581 # can get it as well in (very) rare cases. It is mostly in 1582 # cases where a package uses autodie multiple times and leaks 1583 # from multiple places. Possibly something like: 1584 # 1585 # package Pkg::With::LeakyCode; 1586 # sub a { 1587 # use autodie; 1588 # code_that_leaks(); 1589 # } 1590 # 1591 # sub b { 1592 # use autodie; 1593 # more_leaky_code(); 1594 # } 1595 # 1596 # Note that we use "Fatal" as package name for reusable subs 1597 # because A) that allows us to trivially re-use the 1598 # trampolines as well and B) because the reusable sub is 1599 # compiled into "package Fatal" as well. 1600 1601 $pkg = 'Fatal' if exists $reusable_builtins{$call}; 1602 $orig_sub = $Trampoline_cache{$pkg}{$call}; 1603 1604 if (not $orig_sub) { 1605 # If we don't have a trampoline, we need to build it. 1606 # 1607 # We only generate trampolines when we need them, and 1608 # we can cache them by subroutine + package. 1609 # 1610 # As $orig_sub is "closed over", updating its value will 1611 # be "remembered" for the next call. 1612 1613 $orig_sub = make_core_trampoline($call, $pkg, $proto); 1614 1615 # We still cache it despite remembering it in $orig_sub as 1616 # well. In particularly, we rely on this to avoid 1617 # re-compiling the reusable trampolines. 1618 $Trampoline_cache{$pkg}{$call} = $orig_sub; 1619 } 1620 1621 # Bounce to our trampoline, which takes us to our core sub. 1622 goto $orig_sub; 1623 }; # <-- end of leak guard 1624 1625 # If there is a prototype on the original sub, copy it to the leak 1626 # guard. 1627 if (defined $proto) { 1628 # The "\&" may appear to be redundant but set_prototype 1629 # croaks when it is removed. 1630 set_prototype(\&$leak_guard, $proto); 1631 } 1632 1633 return $leak_guard; 1634} 1635 1636sub _compile_wrapper { 1637 my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; 1638 my $real_proto = ''; 1639 my @protos; 1640 my $code; 1641 if (defined $proto) { 1642 $real_proto = " ($proto)"; 1643 } else { 1644 $proto = '@'; 1645 } 1646 1647 @protos = fill_protos($proto); 1648 $code = qq[ 1649 sub$real_proto { 1650 ]; 1651 1652 if (!$lexical) { 1653 $code .= q[ 1654 local($", $!) = (', ', 0); 1655 ]; 1656 } 1657 1658 # Don't have perl whine if exec fails, since we'll be handling 1659 # the exception now. 1660 $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; 1661 1662 $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, 1663 $sub, $sref, @protos); 1664 $code .= "}\n"; 1665 warn $code if $Debug; 1666 1667 # I thought that changing package was a monumental waste of 1668 # time for CORE subs, since they'll always be the same. However 1669 # that's not the case, since they may refer to package-based 1670 # filehandles (eg, with open). 1671 # 1672 # The %reusable_builtins hash defines ones we can aggressively 1673 # cache as they never depend upon package-based symbols. 1674 1675 my $E; 1676 1677 { 1678 no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... 1679 local $@; 1680 if (defined($wrapper_pkg)) { 1681 $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic 1682 } else { 1683 $code = eval("require Carp; $code"); ## no critic 1684 1685 } 1686 $E = $@; 1687 } 1688 1689 if (not $code) { 1690 my $true_name = $core ? $call : $sub; 1691 croak("Internal error in autodie/Fatal processing $true_name: $E"); 1692 } 1693 return $code; 1694} 1695 1696# For some reason, dying while replacing our subs doesn't 1697# kill our calling program. It simply stops the loading of 1698# autodie and keeps going with everything else. The _autocroak 1699# sub allows us to die with a vengeance. It should *only* ever be 1700# used for serious internal errors, since the results of it can't 1701# be captured. 1702 1703sub _autocroak { 1704 warn Carp::longmess(@_); 1705 exit(255); # Ugh! 1706} 1707 17081; 1709 1710__END__ 1711 1712=head1 NAME 1713 1714Fatal - Replace functions with equivalents which succeed or die 1715 1716=head1 SYNOPSIS 1717 1718 use Fatal qw(open close); 1719 1720 open(my $fh, "<", $filename); # No need to check errors! 1721 1722 use File::Copy qw(move); 1723 use Fatal qw(move); 1724 1725 move($file1, $file2); # No need to check errors! 1726 1727 sub juggle { . . . } 1728 Fatal->import('juggle'); 1729 1730=head1 BEST PRACTICE 1731 1732B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use 1733L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping, 1734throws real exception objects, and provides much nicer error messages. 1735 1736The use of C<:void> with Fatal is discouraged. 1737 1738=head1 DESCRIPTION 1739 1740C<Fatal> provides a way to conveniently replace 1741functions which normally return a false value when they fail with 1742equivalents which raise exceptions if they are not successful. This 1743lets you use these functions without having to test their return 1744values explicitly on each call. Exceptions can be caught using 1745C<eval{}>. See L<perlfunc> and L<perlvar> for details. 1746 1747The do-or-die equivalents are set up simply by calling Fatal's 1748C<import> routine, passing it the names of the functions to be 1749replaced. You may wrap both user-defined functions and overridable 1750CORE operators (except C<exec>, C<system>, C<print>, or any other 1751built-in that cannot be expressed via prototypes) in this way. 1752 1753If the symbol C<:void> appears in the import list, then functions 1754named later in that import list raise an exception only when 1755these are called in void context--that is, when their return 1756values are ignored. For example 1757 1758 use Fatal qw/:void open close/; 1759 1760 # properly checked, so no exception raised on error 1761 if (not open(my $fh, '<', '/bogotic') { 1762 warn "Can't open /bogotic: $!"; 1763 } 1764 1765 # not checked, so error raises an exception 1766 close FH; 1767 1768The use of C<:void> is discouraged, as it can result in exceptions 1769not being thrown if you I<accidentally> call a method without 1770void context. Use L<autodie> instead if you need to be able to 1771disable autodying/Fatal behaviour for a small block of code. 1772 1773=head1 DIAGNOSTICS 1774 1775=over 4 1776 1777=item Bad subroutine name for Fatal: %s 1778 1779You've called C<Fatal> with an argument that doesn't look like 1780a subroutine name, nor a switch that this version of Fatal 1781understands. 1782 1783=item %s is not a Perl subroutine 1784 1785You've asked C<Fatal> to try and replace a subroutine which does not 1786exist, or has not yet been defined. 1787 1788=item %s is neither a builtin, nor a Perl subroutine 1789 1790You've asked C<Fatal> to replace a subroutine, but it's not a Perl 1791built-in, and C<Fatal> couldn't find it as a regular subroutine. 1792It either doesn't exist or has not yet been defined. 1793 1794=item Cannot make the non-overridable %s fatal 1795 1796You've tried to use C<Fatal> on a Perl built-in that can't be 1797overridden, such as C<print> or C<system>, which means that 1798C<Fatal> can't help you, although some other modules might. 1799See the L</"SEE ALSO"> section of this documentation. 1800 1801=item Internal error: %s 1802 1803You've found a bug in C<Fatal>. Please report it using 1804the C<perlbug> command. 1805 1806=back 1807 1808=head1 BUGS 1809 1810C<Fatal> clobbers the context in which a function is called and always 1811makes it a scalar context, except when the C<:void> tag is used. 1812This problem does not exist in L<autodie>. 1813 1814"Used only once" warnings can be generated when C<autodie> or C<Fatal> 1815is used with package filehandles (eg, C<FILE>). It's strongly recommended 1816you use scalar filehandles instead. 1817 1818=head1 AUTHOR 1819 1820Original module by Lionel Cons (CERN). 1821 1822Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>. 1823 1824L<autodie> support, bugfixes, extended diagnostics, C<system> 1825support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au> 1826 1827=head1 LICENSE 1828 1829This module is free software, you may distribute it under the 1830same terms as Perl itself. 1831 1832=head1 SEE ALSO 1833 1834L<autodie> for a nicer way to use lexical Fatal. 1835 1836L<IPC::System::Simple> for a similar idea for calls to C<system()> 1837and backticks. 1838 1839=for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG 1840 1841=cut 1842