Deparse implicit with ‘use feature’

When a version declaration has been seen, it’s not possible to deparse
the code perfectly correctly, but using ‘no feature; use feature
"5.14"’ is a reasonable tradeoff.  See also commit 1c74777c25.

This necessitated sorting %^H keys that are output to keep tests pass-
ing.  Previously they were relying on phases of the moon.

4 files changed, 88 insertions, 28 deletions

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index b78ef671f4..3c1dd08395 100644
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -1427,6 +1427,8 @@ sub seq_subs {
     return @text;
 }
 
+my $feature_bundle_mask = 0x1c000000;
+
 # Notice how subs and formats are inserted between statements here;
 # also $[ assignments and pragmas.
 sub pp_nextstate {
@@ -1468,18 +1470,52 @@ sub pp_nextstate {
     }
 
     my $hints = $] < 5.008009 ? $op->private : $op->hints;
+    my $old_hints = $self->{'hints'};
     if ($self->{'hints'} != $hints) {
 	push @text, declare_hints($self->{'hints'}, $hints);
 	$self->{'hints'} = $hints;
     }
 
-    if ($] > 5.009 &&
-	@text != push @text, declare_hinthash(
-	    $self->{'hinthash'}, $op->hints_hash->HASH,
-	    $self->{indent_size}
-	)
-    ) {
-	$self->{'hinthash'} = $op->hints_hash->HASH;
+    my $newhh;
+    if ($] > 5.009) {
+	$newhh = $op->hints_hash->HASH;
+    }
+
+    if ($] >= 5.015006) {
+	# feature bundle hints
+	my $from = $old_hints & $feature_bundle_mask;
+	my $to   = $    hints & $feature_bundle_mask;
+	if ($from != $to) {
+	    require feature;
+	    if ($to == $feature_bundle_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()},
+		);
+	    }
+	    else {
+		my $bundle =
+		    $feature::hint_bundles[$to >> $feature::hint_shift];
+		$bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
+		push @text, "no feature;\n",
+			    "use feature ':$bundle';\n";
+	    }
+	}
+    }
+
+    if ($] > 5.009) {
+	push @text, declare_hinthash(
+	    $self->{'hinthash'}, $newhh,
+	    $self->{indent_size}, $self->{hints},
+	);
+	$self->{'hinthash'} = $newhh;
     }
 
     # This should go after of any branches that add statements, to
@@ -1532,10 +1568,13 @@ my %ignored_hints = (
 );
 
 sub declare_hinthash {
-    my ($from, $to, $indent) = @_;
+    my ($from, $to, $indent, $hints) = @_;
+    my $doing_features = $^V lt 5.15.6 ||
+	($hints & $feature_bundle_mask) == $feature_bundle_mask;
     my @decls;
-    for my $key (keys %$to) {
+    for my $key (sort keys %$to) {
 	next if $ignored_hints{$key};
+	next if $key =~ /^feature_/ and not $doing_features;
 	if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
 	    push @decls,
 		qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
@@ -1547,8 +1586,9 @@ sub declare_hinthash {
 	      . qq(;);
 	}
     }
-    for my $key (keys %$from) {
+    for my $key (sort keys %$from) {
 	next if $ignored_hints{$key};
+	next if $key =~ /^feature_/ and not $doing_features;
 	if (!exists $to->{$key}) {
 	    push @decls, qq(delete \$^H{'$key'};);
 	}
@@ -1583,8 +1623,6 @@ my %feature_keywords = (
     __SUB__ => '__SUB__',
 );
 
-my $feature_bundle_mask = 0x1c000000;
-
 sub keyword {
     my $self = shift;
     my $name = shift;
diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t
index 92917fd276..f13d6b0472 100644
--- a/dist/B-Deparse/t/deparse.t
+++ b/dist/B-Deparse/t/deparse.t
@@ -784,8 +784,8 @@ print /a/u, s/b/c/u;
     print /a/d, s/b/c/d;
 }
 {
-    BEGIN { $^H{'reflags_charset'} = '2';
-	    $^H{'reflags'}         = '0'; }
+    BEGIN { $^H{'reflags'}         = '0';
+	    $^H{'reflags_charset'} = '2'; }
     print /a/d, s/b/c/d;
 }
 ####
@@ -853,12 +853,8 @@ CORE::given ($x) {
 CORE::evalbytes '';
 () = CORE::__SUB__;
 >>>>
-BEGIN {
-    $^H{'feature___SUB__'} = '1';
-    $^H{'feature_unieval'} = '1';
-    $^H{'feature_unicode'} = '1';
-    $^H{'feature_evalbytes'} = '1';
-}
+no feature;
+use feature ':default';
 CORE::state $x;
 CORE::say $x;
 CORE::given ($x) {
@@ -872,6 +868,32 @@ CORE::given ($x) {
 CORE::evalbytes '';
 () = CORE::__SUB__;
 ####
+# Feature hints
+use feature 'current_sub', 'evalbytes';
+print;
+use 1;
+print;
+use 5.014;
+print;
+no feature 'unicode_strings';
+print;
+>>>>
+BEGIN {
+    $^H{'feature___SUB__'} = '1';
+    $^H{'feature_evalbytes'} = '1';
+}
+print $_;
+no feature;
+use feature ':default';
+print $_;
+no feature;
+use feature ':5.12';
+print $_;
+BEGIN {
+    delete $^H{'feature_unicode'};
+}
+print $_;
+####
 # $#- $#+ $#{%} etc.
 my @x;
 @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
diff --git a/lib/feature.pm b/lib/feature.pm
index ff1dd6d44a..8dfb7aaf4b 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -7,7 +7,7 @@ package feature;
 
 our $VERSION = '1.25';
 
-my %feature = (
+our %feature = (
     say             => 'feature_say',
     state           => 'feature_state',
     switch          => 'feature_switch',
@@ -31,9 +31,9 @@ $feature_bundle{"5.14"} = $feature_bundle{"5.11"};
 $feature_bundle{"5.16"} = $feature_bundle{"5.15"};
 $feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
 
-my $hint_shift   = 26;
-my $hint_mask    = 0x1c000000;
-my @hint_bundles = qw( default 5.10 5.11 5.15 );
+our $hint_shift   = 26;
+our $hint_mask    = 0x1c000000;
+our @hint_bundles = qw( default 5.10 5.11 5.15 );
 
 # This gets set (for now) in $^H as well as in %^H,
 # for runtime speed of the uc/lc/ucfirst/lcfirst functions.
diff --git a/regen/feature.pl b/regen/feature.pl
index cea90fb393..a10ceb8658 100755
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -136,7 +136,7 @@ sub longest {
     $long;
 }
 
-print $pm "my %feature = (\n";
+print $pm "our %feature = (\n";
 my $width = length longest keys %feature;
 for(sort { length $a <=> length $b } keys %feature) {
     print $pm "    $_" . " "x($width-length)
@@ -161,9 +161,9 @@ for (sort keys %Aliases) {
 
 print $pm <<EOPM;
 
-my \$hint_shift   = $HintShift;
-my \$hint_mask    = $HintMask;
-my \@hint_bundles = qw( @HintedBundles );
+our \$hint_shift   = $HintShift;
+our \$hint_mask    = $HintMask;
+our \@hint_bundles = qw( @HintedBundles );
 EOPM