From 391c72152e89f549903d94fa5a57cda2ddcd58f7 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Mon, 24 Jun 2013 12:07:20 +0100 Subject: [PATCH] Update autodie to CPAN version 2.20 [DELTA] 2.20 2013-06-23 16:08:41 PST8PDT Many improvements from Niels Thykier, hero of the free people. From GH #25: * SPEED / INTERNAL: Less time is spent computing prototypes * SPEED / INTERNAL: Leak guards are more efficient. * SPEED : Expanding tags (eg: qw(:all)) is now faster. This also improves the speed of checking autodying code with Perl::Critic. * INTERNAL: Expanding of tags is faster and preserves order. --- Porting/Maintainers.pl | 2 +- cpan/autodie/lib/Fatal.pm | 323 ++++++++++++++++----------- cpan/autodie/lib/autodie.pm | 4 +- cpan/autodie/lib/autodie/exception.pm | 2 +- cpan/autodie/lib/autodie/exception/system.pm | 2 +- cpan/autodie/lib/autodie/hints.pm | 2 +- cpan/autodie/lib/autodie/skip.pm | 2 +- 7 files changed, 194 insertions(+), 143 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 7a410d2..4b668e6 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -223,7 +223,7 @@ use File::Glob qw(:case); 'autodie' => { 'MAINTAINER' => 'pjf', - 'DISTRIBUTION' => 'PJF/autodie-2.19.tar.gz', + 'DISTRIBUTION' => 'PJF/autodie-2.20.tar.gz', 'FILES' => q[cpan/autodie], 'EXCLUDED' => [ qr{^inc/Module/}, diff --git a/cpan/autodie/lib/Fatal.pm b/cpan/autodie/lib/Fatal.pm index 8c6536b..a16cfd6 100644 --- a/cpan/autodie/lib/Fatal.pm +++ b/cpan/autodie/lib/Fatal.pm @@ -42,7 +42,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; -our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg::Version +our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -135,6 +135,7 @@ my %TAGS = ( ':2.17' => [qw(:default)], ':2.18' => [qw(:default)], ':2.19' => [qw(:default)], + ':2.20' => [qw(:default)], ); # chmod was only introduced in 2.07 @@ -346,13 +347,20 @@ sub import { # 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) { @@ -363,11 +371,6 @@ 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. @@ -380,14 +383,6 @@ sub import { $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)' @@ -416,8 +411,6 @@ sub import { ( $insist_this || $insist_hints ) ); - $done_this{$func}++; - $Original_user_sub{$sub} ||= $sub_ref; # If we're making lexical changes, we need to arrange @@ -508,7 +501,7 @@ sub _install_subs { if ($sub_ref) { no strict; ## no critic - *{ $pkg_sym . $sub_name } = $sub_ref; + *{ $full_path } = $sub_ref; } } @@ -533,15 +526,7 @@ sub unimport { 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 =~ /::/; @@ -576,7 +561,36 @@ sub unimport { } -# 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. @@ -584,6 +598,11 @@ sub unimport { { 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::" (i.e. "CORE::open" rather than "open"). + # + # NB: the listref must not be modified. sub _expand_tag { my ($class, $tag) = @_; @@ -597,15 +616,37 @@ 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. + # + # 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}++; } } @@ -624,6 +665,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; @@ -676,7 +723,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. @@ -1199,14 +1246,6 @@ sub _make_fatal { $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 @@ -1238,10 +1277,16 @@ sub _make_fatal { } } - 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 { @@ -1305,20 +1350,8 @@ sub _make_fatal { my $leak_guard; if ($lexical) { - # Do a little dance because set_prototype does not accept code - # refs (i.e. "my $s = sub {}; set_prototype($s, '$$);" fails) - if ($real_proto ne '') { - $leak_guard = set_prototype(sub { - unshift @_, [$filename, $code, $sref, $call, \@protos, $pkg]; - goto \&_leak_guard; - }, $proto); - - } 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; @@ -1386,102 +1419,120 @@ sub exception_class { return "autodie::exception" }; } } -sub _leak_guard { - my $call_data = shift; - my ($filename, $wrapped_sub, $orig_sub, $call, $protos, $pkg) = @{$call_data}; - my $caller_level = 0; - my $caller; - my $leaked = 0; +# 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 diff --git a/cpan/autodie/lib/autodie.pm b/cpan/autodie/lib/autodie.pm index 6416d2c..60d1a46 100644 --- a/cpan/autodie/lib/autodie.pm +++ b/cpan/autodie/lib/autodie.pm @@ -10,7 +10,7 @@ our $VERSION; # ABSTRACT: Replace functions with ones that succeed or die with lexical scope BEGIN { - our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg::Version + our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version } use constant ERROR_WRONG_FATAL => q{ @@ -427,6 +427,6 @@ Mark Reed and Roland Giersig -- Klingon translators. See the F file for full credits. The latest version of this file can be found at -L . +L . =cut diff --git a/cpan/autodie/lib/autodie/exception.pm b/cpan/autodie/lib/autodie/exception.pm index ffdd4c8..e5efc61 100644 --- a/cpan/autodie/lib/autodie/exception.pm +++ b/cpan/autodie/lib/autodie/exception.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp qw(croak); -our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying functions. our $DEBUG = 0; diff --git a/cpan/autodie/lib/autodie/exception/system.pm b/cpan/autodie/lib/autodie/exception/system.pm index 137bff1..8a2a101 100644 --- a/cpan/autodie/lib/autodie/exception/system.pm +++ b/cpan/autodie/lib/autodie/exception/system.pm @@ -5,7 +5,7 @@ use warnings; use base 'autodie::exception'; use Carp qw(croak); -our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying system(). diff --git a/cpan/autodie/lib/autodie/hints.pm b/cpan/autodie/lib/autodie/hints.pm index 350738e..c9e6275 100644 --- a/cpan/autodie/lib/autodie/hints.pm +++ b/cpan/autodie/lib/autodie/hints.pm @@ -5,7 +5,7 @@ use warnings; use constant PERL58 => ( $] < 5.009 ); -our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Provide hints about user subroutines to autodie diff --git a/cpan/autodie/lib/autodie/skip.pm b/cpan/autodie/lib/autodie/skip.pm index a9bac83..6519d5e 100644 --- a/cpan/autodie/lib/autodie/skip.pm +++ b/cpan/autodie/lib/autodie/skip.pm @@ -2,7 +2,7 @@ package autodie::skip; use strict; use warnings; -our $VERSION = '2.19'; # VERSION +our $VERSION = '2.20'; # VERSION # This package exists purely so people can inherit from it, # which isn't at all how roles are supposed to work, but it's -- 2.7.4