Don't Deparse "${$}abc" as "$$abc"

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

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index cc439ae..b19b40f 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -19,6 +19,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
          OPpSPLIT_ASSIGN OPpSPLIT_LEX
          OPpPADHV_ISKEYS OPpRV2HV_ISKEYS
+         OPpCONCAT_NESTED
          OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
          OPpTRUEBOOL OPpINDEX_BOOLNEG
         SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
@@ -51,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-$VERSION = '1.45';
+$VERSION = '1.46';
 use strict;
 our $AUTOLOAD;
 use warnings ();
@@ -655,7 +656,8 @@ sub stash_subs {
        if ($seen ||= {})->{
            $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
           }++;
-    my %stash = svref_2object($stash)->ARRAY;
+    my $stashobj = svref_2object($stash);
+    my %stash = $stashobj->ARRAY;
     while (my ($key, $val) = each %stash) {
        my $flags = $val->FLAGS;
        if ($flags & SVf_ROK) {
@@ -696,7 +698,20 @@ sub stash_subs {
        } elsif (class($val) eq "GV") {
            if (class(my $cv = $val->CV) ne "SPECIAL") {
                next if $self->{'subs_done'}{$$val}++;
-               next if $$val != ${$cv->GV};   # Ignore imposters
+
+                # Ignore imposters (aliases etc)
+                my $name = $cv->NAME_HEK;
+                if(defined $name) {
+                    # avoid using $cv->GV here because if the $val GV is
+                    # an alias, CvGV() could upgrade the real stash entry
+                    # from an RV to a GV
+                    next unless $name eq $key;
+                    next unless $$stashobj == ${$cv->STASH};
+                }
+                else {
+                   next if $$val != ${$cv->GV};
+                }
+
                $self->todo($cv, 0);
            }
            if (class(my $cv = $val->FORM) ne "SPECIAL") {
@@ -1878,7 +1893,7 @@ sub maybe_qualify {
        if
            $name =~ /^(?!\d)\w/         # alphabetic
         && $v    !~ /^\$[ab]\z/         # not $a or $b
-        && $v =~ /\A[\$\@\%]/           # scalar, array, or hash
+        && $v =~ /\A[\$\@\%\&]/         # scalar, array, hash, or sub
         && !$globalnames{$name}         # not a global name
         && $self->{hints} & $strict_bits{vars}  # strict vars
         && !$self->lex_in_scope($v,1)   # no "our"
@@ -3033,7 +3048,8 @@ sub real_concat {
     my $right = $op->last;
     my $eq = "";
     my $prec = 18;
-    if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
+    if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) {
+        # '.=' rather than optimised '.'
        $eq = "=";
        $prec = 7;
     }
@@ -4023,15 +4039,29 @@ sub pp_padsv {
 
 sub pp_padav { pp_padsv(@_) }
 
+# prepend 'keys' where its been optimised away, with suitable handling
+# of CORE:: and parens
+
+sub add_keys_keyword {
+    my ($self, $str, $cx) = @_;
+    $str = $self->maybe_parens($str, $cx, 16);
+    # 'keys %h' versus 'keys(%h)'
+    $str = " $str" unless $str =~ /^\(/;
+    return $self->keyword("keys") . $str;
+}
+
 sub pp_padhv {
-    my $op = $_[1];
-    my $keys = '';
+    my ($self, $op, $cx) = @_;
+    my $str =  pp_padsv(@_);
     # with OPpPADHV_ISKEYS the keys op is optimised away, except
     # in scalar context the old op is kept (but not executed) so its targ
     # can be used.
-    $keys = 'keys ' if (     ($op->private & OPpPADHV_ISKEYS)
-                            && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR));
-    $keys . pp_padsv(@_);
+    if (     ($op->private & OPpPADHV_ISKEYS)
+        && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR))
+    {
+        $str = $self->add_keys_keyword($str, $cx);
+    }
+    $str;
 }
 
 sub gv_or_padgv {
@@ -4119,9 +4149,12 @@ sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
 
 sub pp_rv2hv {
-    my $op = $_[1];
-    (($op->private & OPpRV2HV_ISKEYS) ? 'keys ' : '')
-        . maybe_local(@_, rv2x(@_, "%"))
+    my ($self, $op, $cx) = @_;
+    my $str = rv2x(@_, "%");
+    if ($op->private & OPpRV2HV_ISKEYS) {
+        $str = $self->add_keys_keyword($str, $cx);
+    }
+    return maybe_local(@_, $str);
 }
 
 # skip rv2av
@@ -4372,8 +4405,12 @@ sub do_multiconcat {
         # "foo=$foo bar=$bar "
         my $not_first;
         while (@consts) {
-            $rhs = dq_disambiguate($rhs, $self->dq(shift(@kids), 18))
-                if $not_first;
+            if ($not_first) {
+                my $s = $self->dq(shift(@kids), 18);
+                # don't deparse "a${$}b" as "a$$b"
+                $s = '${$}' if $s eq '$$';
+                $rhs = dq_disambiguate($rhs, $s);
+            }
             $not_first = 1;
             my $c = shift @consts;
             if (defined $c) {
@@ -4883,7 +4920,7 @@ sub pp_entersub {
            $proto = $cv->PV if $cv->FLAGS & SVf_POK;
        }
        $simple = 1; # only calls of named functions can be prototyped
-       $kid = $self->maybe_qualify("&", $self->gv_name($gv));
+       $kid = $self->maybe_qualify("!", $self->gv_name($gv));
        my $fq;
        # Fully qualify any sub name that conflicts with a lexical.
        if ($self->lex_in_scope("&$kid")