Re: [PATCH] Deparse.pm bugfix

Message-Id: <A4BDE74B-DB3A-41C0-B2BE-FCEE0E15AB54@hagernas.com>

p4raw-id: //depot/perl@29512

2 files changed, 44 insertions, 26 deletions

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index b2fc7e34a7..1316c547a5 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
          CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
 	 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
 	 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.78;
+$VERSION = 0.79;
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -2922,17 +2922,15 @@ sub is_subscriptable {
     }
 }
 
-sub elem {
+sub elem_or_slice_array_name
+{
     my $self = shift;
-    my ($op, $cx, $left, $right, $padname) = @_;
-    my($array, $idx) = ($op->first, $op->first->sibling);
-    unless ($array->name eq $padname) { # Maybe this has been fixed	
-	$array = $array->first; # skip rv2av (or ex-rv2av in _53+)
-    }
+    my ($array, $left, $padname, $allow_arrow) = @_;
+
     if ($array->name eq $padname) {
-	$array = $self->padany($array);
+	return $self->padany($array);
     } elsif (is_scope($array)) { # ${expr}[0]
-	$array = "{" . $self->deparse($array, 0) . "}";
+	return "{" . $self->deparse($array, 0) . "}";
     } elsif ($array->name eq "gv") {
 	$array = $self->gv_name($self->gv_or_padgv($array));
 	if ($array !~ /::/) {
@@ -2940,14 +2938,19 @@ sub elem {
 	    $array = $self->{curstash}.'::'.$array
 		if $self->lex_in_scope($prefix . $array);
 	}
-    } elsif (is_scalar $array) { # $x[0], $$x[0], ...
-	$array = $self->deparse($array, 24);
+	return $array;
+    } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
+	return $self->deparse($array, 24);
     } else {
-	# $x[20][3]{hi} or expr->[20]
-	my $arrow = is_subscriptable($array) ? "" : "->";
-	return $self->deparse($array, 24) . $arrow .
-	    $left . $self->deparse($idx, 1) . $right;
+	return undef;
     }
+}
+
+sub elem_or_slice_single_index
+{
+    my $self = shift;
+    my ($idx) = @_;
+
     $idx = $self->deparse($idx, 1);
 
     # Outer parens in an array index will confuse perl
@@ -2978,7 +2981,28 @@ sub elem {
     #
     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
 
-    return "\$" . $array . $left . $idx . $right;
+    return $idx;
+}
+
+sub elem {
+    my $self = shift;
+    my ($op, $cx, $left, $right, $padname) = @_;
+    my($array, $idx) = ($op->first, $op->first->sibling);
+
+    $idx = $self->elem_or_slice_single_index($idx);
+
+    unless ($array->name eq $padname) { # Maybe this has been fixed	
+	$array = $array->first; # skip rv2av (or ex-rv2av in _53+)
+    }
+    if (my $array_name=$self->elem_or_slice_array_name
+	    ($array, $left, $padname, 1)) {
+	return "\$" . $array_name . $left . $idx . $right;
+    } else {
+	# $x[20][3]{hi} or expr->[20]
+	my $arrow = is_subscriptable($array) ? "" : "->";
+	return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
+    }
+
 }
 
 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
@@ -3010,13 +3034,7 @@ sub slice {
     $array = $last;
     $array = $array->first
 	if $array->name eq $regname or $array->name eq "null";
-    if (is_scope($array)) {
-	$array = "{" . $self->deparse($array, 0) . "}";
-    } elsif ($array->name eq $padname) {
-	$array = $self->padany($array);
-    } else {
-	$array = $self->deparse($array, 24);
-    }
+    $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
     $kid = $op->first->sibling; # skip pushmark
     if ($kid->name eq "list") {
 	$kid = $kid->first->sibling; # skip list, pushmark
@@ -3025,7 +3043,7 @@ sub slice {
 	}
 	$list = join(", ", @elems);
     } else {
-	$list = $self->deparse($kid, 1);
+	$list = $self->elem_or_slice_single_index($kid);
     }
     return "\@" . $array . $left . $list . $right;
 }
@@ -4025,7 +4043,7 @@ sub pure_string {
         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
 
 	return 0 unless ${$join_op->sibling} eq ${$op->last};
-	return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
+	return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
     }
     elsif ($type eq 'concat') {
 	return $self->pure_string($op->first)
diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index 17f9df477f..a83bc16caf 100644
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -117,7 +117,7 @@ use Getopt::Std;
 use Carp;
 use Test::More tests => ( # per-pkg tests (function ct + require_ok)
 			  40 + 16	# Data::Dumper, Digest::MD5
-			  + 515 + 236	# B::Deparse, B
+			  + 517 + 236	# B::Deparse, B
 			  + 595 + 190	# POSIX, IO::Socket
 			  + 3 * ($] > 5.009)
 			  + 16 * ($] >= 5.009003)