[perl #70764] $' fails to initialized for pre-compiled regular expression matches

The match vars are associated with the regexp that last matched
successfully. In the case of $str =~ $qr or /$qr/, since the $qr could
be used in multiple scopes that need their own sets of match vars, the
$qr is cloned by Perl_reg_temp_copy as of change 30677/28d8d7f. This
happens in pp_regcomp before pp_match has stringified the LHS, hence the
bug. In short, /$gror/ is not equivalent to
($which = !$which) ? /$gror/ : /$gror/, which is weird.

Attached is a patch, which admittedly is a hack, but fixes this
particular side effect of what is probably a bad design, by stringifying
the LHS in pp_regcomp, and having pp_match skip get-magic in such cases.
A real fix far exceeds my capabalities, and would also be very intrusive
according to
<http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html>.

diff --git a/pp_ctl.c b/pp_ctl.c
index b196640..27d94bc 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -149,6 +149,26 @@ PP(pp_regcomp)
        re = (REGEXP*) tmpstr;
 
     if (re) {
+       /* The match's LHS's get-magic might need to access this op's reg-
+          exp (as is sometimes the case with $';  see bug 70764).  So we
+          must call get-magic now before we replace the regexp. Hopeful-
+          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)
+           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;
+
        re = reg_temp_copy(NULL, re);
        ReREFCNT_dec(PM_GETRE(pm));
        PM_SETRE(pm, re);

diff --git a/pp_hot.c b/pp_hot.c
index 2c2edcd..a8aa4ba 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1261,7 +1261,11 @@ PP(pp_match)
     }
 
     PUTBACK;                           /* EVAL blocks need stack_sp. */
-    s = SvPV_const(TARG, len);
+    /* Skip get-magic if this is a qr// clone, because regcomp has
+       already done it. */
+    s = ((struct regexp *)SvANY(rx))->mother_re
+        ? SvPV_nomg_const(TARG, len)
+        : SvPV_const(TARG, len);
     if (!s)
        DIE(aTHX_ "panic: pp_match");
     strend = s + len;

diff --git a/t/re/qr.t b/t/re/qr.t
index ff9449e..6d2baeb 100644 (file)
--- a/t/re/qr.t
+++ b/t/re/qr.t
@@ -6,8 +6,68 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 1;
+plan tests => 4;
 
 my $rx = qr//;
 
 is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default");
+
+
+# Make sure /$qr/ doesn’t clobber match vars before the match (bug 70764).
+{
+ my $output = '';
+ my $rx = qr/o/;
+ my $a = "ooaoaoao";
+
+ my $foo = 0;
+ $foo += () = ($a =~ /$rx/g);
+ $output .= "$foo\n"; # correct
+
+ $foo = 0;
+ for ($foo += ($a =~ /o/); $' && ($' =~ /o/) && ($foo++) ; ) { ; }
+ $output .= "1: $foo\n"; # No error
+
+ $foo = 0;
+ for ($foo += ($a =~ /$rx/); $' && ($' =~ /$rx/) && ($foo++) ; ) { ; }
+ $output .= "2: $foo\n"; # initialization warning, incorrect results
+
+ is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/';
+}
+for my $_($'){
+ my $output = '';
+ my $rx = qr/o/;
+ my $a = "ooaoaoao";
+
+ my $foo = 0;
+ $foo += () = ($a =~ /$rx/g);
+ $output .= "$foo\n"; # correct
+
+ $foo = 0;
+ for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; }
+ $output .= "1: $foo\n"; # No error
+
+ $foo = 0;
+ for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; }
+ $output .= "2: $foo\n"; # initialization warning, incorrect results
+
+ is $output, "5\n1: 5\n2: 5\n", '/$qr/ with my $_ aliased to a match var';
+}
+for($'){
+ my $output = '';
+ my $rx = qr/o/;
+ my $a = "ooaoaoao";
+
+ my $foo = 0;
+ $foo += () = ($a =~ /$rx/g);
+ $output .= "$foo\n"; # correct
+
+ $foo = 0;
+ for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; }
+ $output .= "1: $foo\n"; # No error
+
+ $foo = 0;
+ for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; }
+ $output .= "2: $foo\n"; # initialization warning, incorrect results
+
+ is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|;
+}