summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Fatal.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Fatal.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Fatal.pm892
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