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