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