deparse pragmas before subs

Currently something like this:

    use strict;
    sub f {
        print;
    }
    print;

deparses as:

    sub f {
        use strict;
        print $_;
    }
    use strict;
    print $_;

(Note where the 'strict's appear). Although ugly, this is semantically
correct for most pragmas. However, it breaks down for "use feature
'signatures'", since that needs to appear before the sub if the
deparsing of the sub's header is altered to reflect signature syntax or
not, based on whether the pragma is in scope.

This commit changes the deparsing of each nextstate op so that it outputs
any pragmas which reflect changes since the last nextstate's hints etc,
*before* deparsing any subs whose COP is less than that of the new
nextstate. After this commit, the code above deparses as:

    use strict;
    sub f {
        print $_;
    }
    print $_;

It also allows some hacky code to be removed from Deparse.pm that
ensured that "no warnings experimental::lexical_subs" appeared before
each lexical sub was deparsed.

[ This fix is not comprehensive; a fuller fix comes in a few commits time ]

diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t
index b42ad0a..247869c 100644 (file)
--- a/lib/B/Deparse-core.t
+++ b/lib/B/Deparse-core.t
@@ -102,9 +102,11 @@ sub testit {
 
        unless ($got_text =~ /
     package (?:lexsub)?test;
-    use strict 'refs', 'subs';
+(?:    BEGIN \{\$\{\^WARNING_BITS\} = "[^"]+"\}
+)?    use strict 'refs', 'subs';
     use feature [^\n]+
-    \Q$vars\E\(\) = (.*)
+(?:    (?:CORE::)?state sub \w+;
+)?    \Q$vars\E\(\) = (.*)
 }/s) {
            ::fail($desc);
            ::diag("couldn't extract line from boilerplate\n");

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 7e4c55c..1ee584e 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -495,46 +495,8 @@ sub next_todo {
     my $ent = shift @{$self->{'subs_todo'}};
     my $cv = $ent->[1];
     if (ref $ent->[3]) { # lexical sub
+       # emit the sub.
        my @text;
-
-       # At this point, we may not yet have deparsed the hints that allow
-       # lexical subroutines to be recognized.  So adjust the current
-       # hints and deparse them.
-       # When lex subs cease being experimental, we should be able to
-       # remove this code.
-       {
-           local $^H = $self->{'hints'};
-           local %^H = %{ $self->{'hinthash'} || {} };
-           local ${^WARNING_BITS} = $self->{'warnings'};
-           feature->import("lexical_subs");
-           warnings->unimport("experimental::lexical_subs");
-           # Here we depend on the fact that individual features
-           # will always set the feature bundle to ‘custom’
-           # (== $feature::hint_mask).  If we had another specific bundle
-           # enabled previously, normalise it.
-           if (($self->{'hints'} & $feature::hint_mask)
-                   != $feature::hint_mask)
-           {
-               if ($self->{'hinthash'}) {
-                   delete $self->{'hinthash'}{$_}
-                       for grep /^feature_/, keys %{$self->{'hinthash'}};
-               }
-               else { $self->{'hinthash'} = {} }
-               $self->{'hinthash'}
-                   = _features_from_bundle(@$self{'hints','hinthash'});
-           }
-           push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
-                                               $self->{indent_size}, $^H);
-           push @text, $self->declare_warnings($self->{'warnings'},
-                                               ${^WARNING_BITS})
-               unless ($self->{'warnings'} // 'u')
-                   eq (${^WARNING_BITS   } // 'u');
-           $self->{'warnings'} = ${^WARNING_BITS};
-           $self->{'hints'} = $^H;
-           $self->{'hinthash'} = {%^H};
-       }
-
-       # Now emit the sub itself.
        my $padname = $ent->[3];
        my $flags = $padname->FLAGS;
        push @text,
@@ -560,6 +522,7 @@ sub next_todo {
        }
        return join "", @text;
     }
+
     my $gv = $cv->GV;
     my $name = $ent->[3] // $self->gv_name($gv);
     if ($ent->[2]) {
@@ -1946,11 +1909,7 @@ sub pp_nextstate {
     my($op, $cx) = @_;
     $self->{'curcop'} = $op;
     my @text;
-    push @text, $self->cop_subs($op);
-    if (@text) {
-       # Special marker to swallow up the semicolon
-       push @text, "\cK";
-    }
+
     my $stash = $op->stashpv;
     if ($stash ne $self->{'curstash'}) {
        push @text, $self->keyword("package") . " $stash;\n";
@@ -2029,6 +1988,21 @@ sub pp_nextstate {
        $self->{'hinthash'} = $newhh;
     }
 
+    my @subs = $self->cop_subs($op);
+    if (@subs) {
+       # Special marker to swallow up the semicolon
+       push @subs, "\cK";
+    }
+    push @text, @subs;
+
+    # cop_subs above may have changed the package; restore it
+    $stash = $op->stashpv;
+    if ($stash ne $self->{'curstash'}) {
+       push @text, $self->keyword("package") . " $stash;\n";
+       $self->{'curstash'} = $stash;
+    }
+
+
     # This should go after of any branches that add statements, to
     # increase the chances that it refers to the same line it did in
     # the original program.
@@ -6316,7 +6290,7 @@ which is not, consequently, deparsed correctly.
 =item *
 
 Lexical (my) variables declared in scopes external to a subroutine
-appear in code2ref output text as package variables.  This is a tricky
+appear in coderef2text output text as package variables.  This is a tricky
 problem, as perl has no native facility for referring to a lexical variable
 defined within a different scope, although L<PadWalker> is a good start.
 

diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index ba24c27..7dd056d 100644 (file)
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -87,7 +87,12 @@ EOC
        $regex =~ s/\s+/\\s+/g;
        $regex = '^\{\s*' . $regex . '\s*\}$';
 
-        like($deparsed, qr/$regex/, $desc);
+        like($deparsed, qr/$regex/, $desc)
+            or diag "=============================================\n"
+                  . "CODE:\n--------\n$input\n--------\n"
+                  . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n"
+                  . "GOT:\n--------\n$deparsed\n--------\n"
+                  . "=============================================\n";
     }
 }
 
@@ -376,7 +381,7 @@ like($a, qr/my sub use;\nCORE::use less;/,
 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
              .qq`"use feature q|:all|; my sub __DATA__; `
              .qq`CORE::__DATA__" 2>&1`;
-like($a, qr/my sub __DATA__;\n.*\nCORE::__DATA__/s,
+like($a, qr/my sub __DATA__;\nCORE::__DATA__/s,
     'CORE::__DATA__ after my sub __DATA__');
 
 # sub declarations
@@ -1946,12 +1951,10 @@ no warnings "experimental::lexical_subs";
 my sub f {}
 print f();
 >>>>
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"}
+BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
 my sub f {
-    BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
     
 }
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
 print f();
 ####
 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
@@ -1961,12 +1964,10 @@ no warnings 'experimental::lexical_subs';
 state sub f {}
 print f();
 >>>>
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"}
+BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
 state sub f {
-    BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
     
 }
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
 print f();
 ####
 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"