s/.(?=.\G)/X/g: refuse to go backwards

On something like:

    $_ = "123456789";
    pos = 6;
    s/.(?=.\G)/X/g;

each iteration could in theory start with pos one character to the left
of the previous position, and with the substitution replacing bits that
it has already replaced.  Since that way madness lies, ban any attempt by
s/// to substitute to the left of a previous position.

To implement this, add a new flag to regexec(), REXEC_FAIL_ON_UNDERFLOW.
This tells regexec() to return failure even if the match itself succeeded,
but where the start of $& is before the passed stringarg point.

This change caused one existing test to fail (which was added about a year
ago):

    $_="abcdef";
    s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge;
    print; # used to print "aXX[c-d][d-e][e-f]"; now prints "aXXdef"

I think that that test relies on ambiguous behaviour, and that my change
makes things saner.

Note that s/// with \G is generally very under-tested.

diff --git a/pod/perlre.pod b/pod/perlre.pod
index 0119fc5..3b3f727 100644 (file)
--- a/pod/perlre.pod
+++ b/pod/perlre.pod
@@ -746,6 +746,17 @@ row.
 It is worth noting that C<\G> improperly used can result in an infinite
 loop. Take care when using patterns that include C<\G> in an alternation.
 
+Note also that C<s///> will refuse to overwrite part of a substitution
+that has already been replaced; so for example this will stop after the
+first iteration, rather than iterating its way backwards through the
+string:
+
+    $_ = "123456789";
+    pos = 6;
+    s/.(?=.\G)/X/g;
+    print;     # prints 1234X6789, not XXXXX6789
+
+
 =head3 Capture groups
 
 The bracketing construct C<( ... )> creates capture groups (also referred to as

diff --git a/pp_ctl.c b/pp_ctl.c
index 87eadd2..ff3d661 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -229,7 +229,7 @@ PP(pp_substcont)
        if (CxONCE(cx) || s < orig ||
                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
                             (s == m), cx->sb_targ, NULL,
-                                (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
+                    (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
        {
            SV *targ = cx->sb_targ;
 

diff --git a/pp_hot.c b/pp_hot.c
index ee82673..95a3bcd 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2233,7 +2233,7 @@ PP(pp_subst)
            } while (CALLREGEXEC(rx, s, strend, orig, s == m,
                                 TARG, NULL,
                                 /* don't match same null twice */
-                                REXEC_NOT_FIRST|REXEC_IGNOREPOS));
+                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
            if (s != d) {
                 I32 i = strend - s;
                SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
@@ -2321,7 +2321,8 @@ PP(pp_subst)
            if (once)
                break;
        } while (CALLREGEXEC(rx, s, strend, orig, s == m,
-                            TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS));
+                            TARG, NULL,
+                    REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
        sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
 
        if (rpm->op_pmflags & PMf_NONDESTRUCT) {

diff --git a/regexec.c b/regexec.c
index 48b21e7..8d2fbfd 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2279,6 +2279,19 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
              * Set up captures etc just for $& and $-[0]
              * (an intuit-only match wont have $1,$2,..) */
             assert(!prog->nparens);
+
+            /* s/// doesn't like it if $& is earlier than where we asked it to
+             * start searching (which can happen on something like /.\G/) */
+            if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
+                    && (s < stringarg))
+            {
+                /* this should only be possible under \G */
+                assert(prog->extflags & RXf_GPOS_SEEN);
+                DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+                    "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
+                goto phooey;
+            }
+
             /* match via INTUIT shouldn't have any captures.
              * Let @-, @+, $^N know */
             prog->lastparen = prog->lastcloseparen = 0;
@@ -2834,6 +2847,18 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
     goto phooey;
 
 got_it:
+    /* s/// doesn't like it if $& is earlier than where we asked it to
+     * start searching (which can happen on something like /.\G/) */
+    if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
+            && (prog->offs[0].start < stringarg - strbeg))
+    {
+        /* this should only be possible under \G */
+        assert(prog->extflags & RXf_GPOS_SEEN);
+        DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+            "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
+        goto phooey;
+    }
+
     DEBUG_BUFFERS_r(
        if (swap)
            PerlIO_printf(Perl_debug_log,

diff --git a/regexp.h b/regexp.h
index 5fb85ec..65c2d38 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -547,6 +547,9 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
                                      * to skip copying ... */
 #define REXEC_COPY_SKIP_PRE  0x20   /* ...the $` part of the string, or */
 #define REXEC_COPY_SKIP_POST 0x40   /* ...the $' part of the string */
+#define REXEC_FAIL_ON_UNDERFLOW 0x80 /* fail the match if $& would start before
+                                        the start pos (so s/.\G// would fail
+                                        on second iteration */
 
 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
 #  define ReREFCNT_inc(re)                                             \

diff --git a/t/re/subst.t b/t/re/subst.t
index bbc3a83..44fde78 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 207 );
+plan( tests => 231 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -670,11 +670,95 @@ 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( '$_="abcdef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-d][d-e][e-f]',
+fresh_perl_is( '$_="abcdef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXXdef',
                 'positive GPOS regex substitution failure (#69056, #114884)' );
 fresh_perl_is( '$_="abcdefg123456"; s/(?<=...\G)?(\d)/($1)/; print' => 'abcdefg(1)23456',
                 'positive GPOS lookbehind regex substitution failure #114884' );
 
+# s/..\G//g should stop after the first iteration, rather than working its
+# way backwards, or looping infinitely, or SEGVing (for example)
+{
+    my ($s, $count);
+
+    # use a function to disable constant folding
+    my $f = sub { substr("789", 0, $_[0]) };
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d\G/7/g;
+    is($count, 1, "..\\G count (short)");
+    is($s, "12756", "..\\G s (short)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d\G/78/g;
+    is($count, 1, "..\\G count (equal)");
+    is($s, "127856", "..\\G s (equal)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d\G/789/g;
+    is($count, 1, "..\\G count (long)");
+    is($s, "1278956", "..\\G s (long)");
+
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d\G/$f->(1)/eg;
+    is($count, 1, "..\\G count (short code)");
+    is($s, "12756", "..\\G s (short code)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d\G/$f->(2)/eg;
+    is($count, 1, "..\\G count (equal code)");
+    is($s, "127856", "..\\G s (equal code)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d\G/$f->(3)/eg;
+    is($count, 1, "..\\G count (long code)");
+    is($s, "1278956", "..\\G s (long code)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d(?=\d\G)/7/g;
+    is($count, 1, "..\\G count (lookahead short)");
+    is($s, "17456", "..\\G s (lookahead short)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d(?=\d\G)/78/g;
+    is($count, 1, "..\\G count (lookahead equal)");
+    is($s, "178456", "..\\G s (lookahead equal)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d(?=\d\G)/789/g;
+    is($count, 1, "..\\G count (lookahead long)");
+    is($s, "1789456", "..\\G s (lookahead long)");
+
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d(?=\d\G)/$f->(1)/eg;
+    is($count, 1, "..\\G count (lookahead short code)");
+    is($s, "17456", "..\\G s (lookahead short code)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d(?=\d\G)/$f->(2)/eg;
+    is($count, 1, "..\\G count (lookahead equal code)");
+    is($s, "178456", "..\\G s (lookahead equal code)");
+
+    $s = '123456';
+    pos($s) = 4;
+    $count = $s =~ s/\d\d(?=\d\G)/$f->(3)/eg;
+    is($count, 1, "..\\G count (lookahead long code)");
+    is($s, "1789456", "..\\G s (lookahead long code)");
+}
+
+
 # [perl #71470] $var =~ s/$qr//e calling get-magic on $_ as well as $var
 {
  local *_;