diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Fatal.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Fatal.pm | 892 |
1 files changed, 660 insertions, 232 deletions
diff --git a/Master/tlpkg/tlperl/lib/Fatal.pm b/Master/tlpkg/tlperl/lib/Fatal.pm index c6a3d1b3290..e538e20d682 100644 --- a/Master/tlpkg/tlperl/lib/Fatal.pm +++ b/Master/tlpkg/tlperl/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 ); @@ -13,6 +16,12 @@ use constant LEXICAL_TAG => q{:lexical}; use constant VOID_TAG => q{:void}; use constant INSIST_TAG => q{!}; +# Keys for %Cached_fatalised_sub (used in 3rd level) +use constant CACHE_AUTODIE_LEAK_GUARD => 0; +use constant CACHE_FATAL_WRAPPER => 1; +use constant CACHE_FATAL_VOID => 2; + + use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; @@ -39,8 +48,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.23'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -65,10 +73,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 +97,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,17 +129,41 @@ 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)], + ':2.20' => [qw(:default)], + ':2.21' => [qw(:default)], + ':2.22' => [qw(:default)], + ':2.23' => [qw(:default)], ); # chmod was only introduced in 2.07 +# chown was only introduced in 2.14 -$TAGS{':all'} = [ keys %TAGS ]; +{ + # Expand :all immediately by expanding and flattening all tags. + # _expand_tag is not really optimised for expanding the ":all" + # case (i.e. keys %TAGS, or values %TAGS for that matter), so we + # just do it here. + # + # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being + # pre-expanded. + my %seen; + my @all = grep { + !/^:/ && !$seen{$_}++ + } map { @{$_} } values %TAGS; + $TAGS{':all'} = \@all; +} # This hash contains subroutines for which we should # subroutine() // die() rather than subroutine() || die() @@ -147,10 +187,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 +246,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 +312,15 @@ 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; + +# A cache mapping "CORE::<name>" to their prototype. Turns out that if +# you "use autodie;" enough times, this pays off. +my %CORE_prototype_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. @@ -275,16 +370,26 @@ sub import { my @fatalise_these = @_; - # Thiese subs will get unloaded at the end of lexical scope. + # These subs will get unloaded at the end of lexical scope. my %unload_later; + # These subs are to be installed into callers namespace. + my %install_subs; - # This hash helps us track if we've alredy done work. - my %done_this; - - # NB: we're using while/shift rather than foreach, since - # we'll be modifying the array as we walk through it. - - while (my $func = shift @fatalise_these) { + # Use _translate_import_args to expand tags for us. It will + # pass-through unknown tags (i.e. we have to manually handle + # VOID_TAG). + # + # NB: _translate_import_args re-orders everything for us, so + # we don't have to worry about stuff like: + # + # :default :void :io + # + # That will (correctly) translated into + # + # expand(:defaults-without-io) :void :io + # + # by _translate_import_args. + for my $func ($class->_translate_import_args(@fatalise_these)) { if ($func eq VOID_TAG) { @@ -295,31 +400,19 @@ sub import { $insist_hints = 1; - } elsif (exists $TAGS{$func}) { - - # When it's a tag, expand it. - push(@fatalise_these, @{ $TAGS{$func} }); - } else { # Otherwise, fatalise it. # Check to see if there's an insist flag at the front. # If so, remove it, and insist we have hints for this sub. - my $insist_this; + my $insist_this = $insist_hints; - if ($func =~ s/^!//) { + if (substr($func, 0, 1) eq '!') { + $func = substr($func, 1); $insist_this = 1; } - # TODO: Even if we've already fatalised, we should - # check we've done it with hints (if $insist_hints). - - # If we've already made something fatal this call, - # then don't do it twice. - - next if $done_this{$func}; - # We're going to make a subroutine fatalistic. # However if we're being invoked with 'use Fatal qw(x)' # and we've already been called with 'no autodie qw(x)' @@ -345,11 +438,9 @@ sub import { my $sub_ref = $class->_make_fatal( $func, $pkg, $void, $lexical, $filename, - ( $insist_this || $insist_hints ) + $insist_this, \%install_subs, ); - $done_this{$func}++; - $Original_user_sub{$sub} ||= $sub_ref; # If we're making lexical changes, we need to arrange @@ -360,6 +451,8 @@ sub import { } } + $class->_install_subs($pkg, \%install_subs); + if ($lexical) { # Dark magic to have autodie work under 5.8 @@ -412,18 +505,26 @@ sub _install_subs { # It does not hurt to do this in a predictable order, and might help debugging. foreach my $sub_name (sort keys %$subs_to_reinstate) { - my $sub_ref= $subs_to_reinstate->{$sub_name}; - - my $full_path = $pkg_sym.$sub_name; - # Copy symbols across to temp area. + # We will repeatedly mess with stuff that strict "refs" does + # not like. So lets just disable it once for this entire + # scope. + no strict qw(refs); ## no critic - no strict 'refs'; ## no critic + my $sub_ref= $subs_to_reinstate->{$sub_name}; - local *__tmp = *{ $full_path }; + my $full_path = $pkg_sym.$sub_name; + my $oldglob = *$full_path; # Nuke the old glob. - { no strict; delete $pkg_sym->{$sub_name}; } ## no critic + delete $pkg_sym->{$sub_name}; + + # For some reason this local *alias = *$full_path triggers an + # "only used once" warning. Not entirely sure why, but at + # least it is easy to silence. + no warnings qw(once); + local *alias = *$full_path; + use warnings qw(once); # Copy innocent bystanders back. Note that we lose # formats; it seems that Perl versions up to 5.10.0 @@ -431,16 +532,12 @@ sub _install_subs { # the scalar slot. Thanks to Ben Morrow for spotting this. foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) { - next unless defined *__tmp{ $slot }; - *{ $full_path } = *__tmp{ $slot }; + next unless defined *$oldglob{$slot}; + *alias = *$oldglob{$slot}; } - # Put back the old sub (if there was one). - if ($sub_ref) { - - no strict; ## no critic - *{ $pkg_sym . $sub_name } = $sub_ref; + *$full_path = $sub_ref; } } @@ -464,16 +561,9 @@ sub unimport { # in which case, we disable Fatalistic behaviour for 'blah'. my @unimport_these = @_ ? @_ : ':all'; + my %uninstall_subs; - while (my $symbol = shift @unimport_these) { - - if ($symbol =~ /^:/) { - - # Looks like a tag! Expand it! - push(@unimport_these, @{ $TAGS{$symbol} }); - - next; - } + for my $symbol ($class->_translate_import_args(@unimport_these)) { my $sub = $symbol; $sub = "${pkg}::$sub" unless $sub =~ /::/; @@ -493,29 +583,121 @@ sub unimport { if (my $original_sub = $Original_user_sub{$sub}) { # Hey, we've got an original one of these, put it back. - $class->_install_subs($pkg, { $symbol => $original_sub }); + $uninstall_subs{$symbol} = $original_sub; next; } # We don't have an original copy of the sub, on the assumption # it's core (or doesn't exist), we'll just nuke it. - $class->_install_subs($pkg,{ $symbol => undef }); + $uninstall_subs{$symbol} = undef; } + $class->_install_subs($pkg, \%uninstall_subs); + return; } -# TODO - This is rather terribly inefficient right now. +sub _translate_import_args { + my ($class, @args) = @_; + my @result; + my %seen; + + if (@args < 2) { + # Optimize for this case, as it is fairly common. (e.g. use + # autodie; or use autodie qw(:all); both trigger this). + return unless @args; + + # Not a (known) tag, pass through. + return @args unless exists($TAGS{$args[0]}); + + # Strip "CORE::" from all elements in the list as import and + # unimport does not handle the "CORE::" prefix too well. + # + # NB: we use substr as it is faster than s/^CORE::// and + # it does not change the elements. + return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; + } + + # We want to translate + # + # :default :void :io + # + # into (pseudo-ish): + # + # expanded(:threads) :void expanded(:io) + # + # We accomplish this by "reverse, expand + filter, reverse". + for my $a (reverse(@args)) { + if (exists $TAGS{$a}) { + my $expanded = $class->_expand_tag($a); + push(@result, + # Remove duplicates after ... + grep { !$seen{$_}++ } + # we have stripped CORE:: (see above) + map { substr($_, 6) } + # We take the elements in reverse order + # (as @result be reversed later). + reverse(@{$expanded})); + } else { + # pass through - no filtering here for tags. + # + # The reason for not filtering tags cases like: + # + # ":default :void :io :void :threads" + # + # As we have reversed args, we see this as: + # + # ":threads :void :io :void* :default*" + # + # (Entries marked with "*" will be filtered out completely). When + # reversed again, this will be: + # + # ":io :void :threads" + # + # But we would rather want it to be: + # + # ":void :io :threads" or ":void :io :void :threads" + # + + my $letter = substr($a, 0, 1); + if ($letter ne ':' && $a ne INSIST_TAG) { + next if $seen{$a}++; + if ($letter eq '!' and $seen{substr($a, 1)}++) { + my $name = substr($a, 1); + # People are being silly and doing: + # + # use autodie qw(!a a); + # + # Enjoy this little O(n) clean up... + @result = grep { $_ ne $name } @result; + } + } + push @result, $a; + } + } + # Reverse the result to restore the input order + return reverse(@result); +} + # NB: Perl::Critic's dump-autodie-tag-contents depends upon this # continuing to work. { - my %tag_cache; + # We assume that $TAGS{':all'} is pre-expanded and just fill it in + # from the beginning. + my %tag_cache = ( + 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], + ); + # Expand a given tag (e.g. ":default") into a listref containing + # all sub names covered by that tag. Each sub is returned as + # "CORE::<name>" (i.e. "CORE::open" rather than "open"). + # + # NB: the listref must not be modified. sub _expand_tag { my ($class, $tag) = @_; @@ -529,15 +711,33 @@ sub unimport { my @to_process = @{$TAGS{$tag}}; + # If the tag is basically an alias of another tag (like e.g. ":2.11"), + # then just share the resulting reference with the original content (so + # we only pay for an extra reference for the alias memory-wise). + if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { + # We could do this for "non-tags" as well, but that only occurs + # once at the time of writing (":threads" => ["fork"]), so + # probably not worth it. + my $expanded = $class->_expand_tag($to_process[0]); + $tag_cache{$tag} = $expanded; + return $expanded; + } + + my %seen = (); my @taglist = (); - while (my $item = shift @to_process) { - if ($item =~ /^:/) { - # Expand :tags - push(@to_process, @{$TAGS{$item}} ); - } - else { - push(@taglist, "CORE::$item"); + for my $item (@to_process) { + # substr is more efficient than m/^:/ for stuff like this, + # at the price of being a bit more verbose/low-level. + if (substr($item, 0, 1) eq ':') { + # Use recursion here to ensure we expand a tag at most once. + + my $expanded = $class->_expand_tag($item); + push @taglist, grep { !$seen{$_}++ } @{$expanded}; + } else { + my $subname = "CORE::$item"; + push @taglist, $subname + unless $seen{$subname}++; } } @@ -556,6 +756,12 @@ sub unimport { sub fill_protos { my $proto = shift; my ($n, $isref, @out, @out1, $seen_semi) = -1; + if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) { + # prototype is entirely slurp - special case that does not + # require any handling. + return ([0, '@_']); + } + while ($proto =~ /\S/) { $n++; push(@out1,[$n,@out]) if $seen_semi; @@ -608,7 +814,7 @@ sub _write_invocation { my $condition = "\@_ == $n"; - if (@argv and $argv[-1] =~ /#_/) { + if (@argv and $argv[-1] =~ /[#@]_/) { # This argv ends with '@' in the prototype, so it matches # any number of args >= the number of expressions in the # argv. @@ -702,7 +908,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 +959,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 +1055,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 @@ -966,11 +1196,21 @@ sub _one_invocation { # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 sub _make_fatal { - my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_; - my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints); + my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; + my($code, $sref, $real_proto, $proto, $core, $call, $hints, $cache, $cache_type); my $ini = $sub; + my $name = $sub; + + + if (index($sub, '::') == -1) { + $sub = "${pkg}::$sub"; + if (substr($name, 0, 1) eq '&') { + $name = substr($name, 1); + } + } else { + $name =~ s/.*:://; + } - $sub = "${pkg}::$sub" unless $sub =~ /::/; # Figure if we're using lexical or package semantics and # twiddle the appropriate bits. @@ -982,8 +1222,6 @@ sub _make_fatal { # TODO - We *should* be able to do skipping, since we know when # we've lexicalised / unlexicalised a subroutine. - $name = $sub; - $name =~ s/.*::// or $name =~ s/^&//; warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; @@ -998,7 +1236,7 @@ sub _make_fatal { # This could be something that we've fatalised that # was in core. - if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) { + if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { # Something we previously made Fatal that was core. # This is safe to replace with an autodying to core @@ -1006,7 +1244,7 @@ sub _make_fatal { $core = 1; $call = "CORE::$name"; - $proto = prototype $call; + $proto = $CORE_prototype_cache{$call}; # We return our $sref from this subroutine later # on, indicating this subroutine should be placed @@ -1020,29 +1258,51 @@ sub _make_fatal { # then look-up the name of the original sub for the rest of # our processing. - $sub = $Is_fatalised_sub{\&$sub} || $sub; + if (exists($Is_fatalised_sub{\&$sub})) { + # $sub is one of our wrappers around a CORE sub or a + # user sub. Instead of wrapping our wrapper, lets just + # generate a new wrapper for the original sub. + # - NB: the current wrapper might be for a different class + # than the one we are generating now (e.g. some limited + # mixing between use Fatal + use autodie can occur). + # - Even for nested autodie, we need this as the leak guards + # differ. + my $s = $Is_fatalised_sub{\&$sub}; + if (defined($s)) { + # It is a wrapper for a user sub + $sub = $s; + } else { + # It is a wrapper for a CORE:: sub + $core = 1; + $call = "CORE::$name"; + $proto = $CORE_prototype_cache{$call}; + } + } # A regular user sub, or a user sub wrapping a # core sub. $sref = \&$sub; - $proto = prototype $sref; - $call = '&$sref'; - require autodie::hints; + if (!$core) { + # A non-CORE sub might have hints and such... + $proto = prototype($sref); + $call = '&$sref'; + require autodie::hints; - $hints = autodie::hints->get_hints_for( $sref ); + $hints = autodie::hints->get_hints_for( $sref ); - # If we've insisted on hints, but don't have them, then - # bail out! + # If we've insisted on hints, but don't have them, then + # bail out! - if ($insist and not $hints) { - croak(sprintf(ERROR_NOHINTS, $name)); - } + if ($insist and not $hints) { + croak(sprintf(ERROR_NOHINTS, $name)); + } - # Otherwise, use the default hints if we don't have - # any. + # Otherwise, use the default hints if we don't have + # any. - $hints ||= autodie::hints::DEFAULT_HINTS(); + $hints ||= autodie::hints::DEFAULT_HINTS(); + } } @@ -1082,40 +1342,34 @@ sub _make_fatal { } $call = 'CORE::system'; - $name = 'system'; $core = 1; } 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'; $core = 1; } else { # CORE subroutine - my $E; - { - local $@; - $proto = eval { prototype "CORE::$name" }; - $E = $@; + $call = "CORE::$name"; + if (exists($CORE_prototype_cache{$call})) { + $proto = $CORE_prototype_cache{$call}; + } else { + my $E; + { + local $@; + $proto = eval { prototype $call }; + $E = $@; + } + croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; + croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; + $CORE_prototype_cache{$call} = $proto; } - croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; - croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; $core = 1; - $call = "CORE::$name"; - } - - if (defined $proto) { - $real_proto = " ($proto)"; - } else { - $real_proto = ''; - $proto = '@'; } - my $true_name = $core ? $call : $sub; - # TODO: This caching works, but I don't like using $void and # $lexical as keys. In particular, I suspect our code may end up # wrapping already wrapped code when autodie and Fatal are used @@ -1126,48 +1380,43 @@ sub _make_fatal { # results code that's in the wrong package, and hence has # access to the wrong package filehandles. - if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) { - $class->_install_subs($pkg, { $name => $subref }); - return $sref; + $cache = $Cached_fatalised_sub{$class}{$sub}; + if ($lexical) { + $cache_type = CACHE_AUTODIE_LEAK_GUARD; + } else { + $cache_type = CACHE_FATAL_WRAPPER; + $cache_type = CACHE_FATAL_VOID if $void; } - $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"; - - 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 ... - - my $E; + if (my $subref = $cache->{$cache_type}) { + $install_subs->{$name} = $subref; + return $sref; + } - { - local $@; - $code = eval("package $pkg; require Carp; $code"); ## no critic - $E = $@; + # 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)) { + $install_subs->{$name} = $code; + return $sref; } + } - if (not $code) { - croak("Internal error in autodie/Fatal processing $true_name: $E"); - + if (!($lexical && $core) && !defined($code)) { + # No code available, generate it now. + my $wrapper_pkg = $pkg; + $wrapper_pkg = undef if (exists($reusable_builtins{$call})); + $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, + $void, $lexical, $sub, $sref, + $hints, $proto); + if (!defined($wrapper_pkg)) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; } } @@ -1182,86 +1431,24 @@ sub _make_fatal { # TODO: This is pretty hairy code. A lot more tests would # be really nice for this. - my $leak_guard; + my $installed_sub = $code; if ($lexical) { - - $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 = $@; + my $real_proto = ''; + if (defined $proto) { + $real_proto = " ($proto)"; + } else { + $proto = '@'; } - - die "Internal error in $class: Leak-guard installation failure: $E" if $E; + $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, + $pkg, $proto, $real_proto); } - my $installed_sub = $leak_guard || $code; - - $class->_install_subs($pkg, { $name => $installed_sub }); + $cache->{$cache_type} = $code; - $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub; + $install_subs->{$name} = $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 +1507,249 @@ sub exception_class { return "autodie::exception" }; } } +# Creates and returns a leak guard (with prototype if needed). +sub _make_leak_guard { + my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto, $real_proto) = @_; + + # The leak guard is rather lengthly (in fact it makes up the most + # of _make_leak_guard). It is possible to split it into a large + # "generic" part and a small wrapper with call-specific + # information. This was done in v2.19 and profiling suggested + # that we ended up using a substantial amount of runtime in "goto" + # between the leak guard(s) and the final sub. Therefore, the two + # parts were merged into one to reduce the runtime overhead. + + my $leak_guard = sub { + 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. + + last if ($caller eq $filename); + $caller_level++; + } + + # We're now out of the eval stack. + + if ($caller eq $filename) { + # No leak, call the wrapper. NB: In this case, it doesn't + # matter if it is a CORE sub or not. + if (!defined($wrapped_sub)) { + # CORE sub that we were too lazy to compile when we + # created this leak guard. + die "$call is not CORE::<something>" + if substr($call, 0, 6) ne 'CORE::'; + + my $name = substr($call, 6); + my $sub = $name; + my $lexical = 1; + my $wrapper_pkg = $pkg; + my $code; + if (exists($reusable_builtins{$call})) { + $code = $reusable_builtins{$call}{$lexical}; + $wrapper_pkg = undef; + } + if (!defined($code)) { + $code = $class->_compile_wrapper($wrapper_pkg, + 1, # core + $call, + $name, + 0, # void + $lexical, + $sub, + undef, # subref (not used for core) + undef, # hints (not used for core) + $proto); + + if (!defined($wrapper_pkg)) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + # As $wrapped_sub is "closed over", updating its value will + # be "remembered" for the next call. + $wrapped_sub = $code; + } + goto $wrapped_sub; + } + + # We leaked, time to call the original function. + # - for non-core functions that will be $orig_sub + # - for CORE functions, $orig_sub may be a trampoline + goto $orig_sub if defined($orig_sub); + + # We are wrapping a CORE sub and we do not have a trampoline + # yet. + # + # If we've cached a trampoline, then use it. Usually only + # resuable subs will have cache hits, but non-reusuably ones + # can get it as well in (very) rare cases. It is mostly in + # cases where a package uses autodie multiple times and leaks + # from multiple places. Possibly something like: + # + # package Pkg::With::LeakyCode; + # sub a { + # use autodie; + # code_that_leaks(); + # } + # + # sub b { + # use autodie; + # more_leaky_code(); + # } + # + # Note that we use "Fatal" as package name for reusable subs + # because A) that allows us to trivially re-use the + # trampolines as well and B) because the reusable sub is + # compiled into "package Fatal" as well. + + $pkg = 'Fatal' if exists $reusable_builtins{$call}; + $orig_sub = $Trampoline_cache{$pkg}{$call}; + + if (not $orig_sub) { + # If we don't have a trampoline, we need to build it. + # + # We only generate trampolines when we need them, and + # we can cache them by subroutine + package. + # + # As $orig_sub is "closed over", updating its value will + # be "remembered" for the next call. + + $orig_sub = _make_core_trampoline($call, $pkg, $proto); + + # We still cache it despite remembering it in $orig_sub as + # well. In particularly, we rely on this to avoid + # re-compiling the reusable trampolines. + $Trampoline_cache{$pkg}{$call} = $orig_sub; + } + + # Bounce to our trampoline, which takes us to our core sub. + goto $orig_sub; + }; # <-- end of leak guard + + # If there is a prototype on the original sub, copy it to the leak + # guard. + if ($real_proto ne '') { + # The "\&" may appear to be redundant but set_prototype + # croaks when it is removed. + set_prototype(\&$leak_guard, $proto); + } + + return $leak_guard; +} + +# Create a trampoline for calling a core sub. 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. +sub _make_core_trampoline { + my ($call, $pkg, $proto_str) = @_; + my $trampoline_code = 'sub {'; + my $trampoline_sub; + my @protos = fill_protos($proto_str); + + # TODO: It may be possible to combine this with write_invocation(). + + foreach my $proto (@protos) { + local $" = ", "; # So @args is formatted correctly. + my ($count, @args) = @$proto; + if (@args && $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; + + return $trampoline_sub; +} + +sub _compile_wrapper { + my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; + my $real_proto = ''; + my @protos; + my $code; + if (defined $proto) { + $real_proto = " ($proto)"; + } else { + $proto = '@'; + } + + @protos = fill_protos($proto); + $code = qq[ + sub$real_proto { + ]; + + if (!$lexical) { + $code .= q[ + local($", $!) = (', ', 0); + ]; + } + + # 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. + + my $E; + + { + no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + local $@; + if (defined($wrapper_pkg)) { + $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic + } else { + $code = eval("require Carp; $code"); ## no critic + + } + $E = $@; + } + + if (not $code) { + my $true_name = $core ? $call : $sub; + croak("Internal error in autodie/Fatal processing $true_name: $E"); + } + return $code; +} + # 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 +1907,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 ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG + =cut |