[perl #115066] Fix wrongly nested ‘use’ deparsing

[perl5.git] / lib / B / Deparse.pm

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 523a194..1e42ef1 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -323,7 +323,8 @@ BEGIN {
 
 
 
-BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem]) {
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
+                custom ]) {
     eval "sub OP_\U$_ () { " . opnumber($_) . "}"
 }}
 
@@ -1311,7 +1312,8 @@ sub maybe_my {
 
 sub AUTOLOAD {
     if ($AUTOLOAD =~ s/^.*::pp_//) {
-       warn "unexpected OP_".uc $AUTOLOAD;
+       warn "unexpected OP_".
+         ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
        return "XXX";
     } else {
        die "Undefined subroutine $AUTOLOAD called";
@@ -1643,10 +1645,18 @@ sub seq_subs {
 #push @text, "# ($seq)\n";
 
     return "" if !defined $seq;
+    my @pending;
     while (scalar(@{$self->{'subs_todo'}})
           and $seq > $self->{'subs_todo'}[0][0]) {
+       my $cv = $self->{'subs_todo'}[0][1];
+       my $outside = $cv && $cv->OUTSIDE;
+       if ($cv and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) {
+           push @pending, shift @{$self->{'subs_todo'}};
+           next;
+       }
        push @text, $self->next_todo;
     }
+    unshift @{$self->{'subs_todo'}}, @pending;
     return @text;
 }
 
@@ -2635,8 +2645,10 @@ sub real_concat {
     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
 }
 
+sub pp_repeat { maybe_targmy(@_, \&repeat) }
+
 # 'x' is weird when the left arg is a list
-sub pp_repeat {
+sub repeat {
     my $self = shift;
     my($op, $cx) = @_;
     my $left = $op->first;
@@ -2828,7 +2840,7 @@ sub pp_substr {
     }
     maybe_local(@_, listop(@_, "substr"))
 }
-sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
 sub pp_index { maybe_targmy(@_, \&listop, "index") }
 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
@@ -3053,6 +3065,18 @@ sub pp_grepwhile { mapop(@_, "grep") }
 sub pp_mapstart { baseop(@_, "map") }
 sub pp_grepstart { baseop(@_, "grep") }
 
+my %uses_intro;
+BEGIN {
+    @uses_intro{
+       eval { require B::Op_private }
+         ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
+         : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
+              hslice delete padsv padav padhv enteriter entersub padrange
+              pushmark cond_expr refassign list)
+    } = ();
+    delete @uses_intro{qw( lvref lvrefslice lvavref )};
+}
+
 sub pp_list {
     my $self = shift;
     my($op, $cx) = @_;
@@ -3063,27 +3087,10 @@ sub pp_list {
     my $local = "either"; # could be local(...), my(...), state(...) or our(...)
     my $type;
     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
-       # This assumes that no other private flags equal 128, and that
-       # OPs that store things other than flags in their op_private,
-       # like OP_AELEMFAST, won't be immediate children of a list.
-       #
-       # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
-       # I suspect that open and exit can too.
-       # XXX This really needs to be rewritten to accept only those ops
-       #     known to take the OPpLVAL_INTRO flag.
-
        my $lopname = $lop->name;
        my $loppriv = $lop->private;
-       if (!($loppriv & (OPpLVAL_INTRO|OPpOUR_INTRO)
-               or $lopname eq "undef")
-           or $lopname =~ /^(?:entersub|exit|open|split
-                              |lv(?:av)?ref(?:slice)?)\z/x)
-       {
-           $local = ""; # or not
-           last;
-       }
        my $newtype;
-       if ($lopname =~ /^pad[ash]v$/) {
+       if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
            if ($loppriv & OPpPAD_STATE) { # state()
                ($local = "", last) if $local !~ /^(?:either|state)$/;
                $local = "state";
@@ -3109,10 +3116,15 @@ sub pp_list {
               )) {
                $newtype = $t;
            }
-       } elsif ($lopname ne "undef"
-               # specifically avoid the "reverse sort" optimisation,
-               # where "reverse" is nullified
-               && !($lopname eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+       } elsif ($lopname ne 'undef'
+          and    !($loppriv & OPpLVAL_INTRO)
+              || !exists $uses_intro{$lopname eq 'null'
+                                       ? substr B::ppname($lop->targ), 3
+                                       : $lopname})
+       {
+           $local = ""; # or not
+           last;
+       } elsif ($lopname ne "undef")
        {
            # local()
            ($local = "", last) if $local !~ /^(?:either|local)$/;
@@ -3208,7 +3220,9 @@ sub pp_once {
     my $cond = $op->first;
     my $true = $cond->sibling;
 
-    return $self->deparse($true, $cx);
+    my $ret = $self->deparse($true, $cx);
+    $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
+    $ret;
 }
 
 sub loop_common {
@@ -4746,7 +4760,7 @@ sub tr_decode_utf8 {
 
 sub pp_trans {
     my $self = shift;
-    my($op, $cx) = @_;
+    my($op, $cx, $morflags) = @_;
     my($from, $to);
     my $class = class($op);
     my $priv_flags = $op->private;
@@ -4763,10 +4777,16 @@ sub pp_trans {
     $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
     $to = "" if $from eq $to and $flags eq "";
     $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
-    return $self->keyword("tr") . double_delim($from, $to) . $flags;
+    $flags .= $morflags if defined $morflags;
+    my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
+    if (my $targ = $op->targ) {
+       return $self->maybe_parens($self->padname($targ) . " =~ $ret",
+                                  $cx, 20);
+    }
+    return $ret;
 }
 
-sub pp_transr { &pp_trans . 'r' }
+sub pp_transr { push @_, 'r'; goto &pp_trans }
 
 sub re_dq_disambiguate {
     my ($first, $last) = @_;
@@ -4939,6 +4959,10 @@ sub matchop {
        $var = $self->deparse($kid, 20);
        $kid = $kid->sibling;
     }
+    elsif ($name eq 'match' and my $targ = $op->targ) {
+       $binop = 1;
+       $var = $self->padname($targ);
+    }
     my $quote = 1;
     my $pmflags = $op->pmflags;
     my $extended = ($pmflags & PMf_EXTENDED);
@@ -4995,6 +5019,9 @@ sub pp_qr { matchop(@_, "qr", "") }
 sub pp_runcv { unop(@_, "__SUB__"); }
 
 sub pp_split {
+    maybe_targmy(@_, \&split);
+}
+sub split {
     my $self = shift;
     my($op, $cx) = @_;
     my($kid, @exprs, $ary, $expr);
@@ -5075,6 +5102,10 @@ sub pp_subst {
        $var = $self->deparse($kid, 20);
        $kid = $kid->sibling;
     }
+    elsif (my $targ = $op->targ) {
+       $binop = 1;
+       $var = $self->padname($targ);
+    }
     my $flags = "";
     my $pmflags = $op->pmflags;
     if (null($op->pmreplroot)) {
@@ -5631,7 +5662,8 @@ the main:: package, the code will include a package declaration.
 
 =item *
 
-The only pragmas to be completely supported are: C<use warnings>,
+In Perl 5.20 and earlier, the only pragmas to
+be completely supported are: C<use warnings>,
 C<use strict>, C<use bytes>, C<use integer>
 and C<use feature>.  (C<$[>, which
 behaves like a pragma, is also supported.)
@@ -5652,8 +5684,8 @@ exactly the right place.  So if you use a module which affects compilation
 (such as by over-riding keywords, overloading constants or whatever)
 then the output code might not work as intended.
 
-This is the most serious outstanding problem, and will require some help
-from the Perl core to fix.
+This is the most serious problem in Perl 5.20 and earlier.  Fixing this
+required internal changes in Perl 5.22.
 
 =item *
 
@@ -5674,7 +5706,7 @@ produced is already ordinary Perl which shouldn't be filtered again.
 
 =item *
 
-Optimised away statements are rendered as
+Optimized-away statements are rendered as
 '???'.  This includes statements that
 have a compile-time side-effect, such as the obscure