use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
-our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg::Version
+our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version
our $Debug ||= 0;
':2.17' => [qw(:default)],
':2.18' => [qw(:default)],
':2.19' => [qw(:default)],
+ ':2.20' => [qw(:default)],
);
# chmod was only introduced in 2.07
# Thiese subs will get unloaded at the end of lexical scope.
my %unload_later;
- # This hash helps us track if we've already 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).
+ #
+ # TODO: Consider how to handle stuff like:
+ # use autodie qw(:defaults ! :io);
+ # use Fatal qw(:defaults :void :io);
+ #
+ # The ! and :void is currently not applied to anything in the
+ # example above since duplicates are filtered out. This has been
+ # autodie's behaviour for quite a while, but it might make sense
+ # to change it so "!" or ":void" applies to stuff after they
+ # appear (even if they are all duplicates).
+ for my $func ($class->_translate_import_args(@fatalise_these)) {
if ($func eq VOID_TAG) {
$insist_hints = 1;
- } elsif (exists $TAGS{$func}) {
-
- # When it's a tag, expand it.
- push(@fatalise_these, @{ $TAGS{$func} });
-
} else {
# Otherwise, fatalise it.
$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)'
( $insist_this || $insist_hints )
);
- $done_this{$func}++;
-
$Original_user_sub{$sub} ||= $sub_ref;
# If we're making lexical changes, we need to arrange
if ($sub_ref) {
no strict; ## no critic
- *{ $pkg_sym . $sub_name } = $sub_ref;
+ *{ $full_path } = $sub_ref;
}
}
my @unimport_these = @_ ? @_ : ':all';
- 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 =~ /::/;
}
-# TODO - This is rather terribly inefficient right now.
+sub _translate_import_args {
+ my ($class, @args) = @_;
+ my @result;
+ for my $a (@args){
+ if (exists $TAGS{$a}) {
+ my $expanded = $class->_expand_tag($a);
+ # 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.
+ push @result, map { substr($_, 6) } @{$expanded};
+ } else {
+ #pass through
+ push @result, $a;
+ }
+ }
+ # If @args < 2, then we have no duplicates (because _expand_tag
+ # does not have duplicates and if it is not a tag, it is just a
+ # single value). We optimize for this because it is a fairly
+ # common case (e.g. use autodie; or use autodie qw(:all); both
+ # trigger this).
+ return @result if @args < 2;
+
+ my %seen = ();
+ # Yes, this is basically List::MoreUtils's uniq/distinct, but
+ # List::MoreUtils is not in the Perl core and autodie is
+ return grep { !$seen{$_}++ } @result;
+}
+
# NB: Perl::Critic's dump-autodie-tag-contents depends upon this
# continuing to work.
{
my %tag_cache;
+ # 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) = @_;
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.
+ #
+ # 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};
+ } else {
+ my $subname = "CORE::$item";
+ push @taglist, $subname
+ unless $seen{$subname}++;
}
}
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;
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.
$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
}
}
- my @protos = fill_protos($proto);
+ if (defined $proto) {
+ $real_proto = " ($proto)";
+ } else {
+ $real_proto = '';
+ $proto = '@';
+ }
if (!defined($code)) {
# No code available, generate it now.
+ my @protos = fill_protos($proto);
$code = qq[
sub$real_proto {
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);
-
- } else {
- $leak_guard = sub {
- unshift @_, [$filename, $code, $sref, $call, \@protos, $pkg];
- goto \&_leak_guard;
- };
- }
+ $leak_guard = _make_leak_guard($filename, $code, $sref, $call,
+ $pkg, $proto, $real_proto);
}
my $installed_sub = $leak_guard || $code;
}
}
-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;
+# 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) = @_;
- # NB: if we are wrapping a CORE sub, $orig_sub will be undef.
+ # 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.
- while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) {
+ my $leak_guard = sub {
+ my $caller_level = 0;
+ my $caller;
- # If our filename is actually an eval, and we
- # reach it, then go to our autodying code immediatately.
+ while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) {
- last if ($caller eq $filename);
- $caller_level++;
- }
- # We're now out of the eval stack.
+ # If our filename is actually an eval, and we
+ # reach it, then go to our autodying code immediatately.
- if ($caller ne $filename) {
- # Oh bother, we've leaked into another file.
- $leaked = 1;
- }
+ last if ($caller eq $filename);
+ $caller_level++;
+ }
- if (defined($orig_sub)) {
- # User sub.
- goto $wrapped_sub unless $leaked;
- goto $orig_sub;
- }
+ # 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.
+ goto $wrapped_sub;
+ }
- # Core sub
- if ($leaked) {
- # If we're here, it must have been a core subroutine called.
+ # We leaked, time to call the original function.
+ # - for non-core functions that will be $orig_sub
+ goto $orig_sub if defined($orig_sub);
+
+ # We are wrapping a CORE sub
# 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.
+ # 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;
+ $trampoline_sub = _make_core_trampoline($call, $pkg, $proto);
- {
- 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.
+ # 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;
+ }; # <-- 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;
- # No leak, do a regular goto.
- goto $wrapped_sub;
+ return $trampoline_sub;
}
# For some reason, dying while replacing our subs doesn't
projects / platform / upstream / perl.git / commitdiff