Merge the feature and B::Deparse refactoring to blead.

5 files changed, 225 insertions, 145 deletions

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 054b919e38..eb24214eff 100644
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -20,10 +20,11 @@ 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 ();
+require feature;
 
 BEGIN {
     # List version-specific constants here.
@@ -1448,7 +1449,13 @@ sub seq_subs {
     return @text;
 }
 
-my $feature_bundle_mask = 0x1c000000;
+sub _features_from_bundle {
+    my ($hints, $hh) = @_;
+    foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
+	$hh->{$feature::feature{$_}} = 1;
+    }
+    return $hh;
+}
 
 # Notice how subs and formats are inserted between statements here;
 # also $[ assignments and pragmas.
@@ -1504,22 +1511,17 @@ sub pp_nextstate {
 
     if ($] >= 5.015006) {
 	# feature bundle hints
-	my $from = $old_hints & $feature_bundle_mask;
-	my $to   = $    hints & $feature_bundle_mask;
+	my $from = $old_hints & $feature::hint_mask;
+	my $to   = $    hints & $feature::hint_mask;
 	if ($from != $to) {
-	    require feature;
-	    if ($to == $feature_bundle_mask) {
+	    if ($to == $feature::hint_mask) {
 		if ($self->{'hinthash'}) {
 		    delete $self->{'hinthash'}{$_}
 			for grep /^feature_/, keys %{$self->{'hinthash'}};
 		}
 		else { $self->{'hinthash'} = {} }
-		local $^H = $from;
-		%{$self->{'hinthash'}} = (
-		    %{$self->{'hinthash'}},
-		    map +($feature::feature{$_} => 1),
-			 @{feature::current_bundle()},
-		);
+		$self->{'hinthash'}
+		    = _features_from_bundle($from, $self->{'hinthash'});
 	    }
 	    else {
 		my $bundle =
@@ -1593,7 +1595,7 @@ my %rev_feature;
 sub declare_hinthash {
     my ($from, $to, $indent, $hints) = @_;
     my $doing_features =
-	($hints & $feature_bundle_mask) == $feature_bundle_mask;
+	($hints & $feature::hint_mask) == $feature::hint_mask;
     my @decls;
     my @features;
     my @unfeatures; # bugs?
@@ -1624,7 +1626,6 @@ sub declare_hinthash {
     }
     my @ret;
     if (@features || @unfeatures) {
-	require feature;
 	if (!%rev_feature) { %rev_feature = reverse %feature::feature }
     }
     if (@features) {
@@ -1683,13 +1684,9 @@ sub keyword {
     return $name if $name =~ /^CORE::/; # just in case
     if (exists $feature_keywords{$name}) {
 	my $hh;
-	my $hints = $self->{hints} & $feature_bundle_mask;
-	if ($hints && $hints != $feature_bundle_mask) {
-	    require feature;
-	    local $^H = $self->{hints};
-	    # Shh! Keep quite about this function.  It is not to be
-	    # relied upon.
-	    $hh = { map +($_ => 1), feature::current_bundle() };
+	my $hints = $self->{hints} & $feature::hint_mask;
+	if ($hints && $hints != $feature::hint_mask) {
+	    $hh = _features_from_bundle($hints);
 	}
 	elsif ($hints) { $hh = $self->{'hinthash'} }
 	return "CORE::$name"
@@ -4546,11 +4543,10 @@ sub re_flags {
     elsif ($self->{hinthash} and
 	     $self->{hinthash}{reflags_charset}
 	    || $self->{hinthash}{feature_unicode}
-	or $self->{hints} & $feature_bundle_mask
-	  && ($self->{hints} & $feature_bundle_mask)
-	       != $feature_bundle_mask
+	or $self->{hints} & $feature::hint_mask
+	  && ($self->{hints} & $feature::hint_mask)
+	       != $feature::hint_mask
 	  && do {
-		require feature;
 		$self->{hints} & $feature::hint_uni8bit;
 	     }
   ) {
diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t
index cae808c1d0..0fa3cbf315 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;
diff --git a/lib/feature.pm b/lib/feature.pm
index 58380e9db6..87b42aa916 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -299,50 +299,14 @@ bundle is automatically loaded instead.
 
 =cut
 
-sub current_bundle {
-    my $bundle_number = $^H & $hint_mask;
-    return if $bundle_number == $hint_mask;
-    return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
-}
-
-sub normalise_hints {
-    # Delete any keys that may be left over from last time.
-    delete @^H{ values(%feature) };
-    $^H |= $hint_mask;
-    for (@{+shift}) {
-	$^H{$feature{$_}} = 1;
-	$^H |= $hint_uni8bit if $_ eq 'unicode_strings';
-    }
-}
-
 sub import {
     my $class = shift;
-    if (@_ == 0) {
+
+    if (!@_) {
         croak("No features specified");
     }
-    if (my $features = current_bundle) {
-	# Features are enabled implicitly via bundle hints.
-	normalise_hints $features;
-    }
-    while (@_) {
-        my $name = shift(@_);
-        if (substr($name, 0, 1) eq ":") {
-            my $v = substr($name, 1);
-            if (!exists $feature_bundle{$v}) {
-                $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
-                if (!exists $feature_bundle{$v}) {
-                    unknown_feature_bundle(substr($name, 1));
-                }
-            }
-            unshift @_, @{$feature_bundle{$v}};
-            next;
-        }
-        if (!exists $feature{$name}) {
-            unknown_feature($name);
-        }
-        $^H{$feature{$name}} = 1;
-        $^H |= $hint_uni8bit if $name eq 'unicode_strings';
-    }
+
+    __common(1, @_);
 }
 
 sub unimport {
@@ -354,11 +318,25 @@ sub unimport {
 	return;
     }
 
-    if (my $features = current_bundle) {
+    __common(0, @_);
+}
+
+
+sub __common {
+    my $import = shift;
+    my $bundle_number = $^H & $hint_mask;
+    my $features = $bundle_number != $hint_mask
+	&& $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
+    if ($features) {
 	# Features are enabled implicitly via bundle hints.
-	normalise_hints $features;
+	# Delete any keys that may be left over from last time.
+	delete @^H{ values(%feature) };
+	$^H |= $hint_mask;
+	for (@$features) {
+	    $^H{$feature{$_}} = 1;
+	    $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
+	}
     }
-
     while (@_) {
         my $name = shift;
         if (substr($name, 0, 1) eq ":") {
@@ -372,10 +350,13 @@ sub unimport {
             unshift @_, @{$feature_bundle{$v}};
             next;
         }
-        if (!exists($feature{$name})) {
+        if (!exists $feature{$name}) {
             unknown_feature($name);
         }
-        else {
+	if ($import) {
+	    $^H{$feature{$name}} = 1;
+	    $^H |= $hint_uni8bit if $name eq 'unicode_strings';
+	} else {
             delete $^H{$feature{$name}};
             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
         }
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index b57b9651a0..0041461e31 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -94,10 +94,19 @@ XXX
 
 =item *
 
+L<B::Deparse> has been upgrade from version 1.11 to 1.12
+
+This fixes a post-v5.14 regression in deparsing C<say> (I<etc>) under
+C<use 5.10.0;>.
+
+=item *
+
 L<feature> has been upgraded from version 1.26 to 1.27
 
 C<no feature;> now means reset to default.
 
+The code has been refactored to reduce duplication.
+
 =back
 
 =head2 Removed Modules and Pragmata
diff --git a/regen/feature.pl b/regen/feature.pl
index aaac912ca2..2a8d369ba2 100755
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -583,50 +583,14 @@ bundle is automatically loaded instead.
 
 =cut
 
-sub current_bundle {
-    my $bundle_number = $^H & $hint_mask;
-    return if $bundle_number == $hint_mask;
-    return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
-}
-
-sub normalise_hints {
-    # Delete any keys that may be left over from last time.
-    delete @^H{ values(%feature) };
-    $^H |= $hint_mask;
-    for (@{+shift}) {
-	$^H{$feature{$_}} = 1;
-	$^H |= $hint_uni8bit if $_ eq 'unicode_strings';
-    }
-}
-
 sub import {
     my $class = shift;
-    if (@_ == 0) {
+
+    if (!@_) {
         croak("No features specified");
     }
-    if (my $features = current_bundle) {
-	# Features are enabled implicitly via bundle hints.
-	normalise_hints $features;
-    }
-    while (@_) {
-        my $name = shift(@_);
-        if (substr($name, 0, 1) eq ":") {
-            my $v = substr($name, 1);
-            if (!exists $feature_bundle{$v}) {
-                $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
-                if (!exists $feature_bundle{$v}) {
-                    unknown_feature_bundle(substr($name, 1));
-                }
-            }
-            unshift @_, @{$feature_bundle{$v}};
-            next;
-        }
-        if (!exists $feature{$name}) {
-            unknown_feature($name);
-        }
-        $^H{$feature{$name}} = 1;
-        $^H |= $hint_uni8bit if $name eq 'unicode_strings';
-    }
+
+    __common(1, @_);
 }
 
 sub unimport {
@@ -638,11 +602,25 @@ sub unimport {
 	return;
     }
 
-    if (my $features = current_bundle) {
+    __common(0, @_);
+}
+
+
+sub __common {
+    my $import = shift;
+    my $bundle_number = $^H & $hint_mask;
+    my $features = $bundle_number != $hint_mask
+	&& $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
+    if ($features) {
 	# Features are enabled implicitly via bundle hints.
-	normalise_hints $features;
+	# Delete any keys that may be left over from last time.
+	delete @^H{ values(%feature) };
+	$^H |= $hint_mask;
+	for (@$features) {
+	    $^H{$feature{$_}} = 1;
+	    $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
+	}
     }
-
     while (@_) {
         my $name = shift;
         if (substr($name, 0, 1) eq ":") {
@@ -656,10 +634,13 @@ sub unimport {
             unshift @_, @{$feature_bundle{$v}};
             next;
         }
-        if (!exists($feature{$name})) {
+        if (!exists $feature{$name}) {
             unknown_feature($name);
         }
-        else {
+	if ($import) {
+	    $^H{$feature{$name}} = 1;
+	    $^H |= $hint_uni8bit if $name eq 'unicode_strings';
+	} else {
             delete $^H{$feature{$name}};
             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
         }