[perl #49190] Stringify repl repeatedly in s///g

pm_runtime in op.c examines the rhs of s/// to see whether it is safe
to execute that set of ops just once.  If it sees a match var or an
expression with side effects, it creates a pp_substcont op, which
results in the rhs being executed multiple times.

If the rhs seems constant enough, pp_subst does the substitution in a
tight loop.

This unfortunately causes s/a/$a/ to fail if *a has been aliased to
*1.  Furthermore, $REGMARK and $REGERROR did not count as match vars.

pp_subst actually has two separate loops.  One of them modifies the
target in place.  The other appends to a new scalar and then copies it
back to the target.  The first loop is used if it seems safe.

This commit makes $REGMARK, $REGERROR and aliases to match vars work=
when the replacement consists solely of the variable.

It does this by setting PL_curpm before stringifying the replacement,
so that $1 et al. see the right pattern.  It also stringifies the
variable for each iteration of the second loop, so that $1 and
$REGMARK update.

The first loop, which requires the rhs to be constant, is skipped if
the regexp contains the special backtracking control verbs that mod-
ify $REGMARK and $REGERROR.

diff --git a/pp_hot.c b/pp_hot.c
index 9c66684..ec0b3b8 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2168,6 +2168,8 @@ PP(pp_subst)
        RETURN;
     }
 
+    PL_curpm = pm;
+
     /* known replacement string? */
     if (dstr) {
        if (SvTAINTED(dstr))
@@ -2201,7 +2203,7 @@ PP(pp_subst)
 #endif
         && (I32)clen <= RX_MINLENRET(rx)
         && (once || !(r_flags & REXEC_COPY_STR))
-       && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
+       && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
        && (!doutf8 || SvUTF8(TARG))
        && !(rpm->op_pmflags & PMf_NONDESTRUCT))
     {
@@ -2218,7 +2220,6 @@ PP(pp_subst)
            goto force_it;
        }
        d = s;
-       PL_curpm = pm;
        if (once) {
            if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
                rxtainted |= SUBST_TAINT_PAT;
@@ -2288,6 +2289,8 @@ PP(pp_subst)
        }
     }
     else {
+       bool first;
+       SV *repl;
        if (force_on_match) {
            force_on_match = 0;
            if (rpm->op_pmflags & PMf_NONDESTRUCT) {
@@ -2306,8 +2309,8 @@ PP(pp_subst)
 #endif
        if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
            rxtainted |= SUBST_TAINT_PAT;
+       repl = dstr;
        dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
-       PL_curpm = pm;
        if (!c) {
            PERL_CONTEXT *cx;
            SPAGAIN;
@@ -2320,6 +2323,7 @@ PP(pp_subst)
            RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
        }
        r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
+       first = TRUE;
        do {
            if (iters++ > maxiters)
                DIE(aTHX_ "Substitution loop");
@@ -2336,8 +2340,23 @@ PP(pp_subst)
            m = RX_OFFS(rx)[0].start + orig;
            sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
            s = RX_OFFS(rx)[0].end + orig;
-           if (clen)
+           if (first) {
+               /* replacement already stringified */
+             if (clen)
                sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
+             first = FALSE;
+           }
+           else {
+               if (SvTAINTED(dstr))
+                   rxtainted |= SUBST_TAINT_REPL;
+               if (PL_encoding) {
+                   if (!nsv) nsv = sv_newmortal();
+                   sv_copypv(nsv, repl);
+                   if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
+                   sv_catsv(dstr, nsv);
+               }
+               else sv_catsv(dstr, repl);
+           }
            if (once)
                break;
        } while (CALLREGEXEC(rx, s, strend, orig, s == m,

diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index 453e5ab..262e8d3 100644 (file)
--- a/t/re/pat_rt_report.t
+++ b/t/re/pat_rt_report.t
@@ -22,7 +22,7 @@ BEGIN {
 }
 
 
-plan tests => 2525;  # Update this when adding/deleting tests.
+plan tests => 2527;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -921,6 +921,10 @@ sub run_tests {
          $_ = "CCCCBAA";
          ok(s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g, $message);
          is($_, "ZYX", $message);
+         # Use a longer name to force reallocation of $REGMARK.
+         $_ = "CCCCBAA";
+         ok(s/(*:X)A+|(*:YYYYYYYYYYYYYYYY)B+|(*:Z)C+/$REGMARK/g, $message);
+         is($_, "ZYYYYYYYYYYYYYYYYX", $message);
     }
 
     {

diff --git a/t/re/subst.t b/t/re/subst.t
index b700537..6474b46 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 202 );
+plan( tests => 203 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -841,6 +841,7 @@ pass("s/// on tied var returning a cow");
 }
 
 
+# Test problems with constant replacement optimisation
 # [perl #26986] logop in repl resulting in incorrect optimisation
 "g" =~ /(.)/;
 @l{'a'..'z'} = 'A'..':';
@@ -848,6 +849,15 @@ $_ = "hello";
 { s/(.)/$l{my $a||$1}/g }
 is $_, "HELLO",
   'logop in s/// repl does not result in "constant" repl optimisation';
+# Aliases to match vars
+"g" =~ /(.)/;
+$_ = "hello";
+{
+    local *a = *1;
+    s/(.)\1/$a/g;
+}
+is $_, 'helo', 's/pat/$alias_to_match_var/';
+
 
 $_ = "\xc4\x80";
 $a = "";