Deparse: handle OP_PADRANGE in regex code blocks

Deparse handles the OP_PADRANGE op by overlaying the view of the optree
with the original pad ops (as if they had never been optimised into a
single OP_PADRANGE op).

However, the op treewalk to pessimise such ops wasn't walking into
the op subtrees of code blocks in patterns. So for example

    /(?{ my ($x, $y) = @a; })/

was being deparsed (with a warning) as

    /(?{ (XXX) = @a; })/

With this commit, this passes again:

 ./TEST -deparse re/pat_re_eval.t

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 6c35a72..0a68828 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -402,13 +402,27 @@ sub _pessimise_walk {
 
        # pessimisations end here
 
-       if (class($op) eq 'PMOP'
-           && ref($op->pmreplroot)
-           && ${$op->pmreplroot}
-           && $op->pmreplroot->isa( 'B::OP' ))
-       {
-           $self-> _pessimise_walk($op->pmreplroot);
-       }
+       if (class($op) eq 'PMOP') {
+           if (ref($op->pmreplroot)
+                && ${$op->pmreplroot}
+                && $op->pmreplroot->isa( 'B::OP' ))
+            {
+                $self-> _pessimise_walk($op->pmreplroot);
+            }
+
+            # pessimise any /(?{...})/ code blocks
+            my ($re, $cv);
+            my $code_list = $op->code_list;
+            if ($$code_list) {
+                $self->_pessimise_walk($code_list);
+            }
+            elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) {
+                $code_list = $cv->ROOT      # leavesub
+                               ->first      #   qr
+                               ->code_list; #     list
+                $self->_pessimise_walk($code_list);
+            }
+        }
 
        if ($op->flags & OPf_KIDS) {
            $self-> _pessimise_walk($op->first);

diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 154a6f9..381cc2f 100644 (file)
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -2614,3 +2614,10 @@ sub ($a, $=) {
     $a;
 }
 ;
+####
+# padrange op within pattern code blocks
+/(?{ my($x, $y) = (); })/;
+my $a;
+/$a(?{ my($x, $y) = (); })/;
+my $r1 = qr/(?{ my($x, $y) = (); })/;
+my $r2 = qr/$a(?{ my($x, $y) = (); })/;