In perl.git, the branch smoke-me/Deparse-defeature has been updated <http://perl5.git.perl.org/perl.git/commitdiff/010b90a910922b6cf21bb0e5ae0c36ce9b0ff914?hp=b4069bca6054692e4fffa8e9e04572511e910fbd>
- Log ----------------------------------------------------------------- commit 010b90a910922b6cf21bb0e5ae0c36ce9b0ff914 Author: Nicholas Clark <[email protected]> Date: Tue Feb 28 17:32:08 2012 +0100 Fix regression in deparsing say (etc) under use 5.10.0 Commit 6634bb9d0ed117be introduced a regression, causing this use 5.10.0; say "Perl rules"; to be deparsed as C<CORE::say>, not C<say>, etc. It wasn't actually possible to write tests for this within the t/deparse.t framework until the recent refactoring. M dist/B-Deparse/Deparse.pm M dist/B-Deparse/t/deparse.t commit ecea46f936df185b24fbab547ad8436dc98e7641 Author: Nicholas Clark <[email protected]> Date: Tue Feb 28 16:44:51 2012 +0100 Add tests for deparsing C<say> under various combinations of pragmas. These mostly codify the current output of B::Deparse, which is not invalid, but might not be considered to be the optimal output. (It's defensive, in that it uses C<no feature;> which will ensure consistent behaviour whatever pragma context the output is evaluated in.) Some are TODO for the cases where B::Deparse is wrongly outputting C<CORE::say> instead of plain C<say> and C<CORE::__SUB__> instead of plain C<__SUB__>. M dist/B-Deparse/t/deparse.t commit 1ef1b534951078128b3ff9ad272aed49b0809053 Author: Nicholas Clark <[email protected]> Date: Tue Feb 28 14:00:56 2012 +0100 Avoid deparse.t testing everything under use feature ':5.10' Only use feature ':5.10' in those tests that actually need it. This will let us add tests for deparsing without any features enabled. M dist/B-Deparse/t/deparse.t commit f428f17372790d940a2db364ead107ae60a6c096 Author: Nicholas Clark <[email protected]> Date: Tue Feb 28 13:49:18 2012 +0100 Add a 'context' feature to deparse.t, to better test ambient pragmas. Call ambient_pragmas() before each deparse test. This will allow use to remove the constraints of the current default, which is to always run under use feature ":5.10"; M dist/B-Deparse/t/deparse.t commit bedac4852689ce2185810bb28e2b691c34888a0b Author: Nicholas Clark <[email protected]> Date: Tue Feb 28 12:43:02 2012 +0100 In deparse.t, rename %reason to %meta. Whilst skip and todo both have "reason"s, subsequent refactoring will use it for other purposes. M dist/B-Deparse/t/deparse.t ----------------------------------------------------------------------- Summary of changes: dist/B-Deparse/Deparse.pm | 4 +- dist/B-Deparse/t/deparse.t | 173 ++++++++++++++++++++++++++++++++++++-------- 2 files changed, 145 insertions(+), 32 deletions(-) diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index 054b919..de768d9 100644 --- a/dist/B-Deparse/Deparse.pm +++ b/dist/B-Deparse/Deparse.pm @@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring CVf_METHOD CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = "1.12"; +$VERSION = '1.13'; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -1689,7 +1689,7 @@ sub keyword { local $^H = $self->{hints}; # Shh! Keep quite about this function. It is not to be # relied upon. - $hh = { map +($_ => 1), feature::current_bundle() }; + $hh = { map +($feature::feature{$_} => 1), @{feature::current_bundle()} }; } elsif ($hints) { $hh = $self->{'hinthash'} } return "CORE::$name" diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t index cae808c..0fa3cbf 100644 --- a/dist/B-Deparse/t/deparse.t +++ b/dist/B-Deparse/t/deparse.t @@ -11,14 +11,7 @@ BEGIN { use warnings; use strict; -BEGIN { - # BEGIN block is actually a subroutine :-) - return unless $] > 5.009; - require feature; - feature->import(':5.10'); -} use Test::More; -use Config (); my $tests = 17; # not counting those in the __DATA__ section @@ -26,34 +19,23 @@ use B::Deparse; my $deparse = B::Deparse->new(); isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object'); -# Tell B::Deparse about our ambient pragmas -{ my ($hint_bits, $warning_bits, $hinthash); - BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); } - $deparse->ambient_pragmas ( - hint_bits => $hint_bits, - warning_bits => $warning_bits, - '%^H' => $hinthash, - ); -} - $/ = "\n####\n"; while (<DATA>) { chomp; $tests ++; # This code is pinched from the t/lib/common.pl for TODO. # It's not clear how to avoid duplication - # Now tweaked a bit to do skip or todo - my %reason; - foreach my $what (qw(skip todo)) { - s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; + my %meta = (context => ''); + foreach my $what (qw(skip todo context)) { + s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1; # If the SKIP reason starts ? then it's taken as a code snippet to # evaluate. This provides the flexibility to have conditional SKIPs - if ($reason{$what} && $reason{$what} =~ s/^\?//) { - my $temp = eval $reason{$what}; + if ($meta{$what} && $meta{$what} =~ s/^\?//) { + my $temp = eval $meta{$what}; if ($@) { - die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; + die "# In \U$what\E code reason:\n# $meta{$what}\n$@"; } - $reason{$what} = $temp; + $meta{$what} = $temp; } } @@ -61,9 +43,9 @@ while (<DATA>) { my $desc = $1; die "Missing name in test $_" unless defined $desc; - if ($reason{skip}) { + if ($meta{skip}) { # Like this to avoid needing a label SKIP: - Test::More->builder->skip($reason{skip}); + Test::More->builder->skip($meta{skip}); next; } @@ -75,7 +57,18 @@ while (<DATA>) { ($input, $expected) = ($_, $_); } - my $coderef = eval "sub {$input}"; + my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input}"; +# Tell B::Deparse about our ambient pragmas +my ($hint_bits, $warning_bits, $hinthash); +BEGIN { + ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); +} +$deparse->ambient_pragmas ( + hint_bits => $hint_bits, + warning_bits => $warning_bits, + '%^H' => $hinthash, +); +EOC if ($@) { is($@, "", "compilation of $desc"); @@ -87,7 +80,7 @@ while (<DATA>) { $regex =~ s/\s+/\\s+/g; $regex = '^\{\s*' . $regex . '\s*\}$'; - local $::TODO = $reason{todo}; + local $::TODO = $meta{todo}; like($deparsed, qr/$regex/, $desc); } } @@ -460,20 +453,109 @@ our @bar; foo { @bar } 1 xor foo(); #### # SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # say say 'foo'; #### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use 5.10.0; +# say in the context of use 5.10.0 +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# say with use 5.10.0 +use 5.10.0; +say 'foo'; +>>>> +no feature; +use feature ':5.10'; +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# say with use feature ':5.10'; +use feature ':5.10'; +say 'foo'; +>>>> +use feature 'say', 'state', 'switch'; +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use feature ':5.10'; +# say with use 5.10.0 in the context of use feature +use 5.10.0; +say 'foo'; +>>>> +no feature; +use feature ':5.10'; +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use 5.10.0; +# say with use feature ':5.10' in the context of use 5.10.0 +use feature ':5.10'; +say 'foo'; +>>>> +say 'foo'; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use feature ':5.15'; +# __SUB__ +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use 5.15.0; +# __SUB__ in the context of use 5.15.0 +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# __SUB__ with use 5.15.0 +use 5.15.0; +__SUB__; +>>>> +no feature; +use feature ':5.16'; +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# __SUB__ with use feature ':5.15'; +use feature ':5.15'; +__SUB__; +>>>> +use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval'; +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use feature ':5.15'; +# __SUB__ with use 5.15.0 in the context of use feature +use 5.15.0; +__SUB__; +>>>> +no feature; +use feature ':5.16'; +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use 5.15.0; +# __SUB__ with use feature ':5.15' in the context of use 5.15.0 +use feature ':5.15'; +__SUB__; +>>>> +__SUB__; +#### # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # state vars state $x = 42; #### # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # state var assignment { my $y = (state $x = 42); } #### # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # state vars in anonymous subroutines $a = sub { state $x; @@ -498,6 +580,7 @@ my $c = []; my $d = \[]; #### # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # implicit smartmatch in given/when given ('foo') { when ('bar') { continue; } @@ -857,7 +940,6 @@ my @a; $a[0] = 1; #### # feature features without feature -no feature 'say', 'state', 'switch'; CORE::state $x; CORE::say $x; CORE::given ($x) { @@ -888,6 +970,37 @@ CORE::given ($x) { CORE::evalbytes ''; () = CORE::__SUB__; >>>> +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +#### +# (the above test with CONTEXT, and the output is equivalent but different) +# CONTEXT use feature ':5.10'; +# feature features when feature has been disabled by use VERSION +use feature (sprintf(":%vd", $^V)); +use 1; +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +>>>> no feature; use feature ':default'; CORE::state $x; -- Perl5 Master Repository
