stop -MO=Concise -e'm?x?' segfaulting

The op_pmreplstart field in a PMOP is actually a union, containing
op_pmreplstart for OP_SUBST, and op_pmstash/op_pmstashoff for OP_MATCH
with PMf_ONCE set.

The B pmreplstart method just blindly treated the value of this field as
an op pointer, even when it wasn't an OP_SUBST. Hence the segfault.
Make it instead return a null pointer when not OP_SUBST.

At the same time I improved the PMOP handling code in Concise.xs so that
it expects particular types for that and the op_pmreplrootu union based on
the op type (OP_SUBST or OP_PUSHRE) rather than trying to handle any field
value regardless of op type.

diff --git a/ext/B/B.pm b/ext/B/B.pm
index b15b80e..8856a32 100644 (file)
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -15,7 +15,7 @@ require Exporter;
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.41';
+    $B::VERSION = '1.42';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.

diff --git a/ext/B/B.xs b/ext/B/B.xs
index bf7e9b1..e2ebdad 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -661,8 +661,7 @@ struct OP_methods {
     STR_WITH_LEN("first"),   OPp,    offsetof(struct unop, op_first),     /* 5*/
     STR_WITH_LEN("last"),    OPp,    offsetof(struct binop, op_last),    /* 6*/
     STR_WITH_LEN("other"),   OPp,    offsetof(struct logop, op_other),   /* 7*/
-    STR_WITH_LEN("pmreplstart"), OPp,
-            offsetof(struct pmop,   op_pmstashstartu.op_pmreplstart),   /* 8*/
+    STR_WITH_LEN("pmreplstart"), 0, -1,                                  /* 8*/
     STR_WITH_LEN("redoop"),  OPp,    offsetof(struct loop, op_redoop),   /* 9*/
     STR_WITH_LEN("nextop"),  OPp,    offsetof(struct loop, op_nextop),   /*10*/
     STR_WITH_LEN("lastop"),  OPp,    offsetof(struct loop, op_lastop),   /*11*/
@@ -1011,6 +1010,13 @@ next(o)
        offset = op_methods[ix].offset;
        if (offset < 0) {
            switch (ix) {
+           case 8: /* pmreplstart */
+               ret = make_op_object(aTHX_
+                               cPMOPo->op_type == OP_SUBST
+                                   ?  cPMOPo->op_pmstashstartu.op_pmreplstart
+                                   : NULL
+                     );
+               break;
 #ifdef USE_ITHREADS
            case 21: /* filegv */
                ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 8bebdfc..67876a1 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
-our $VERSION   = "0.94";
+our $VERSION   = "0.95";
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
                     concise_subref concise_cv concise_main
@@ -824,6 +824,7 @@ sub concise_op {
     $h{arg} = "";
     $h{svclass} = $h{svaddr} = $h{svval} = "";
     if ($h{class} eq "PMOP") {
+       my $extra = '';
        my $precomp = $op->precomp;
        if (defined $precomp) {
            $precomp = cstring($precomp); # Escape literal control sequences
@@ -831,25 +832,30 @@ sub concise_op {
        } else {
            $precomp = "";
        }
-       my $pmreplroot = $op->pmreplroot;
-       my $pmreplstart;
-       if (ref($pmreplroot) eq "B::GV") {
+       if ($op->name eq 'subst') {
+           if (class($op->pmreplstart) ne "NULL") {
+               undef $lastnext;
+               $extra = " replstart->" . seq($op->pmreplstart);
+           }
+       }
+       elsif ($op->name eq 'pushre') {
            # with C<@stash_array = split(/pat/, str);>,
            #  *stash_array is stored in /pat/'s pmreplroot.
-           $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
-       } elsif (!ref($pmreplroot) and $pmreplroot) {
-           # same as the last case, except the value is actually a
-           # pad offset for where the GV is kept (this happens under
-           # ithreads)
-           my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
-           $h{arg} = "($precomp => \@" . $gv->NAME . ")";
-       } elsif ($ {$op->pmreplstart}) {
-           undef $lastnext;
-           $pmreplstart = "replstart->" . seq($op->pmreplstart);
-           $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
-       } else {
-           $h{arg} = "($precomp)";
+           my $gv = $op->pmreplroot;
+           if (!ref($gv)) {
+               # threaded: the value is actually a pad offset for where
+               # the GV is kept (op_pmtargetoff)
+               if ($gv) {
+                   $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
+               }
+           }
+           else {
+               # unthreaded: its a GV (if it exists)
+               $gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef;
+           }
+           $extra = " => \@$gv" if $gv;
        }
+       $h{arg} = "($precomp$extra)";
     } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
        $h{arg} = '("' . $op->pv . '")';
        $h{svval} = '"' . $op->pv . '"';

diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t
index c37b834..6efecdc 100644 (file)
--- a/ext/B/t/optree_misc.t
+++ b/ext/B/t/optree_misc.t
@@ -10,7 +10,7 @@ BEGIN {
 }
 use OptreeCheck;
 use Config;
-plan tests => 16;
+plan tests => 18;
 
 SKIP: {
 skip "no perlio in this build", 4 unless $Config::Config{useperlio};
@@ -431,4 +431,20 @@ EOT_EOT
 EONT_EONT
 
 
+checkOptree ( name      => 'm?x?',
+             code      => sub { m?x?; },
+             strip_open_hints => 1,
+             expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->3
+# 1        <;> nextstate(main 914 optree_misc.t:434) v:{ ->2
+# 2        </> match(/"x"/) /RTIME ->3
+EOT_EOT
+# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->3
+# 1        <;> nextstate(main 914 optree_misc.t:434) v:{ ->2
+# 2        </> match(/"x"/) /RTIME ->3
+EONT_EONT
+
+
 unlink $tmpfile;