fix qr// and get-magic problems

[N.B. I converted package name separators from q{'} to q{::} in
the test files as suggested by demerphq. -- dagolden]

diff --git a/pp_ctl.c b/pp_ctl.c
index d5f2f5d..8c638ac 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -155,19 +155,20 @@ PP(pp_regcomp)
           ly this hack can be replaced with the approach described at
           http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
           /msg122415.html some day. */
-       OP *matchop = pm->op_next;
-       SV *lhs;
-       const bool was_tainted = PL_tainted;
-       if (matchop->op_flags & OPf_STACKED)
+       if(pm->op_type == OP_MATCH) {
+        SV *lhs;
+        const bool was_tainted = PL_tainted;
+        if (pm->op_flags & OPf_STACKED)
            lhs = TOPs;
-       else if (matchop->op_private & OPpTARGET_MY)
-           lhs = PAD_SV(matchop->op_targ);
-       else lhs = DEFSV;
-       SvGETMAGIC(lhs);
-       /* Restore the previous value of PL_tainted (which may have been
-          modified by get-magic), to avoid incorrectly setting the
-          RXf_TAINTED flag further down. */
-       PL_tainted = was_tainted;
+        else if (pm->op_private & OPpTARGET_MY)
+           lhs = PAD_SV(pm->op_targ);
+        else lhs = DEFSV;
+        SvGETMAGIC(lhs);
+        /* Restore the previous value of PL_tainted (which may have been
+           modified by get-magic), to avoid incorrectly setting the
+           RXf_TAINTED flag further down. */
+        PL_tainted = was_tainted;
+       }
 
        re = reg_temp_copy(NULL, re);
        ReREFCNT_dec(PM_GETRE(pm));

diff --git a/t/re/qr.t b/t/re/qr.t
index 6d2baeb..68fddf1 100644 (file)
--- a/t/re/qr.t
+++ b/t/re/qr.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 4;
+plan tests => 5;
 
 my $rx = qr//;
 
@@ -71,3 +71,13 @@ for($'){
 
  is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|;
 }
+
+# Make sure /$qr/ calls get-magic on its LHS (bug ~~~~~).
+{
+ my $scratch;
+ sub qrBug::TIESCALAR{bless[], 'qrBug'}
+ sub qrBug::FETCH { $scratch .= "[fetching]"; 'glat' }
+ tie my $flile, "qrBug";
+ $flile =~ qr/(?:)/;
+ is $scratch, "[fetching]", '/$qr/ with magical LHS';
+}

diff --git a/t/re/subst.t b/t/re/subst.t
index 2f6e759..042f67a 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 142 );
+plan( tests => 143 );
 
 $x = 'foo';
 $_ = "x";
@@ -598,3 +598,19 @@ is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
 fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', '[perl #69056] positive GPOS regex segfault' );
 fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-e][e-f]f', 'positive GPOS regex substitution failure' );
 
+# [perl #~~~~~] $var =~ s/$qr//e calling get-magic on $_ as well as $var
+{
+ local *_;
+ my $scratch;
+ sub qrBug::TIESCALAR { bless[pop], 'qrBug' }
+ sub qrBug::FETCH { $scratch .= "[fetching $_[0][0]]"; 'prew' }
+ sub qrBug::STORE{}
+ tie my $kror, qrBug => '$kror';
+ tie $_, qrBug => '$_';
+ my $qr = qr/(?:)/;
+ $kror =~ s/$qr/""/e;
+ is(
+   $scratch, '[fetching $kror]',
+  'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var',
+ );
+}