diff options
| -rw-r--r-- | pp_ctl.c | 20 | ||||
| -rw-r--r-- | pp_hot.c | 6 | ||||
| -rw-r--r-- | t/re/qr.t | 62 |
3 files changed, 86 insertions, 2 deletions
@@ -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); @@ -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; @@ -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|; +} |