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