Deparse: avoid upgrading RV to GV in stash entries

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

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 00e31d3..0cbb890 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") {
@@ -1778,7 +1793,6 @@ sub gv_name {
     {
        $stash = "";
     } else {
-       $stash = "::$stash" if $stash eq "CORE";
        $stash = $stash . "::";
     }
     if (!$raw and $name =~ /^(\^..|{)/) {
@@ -1794,7 +1808,7 @@ sub gv_name {
 sub stash_variable {
     my ($self, $prefix, $name, $cx) = @_;
 
-    return "$prefix$name" if $name =~ /::/;
+    return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/;
 
     unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
            $prefix eq '%' || $prefix eq '$#') {
@@ -1870,11 +1884,16 @@ sub stash_variable_name {
 sub maybe_qualify {
     my ($self,$prefix,$name) = @_;
     my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
-    return $name if !$prefix || $name =~ /::/;
+    if ($prefix eq "") {
+       $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/;
+       return $name;
+    }
+    return $name if $name =~ /::/;
     return $self->{'curstash'}.'::'. $name
        if
            $name =~ /^(?!\d)\w/         # alphabetic
         && $v    !~ /^\$[ab]\z/         # not $a or $b
+        && $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"
@@ -3029,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;
     }
@@ -4019,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 {
@@ -4052,7 +4086,7 @@ sub pp_gv {
     my $self = shift;
     my($op, $cx) = @_;
     my $gv = $self->gv_or_padgv($op);
-    return $self->gv_name($gv);
+    return $self->maybe_qualify("", $self->gv_name($gv));
 }
 
 sub pp_aelemfast_lex {
@@ -4089,7 +4123,8 @@ sub rv2x {
     }
     my $kid = $op->first;
     if ($kid->name eq "gv") {
-       return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
+       return $self->stash_variable($type,
+                   $self->gv_name($self->gv_or_padgv($kid)), $cx);
     } elsif (is_scalar $kid) {
        my $str = $self->deparse($kid, 0);
        if ($str =~ /^\$([^\w\d])\z/) {
@@ -4114,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
@@ -4572,6 +4610,7 @@ sub pp_gelem {
     my $scope = is_scope($glob);
     $glob = $self->deparse($glob, 0);
     $part = $self->deparse($part, 1);
+    $glob =~ s/::\z// unless $scope;
     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
 }
 
@@ -4877,7 +4916,7 @@ sub pp_entersub {
            $proto = $cv->PV if $cv->FLAGS & SVf_POK;
        }
        $simple = 1; # only calls of named functions can be prototyped
-       $kid = $self->deparse($kid, 24);
+       $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")