From: Father Chrysostomos <sprout@cpan.org>
Date: Tue, 19 Jan 2010 20:35:04 +0000 (-0500)
Subject: fix qr// and get-magic problems
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=455d90333d711fa09eaa6dbc81d437cdac3723d0;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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',
+ );
+}