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';
use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
-our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version
+our $VERSION = '2.21'; # VERSION: Generated by DZP::OurPkg::Version
our $Debug ||= 0;
':2.18' => [qw(:default)],
':2.19' => [qw(:default)],
':2.20' => [qw(:default)],
+ ':2.21' => [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()
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.
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;
# Use _translate_import_args to expand tags for us. It will
# pass-through unknown tags (i.e. we have to manually handle
# 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;
}
my $sub_ref = $class->_make_fatal(
$func, $pkg, $void, $lexical, $filename,
- ( $insist_this || $insist_hints )
+ $insist_this, \%install_subs,
);
$Original_user_sub{$sub} ||= $sub_ref;
}
}
+ $class->_install_subs($pkg, \%install_subs);
+
if ($lexical) {
# Dark magic to have autodie work under 5.8
# in which case, we disable Fatalistic behaviour for 'blah'.
my @unimport_these = @_ ? @_ : ':all';
+ my %uninstall_subs;
for my $symbol ($class->_translate_import_args(@unimport_these)) {
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;
}
# 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
# 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.
- #
- # TODO: Improve handling of :all so we don't expand
- # all those aliases (e.g :2.00..:2.07 are all aliases
- # of v2.07).
my $expanded = $class->_expand_tag($item);
push @taglist, grep { !$seen{$_}++ } @{$expanded};
# 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.
# 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+$/;
# 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
$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
# 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();
+ }
}
}
$call = 'CORE::system';
- $name = 'system';
$core = 1;
} elsif ($name eq 'exec') {
# 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";
}
- 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
# 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 });
+ $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;
+ }
+
+ if (my $subref = $cache->{$cache_type}) {
+ $install_subs->{$name} = $subref;
return $sref;
}
# - 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 });
+ $install_subs->{$name} = $code;
return $sref;
}
}
- if (defined $proto) {
- $real_proto = " ($proto)";
- } else {
- $real_proto = '';
- $proto = '@';
- }
-
- if (!defined($code)) {
+ if (!($lexical && $core) && !defined($code)) {
# No code available, generate it now.
- my @protos = fill_protos($proto);
-
- $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.
-
- {
- no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
-
- my $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");
-
- }
+ 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;
}
}
# 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 = _make_leak_guard($filename, $code, $sref, $call,
- $pkg, $proto, $real_proto);
+ my $real_proto = '';
+ if (defined $proto) {
+ $real_proto = " ($proto)";
+ } else {
+ $proto = '@';
+ }
+ $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 overridden this sub. If we get called
# again, we may need to find that find subroutine again (eg, for hints).
# Creates and returns a leak guard (with prototype if needed).
sub _make_leak_guard {
- my ($filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto, $real_proto) = @_;
+ 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
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
+ # 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.
- # If we've cached a trampoline, then use it.
- my $trampoline_sub = $Trampoline_cache{$pkg}{$call};
+ $pkg = 'Fatal' if exists $reusable_builtins{$call};
+ $orig_sub = $Trampoline_cache{$pkg}{$call};
- if (not $trampoline_sub) {
+ 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.
- # TODO: Consider caching on reusable_builtins status as well.
-
- $trampoline_sub = _make_core_trampoline($call, $pkg, $proto);
+ $orig_sub = _make_core_trampoline($call, $pkg, $proto);
- # Let's cache that, so we don't have to do it again.
- $Trampoline_cache{$pkg}{$call} = $trampoline_sub;
+ # 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 \&$trampoline_sub;
+ goto $orig_sub;
}; # <-- end of leak guard
# If there is a prototype on the original sub, copy it to the leak
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
projects / platform / upstream / perl.git / commitdiff