diff options
Diffstat (limited to 'cpan/autodie/lib/Fatal.pm')
| -rw-r--r-- | cpan/autodie/lib/Fatal.pm | 402 |
1 files changed, 284 insertions, 118 deletions
diff --git a/cpan/autodie/lib/Fatal.pm b/cpan/autodie/lib/Fatal.pm index c6a3d1b329..8c6536b802 100644 --- a/cpan/autodie/lib/Fatal.pm +++ b/cpan/autodie/lib/Fatal.pm @@ -1,11 +1,14 @@ package Fatal; +# ABSTRACT: Replace functions with equivalents which succeed or die + use 5.008; # 5.8.x needed for autodie use Carp; use strict; use warnings; use Tie::RefHash; # To cache subroutine refs use Config; +use Scalar::Util qw(set_prototype); use constant PERL510 => ( $] >= 5.010 ); @@ -39,8 +42,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; -# All the Fatal/autodie modules share the same version number. -our $VERSION = '2.13'; +our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -65,10 +67,10 @@ my %TAGS = ( read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], ':file' => [qw(open close flock sysopen fcntl fileno binmode - ioctl truncate chmod)], + ioctl truncate)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir - symlink rmdir readlink umask)], - ':ipc' => [qw(:msg :semaphore :shm pipe)], + symlink rmdir readlink umask chmod chown utime)], + ':ipc' => [qw(:msg :semaphore :shm pipe kill)], ':msg' => [qw(msgctl msgget msgrcv msgsnd)], ':threads' => [qw(fork)], ':semaphore'=>[qw(semctl semget semop)], @@ -89,10 +91,18 @@ my %TAGS = ( ':default' => [qw(:io :threads)], - # Everything in v2.07 and brefore. This was :default less chmod. - ':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread + # Everything in v2.07 and brefore. This was :default less chmod and chown + ':v207' => [qw(:threads :dbm :socket read seek sysread syswrite sysseek open close flock sysopen fcntl fileno - binmode ioctl truncate)], + binmode ioctl truncate opendir closedir chdir link unlink + rename mkdir symlink rmdir readlink umask + :msg :semaphore :shm pipe)], + + # Chmod was added in 2.13 + ':v213' => [qw(:v207 chmod)], + + # chown, utime, kill were added in 2.14 + ':v214' => [qw(:v213 chown utime kill)], # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. @@ -113,15 +123,22 @@ my %TAGS = ( ':2.06' => [qw(:v207)], ':2.06_01' => [qw(:v207)], ':2.07' => [qw(:v207)], # Last release without chmod - ':2.08' => [qw(:default)], - ':2.09' => [qw(:default)], - ':2.10' => [qw(:default)], - ':2.11' => [qw(:default)], - ':2.12' => [qw(:default)], - ':2.13' => [qw(:default)], + ':2.08' => [qw(:v213)], + ':2.09' => [qw(:v213)], + ':2.10' => [qw(:v213)], + ':2.11' => [qw(:v213)], + ':2.12' => [qw(:v213)], + ':2.13' => [qw(:v213)], + ':2.14' => [qw(:default)], + ':2.15' => [qw(:default)], + ':2.16' => [qw(:default)], + ':2.17' => [qw(:default)], + ':2.18' => [qw(:default)], + ':2.19' => [qw(:default)], ); # chmod was only introduced in 2.07 +# chown was only introduced in 2.14 $TAGS{':all'} = [ keys %TAGS ]; @@ -147,10 +164,17 @@ my %Use_defined_or; CORE::umask )} = (); +# Some functions can return true because they changed *some* things, but +# not all of them. This is a list of offending functions, and how many +# items to subtract from @_ to determine the "success" value they return. -# A snippet of code to apply the open pragma to a handle - - +my %Returns_num_things_changed = ( + 'CORE::chmod' => 1, + 'CORE::chown' => 2, + 'CORE::kill' => 1, # TODO: Could this return anything on negative args? + 'CORE::unlink' => 0, + 'CORE::utime' => 2, +); # Optional actions to take on the return value before returning it. @@ -199,6 +223,45 @@ my %Retval_action = ( }, ); +my %reusable_builtins; + +# "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can +# take file and directory handles, which are package depedent." +# +# You would be correct, except that prototype() returns signatures which don't +# allow for passing of globs, and nobody's complained about that. You can +# still use \*FILEHANDLE, but that results in a reference coming through, +# and it's already pointing to the filehandle in the caller's packge, so +# it's all okay. + +@reusable_builtins{qw( + CORE::fork + CORE::kill + CORE::truncate + CORE::chdir + CORE::link + CORE::unlink + CORE::rename + CORE::mkdir + CORE::symlink + CORE::rmdir + CORE::readlink + CORE::umask + CORE::chmod + CORE::chown + CORE::utime + CORE::msgctl + CORE::msgget + CORE::msgrcv + CORE::msgsnd + CORE::semctl + CORE::semget + CORE::semop + CORE::shmctl + CORE::shmget + CORE::shmread +)} = (); + # Cached_fatalised_sub caches the various versions of our # fatalised subs as they're produced. This means we don't # have to build our own replacement of CORE::open and friends @@ -226,6 +289,11 @@ my %Original_user_sub = (); my %Is_fatalised_sub = (); tie %Is_fatalised_sub, 'Tie::RefHash'; +# Our trampoline cache allows us to cache trampolines which are used to +# bounce leaked wrapped core subroutines to their actual core counterparts. + +my %Trampoline_cache; + # We use our package in a few hash-keys. Having it in a scalar is # convenient. The "guard $PACKAGE" string is used as a key when # setting up lexical guards. @@ -278,7 +346,7 @@ sub import { # Thiese subs will get unloaded at the end of lexical scope. my %unload_later; - # This hash helps us track if we've alredy done work. + # This hash helps us track if we've already done work. my %done_this; # NB: we're using while/shift rather than foreach, since @@ -702,7 +770,7 @@ sub _one_invocation { # $call if the function is CORE # $sub if our function is non-CORE - # The reason for this is that $call is what we're actualling + # The reason for this is that $call is what we're actually # calling. For our core functions, this is always # CORE::something. However for user-defined subs, we're about to # replace whatever it is that we're calling; as such, we actually @@ -753,7 +821,7 @@ sub _one_invocation { # We need to stash $@ into $E, rather than using # local $@ for the whole sub. If we don't then # any exceptions from internal errors in autodie/Fatal - # will mysteriously disappear before propogating + # will mysteriously disappear before propagating # upwards. return qq{ @@ -849,6 +917,30 @@ sub _one_invocation { }; } + if (exists $Returns_num_things_changed{$call}) { + + # Some things return the number of things changed (like + # chown, kill, chmod, etc). We only consider these successful + # if *all* the things are changed. + + return qq[ + my \$num_things = \@_ - $Returns_num_things_changed{$call}; + my \$retval = $call(@argv); + + if (\$retval != \$num_things) { + + # We need \$context to throw an exception. + # It's *always* set to scalar, because that's how + # autodie calls chown() above. + + my \$context = "scalar"; + $die; + } + + return \$retval; + ]; + } + # AFAIK everything that can be given an unopned filehandle # will fail if it tries to use it, so we don't really need # the 'unopened' warning class here. Especially since they @@ -1088,7 +1180,7 @@ sub _make_fatal { } elsif ($name eq 'exec') { # Exec doesn't have a prototype. We don't care. This # breaks the exotic form with lexical scope, and gives - # the regular form a "do or die" beaviour as expected. + # the regular form a "do or die" behavior as expected. $call = 'CORE::exec'; $name = 'exec'; @@ -1107,6 +1199,7 @@ sub _make_fatal { $call = "CORE::$name"; } + if (defined $proto) { $real_proto = " ($proto)"; } else { @@ -1131,43 +1224,70 @@ sub _make_fatal { return $sref; } - $code = qq[ - sub$real_proto { - local(\$", \$!) = (', ', 0); # TODO - Why do we do this? - ]; - - # Don't have perl whine if exec fails, since we'll be handling - # the exception now. - $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; + # If our subroutine is reusable (ie, not package depdendent), + # then check to see if we've got a cached copy, and use that. + # See RT #46984. (Thanks to Niels Thykier for being awesome!) + + if ($core && exists $reusable_builtins{$call}) { + # For non-lexical subs, we can just use this cache directly + # - for lexical variants, we need a leak guard as well. + $code = $reusable_builtins{$call}{$lexical}; + if (!$lexical && defined($code)) { + $class->_install_subs($pkg, { $name => $code }); + return $sref; + } + } my @protos = fill_protos($proto); - $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos); - $code .= "}\n"; - warn $code if $Debug; - - # I thought that changing package was a monumental waste of - # time for CORE subs, since they'll always be the same. However - # that's not the case, since they may refer to package-based - # filehandles (eg, with open). - # - # There is potential to more aggressively cache core subs - # that we know will never want to interact with package variables - # and filehandles. - { - no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + if (!defined($code)) { + # No code available, generate it now. - my $E; + $code = qq[ + sub$real_proto { + local(\$", \$!) = (', ', 0); # TODO - Why do we do this? + ]; + + # Don't have perl whine if exec fails, since we'll be handling + # the exception now. + $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; + + $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, + $sub, $sref, @protos); + $code .= "}\n"; + warn $code if $Debug; + + # I thought that changing package was a monumental waste of + # time for CORE subs, since they'll always be the same. However + # that's not the case, since they may refer to package-based + # filehandles (eg, with open). + # + # The %reusable_builtins hash defines ones we can aggressively + # cache as they never depend upon package-based symbols. { - local $@; - $code = eval("package $pkg; require Carp; $code"); ## no critic - $E = $@; - } + no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + + my $E; - if (not $code) { - croak("Internal error in autodie/Fatal processing $true_name: $E"); + { + local $@; + if (!exists($reusable_builtins{$call})) { + $code = eval("package $pkg; require Carp; $code"); ## no critic + } else { + $code = eval("require Carp; $code"); ## no critic + if (exists $reusable_builtins{$call}) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + $E = $@; + } + if (not $code) { + croak("Internal error in autodie/Fatal processing $true_name: $E"); + + } } } @@ -1185,74 +1305,20 @@ sub _make_fatal { my $leak_guard; if ($lexical) { + # Do a little dance because set_prototype does not accept code + # refs (i.e. "my $s = sub {}; set_prototype($s, '$$);" fails) + if ($real_proto ne '') { + $leak_guard = set_prototype(sub { + unshift @_, [$filename, $code, $sref, $call, \@protos, $pkg]; + goto \&_leak_guard; + }, $proto); - $leak_guard = qq< - package $pkg; - - sub$real_proto { - - # If we're inside a string eval, we can end up with a - # whacky filename. The following code allows autodie - # to propagate correctly into string evals. - - my \$caller_level = 0; - - my \$caller; - - while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) { - - # If our filename is actually an eval, and we - # reach it, then go to our autodying code immediatately. - - goto &\$code if (\$caller eq \$filename); - \$caller_level++; - } - - # We're now out of the eval stack. - - # If we're called from the correct file, then use the - # autodying code. - goto &\$code if ((caller \$caller_level)[1] eq \$filename); - - # Oh bother, we've leaked into another file. Call the - # original code. Note that \$sref may actually be a - # reference to a Fatalised version of a core built-in. - # That's okay, because Fatal *always* leaks between files. - - goto &\$sref if \$sref; - >; - - - # If we're here, it must have been a core subroutine called. - # Warning: The following code may disturb some viewers. - - # TODO: It should be possible to combine this with - # write_invocation(). - - foreach my $proto (@protos) { - local $" = ", "; # So @args is formatted correctly. - my ($count, @args) = @$proto; - $leak_guard .= qq< - if (\@_ == $count) { - return $call(@args); - } - >; - } - - $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; - - # warn "$leak_guard\n"; - - my $E; - { - local $@; - - $leak_guard = eval $leak_guard; ## no critic - - $E = $@; + } else { + $leak_guard = sub { + unshift @_, [$filename, $code, $sref, $call, \@protos, $pkg]; + goto \&_leak_guard; + }; } - - die "Internal error in $class: Leak-guard installation failure: $E" if $E; } my $installed_sub = $leak_guard || $code; @@ -1261,7 +1327,7 @@ sub _make_fatal { $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub; - # Cache that we've now overriddent this sub. If we get called + # Cache that we've now overridden this sub. If we get called # again, we may need to find that find subroutine again (eg, for hints). $Is_fatalised_sub{$installed_sub} = $sref; @@ -1320,10 +1386,108 @@ sub exception_class { return "autodie::exception" }; } } +sub _leak_guard { + my $call_data = shift; + my ($filename, $wrapped_sub, $orig_sub, $call, $protos, $pkg) = @{$call_data}; + my $caller_level = 0; + my $caller; + my $leaked = 0; + + # NB: if we are wrapping a CORE sub, $orig_sub will be undef. + + while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { + + # If our filename is actually an eval, and we + # reach it, then go to our autodying code immediatately. + + last if ($caller eq $filename); + $caller_level++; + } + # We're now out of the eval stack. + + if ($caller ne $filename) { + # Oh bother, we've leaked into another file. + $leaked = 1; + } + + if (defined($orig_sub)) { + # User sub. + goto $wrapped_sub unless $leaked; + goto $orig_sub; + } + + # Core sub + if ($leaked) { + # If we're here, it must have been a core subroutine called. + + # If we've cached a trampoline, then use it. + my $trampoline_sub = $Trampoline_cache{$pkg}{$call}; + + if (not $trampoline_sub) { + # If we don't have a trampoline, we need to build it. + + # We need to build a 'trampoline'. Essentially, a tiny sub that figures + # out how we should be calling our core sub, puts in the arguments + # in the right way, and bounces our control over to it. + # + # If we could use `goto &` on core builtins, we wouldn't need this. + # + # We only generate trampolines when we need them, and we can cache + # them by subroutine + package. + + # TODO: Consider caching on reusable_builtins status as well. + # (In which case we can also remove the package line in the eval + # later in this block.) + + # TODO: It may be possible to combine this with write_invocation(). + + my $trampoline_code = 'sub {'; + + foreach my $proto (@{$protos}) { + local $" = ", "; # So @args is formatted correctly. + my ($count, @args) = @$proto; + if ($args[-1] =~ m/[@#]_/) { + $trampoline_code .= qq/ + if (\@_ >= $count) { + return $call(@args); + } + /; + } else { + $trampoline_code .= qq< + if (\@_ == $count) { + return $call(@args); + } + >; + } + } + + $trampoline_code .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; + my $E; + + { + local $@; + $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic + $E = $@; + } + die "Internal error in Fatal/autodie: Leak-guard installation failure: $E" + if $E; + + # Phew! Let's cache that, so we don't have to do it again. + $Trampoline_cache{$pkg}{$call} = $trampoline_sub; + } + + # Bounce to our trampoline, which takes us to our core sub. + goto \&$trampoline_sub; + } + + # No leak, do a regular goto. + goto $wrapped_sub; +} + # For some reason, dying while replacing our subs doesn't # kill our calling program. It simply stops the loading of # autodie and keeps going with everything else. The _autocroak -# sub allows us to die with a vegence. It should *only* ever be +# sub allows us to die with a vengeance. It should *only* ever be # used for serious internal errors, since the results of it can't # be captured. @@ -1481,4 +1645,6 @@ L<autodie> for a nicer way to use lexical Fatal. L<IPC::System::Simple> for a similar idea for calls to C<system()> and backticks. +=for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation + =cut |