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.

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index b78ef67..3c1dd08 100644 (file)
--- 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 92917fd..f13d6b0 100644 (file)
--- 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 ff1dd6d..8dfb7aa 100644 (file)
--- 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 cea90fb..a10ceb8 100755 (executable)
--- 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