B::Deparse: stub implementation of deparsing lexical subs

This doesn't work properly, but (a) it's better than nothing, and (b) it
suppresses some unsightly "unexpected OP_INTROCV" warnings from the test
suite, fixing RT #116821.

1 files changed, 44 insertions, 3 deletions

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 0241c14128..533a98ae28 100644
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -1323,7 +1323,8 @@ sub scopeop {
 	push @kids, $kid;
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
-	return "do {\n\t" . $self->lineseq($op, 0, @kids) . "\n\b}";
+	my $body = $self->lineseq($op, 0, @kids);
+	return is_lexical_subs(@kids) ? $body : "do {\n\t$body\n\b}";
     } else {
 	my $lineseq = $self->lineseq($op, $cx, @kids);
 	return (length ($lineseq) ? "$lineseq;" : "");
@@ -3426,7 +3427,7 @@ sub is_subscriptable {
 	$kid = $kid->sibling until null $kid->sibling;
 	return 0 if is_scope($kid);
 	$kid = $kid->first;
-	return 0 if $kid->name eq "gv";
+	return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
 	return 0 if is_scalar($kid);
 	return is_subscriptable($kid);	
     } else {
@@ -3790,7 +3791,7 @@ sub pp_entersub {
 	$kid = $self->deparse($kid, 24);
     } else {
 	$prefix = "";
-	my $arrow = is_subscriptable($kid->first) ? "" : "->";
+	my $arrow = is_subscriptable($kid->first) || $kid->first->name eq "padcv" ? "" : "->";
 	$kid = $self->deparse($kid, 24) . $arrow;
     }
 
@@ -4889,6 +4890,36 @@ sub pp_subst {
     }
 }
 
+sub is_lexical_subs {
+    my (@ops) = shift;
+    for my $op (@ops) {
+        return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
+    }
+    return 1;
+}
+
+sub pp_introcv {
+    my $self = shift;
+    my($op, $cx) = @_;
+    # For now, deparsing doesn't worry about the distinction between introcv
+    # and clonecv, so pretend this op doesn't exist:
+    return '';
+}
+
+sub pp_clonecv {
+    my $self = shift;
+    my($op, $cx) = @_;
+    my $sv = $self->padname_sv($op->targ);
+    my $name = substr $sv->PVX, 1; # skip &/$/@/%, like $self->padany
+    return "my sub $name";
+}
+
+sub pp_padcv {
+    my $self = shift;
+    my($op, $cx) = @_;
+    return $self->padany($op);
+}
+
 1;
 __END__
 
@@ -5380,6 +5411,16 @@ defined within a different scope, although L<PadWalker> is a good start.
 
 There are probably many more bugs on non-ASCII platforms (EBCDIC).
 
+=item *
+
+Lexical C<my> subroutines are not deparsed properly at the moment.  They are
+emitted as pure declarations, without their body; and the declaration may
+appear in the wrong place (before any lexicals the body closes over, or
+before the C<use feature> declaration that permits use of this feature).
+
+We expect to resolve this before the lexical-subroutine feature is no longer
+considered experimental.
+
 =back
 
 =head1 AUTHOR