add more positive gofs GPOS tests and fix some bugs too

diff --git a/ext/re/re.pm b/ext/re/re.pm
index 0c49746..6331fb9 100644 (file)
--- a/ext/re/re.pm
+++ b/ext/re/re.pm
@@ -71,10 +71,11 @@ my %flags = (
     OPTIMISEM       => 0x100000,
     STACK           => 0x280000,
     BUFFERS         => 0x400000,
+    GPOS            => 0x800000,
 );
 $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
 $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
-$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE};
+$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS};
 $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
 $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
 $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};

diff --git a/pp_ctl.c b/pp_ctl.c
index 4cde9f8..e69bf0c 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -233,13 +233,16 @@ PP(pp_substcont)
        if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
            cx->sb_rxtainted |= 2;
        sv_catsv(dstr, POPs);
+       /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
+       s -= RX_GOFS(rx);
 
        /* Are we done */
-       if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
-                                    s == m, cx->sb_targ, NULL,
-                                    ((cx->sb_rflags & REXEC_COPY_STR)
-                                     ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
-                                     : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+       if (CxONCE(cx) || s < orig ||
+               !CALLREGEXEC(rx, s, cx->sb_strend, orig,
+                            (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
+                            ((cx->sb_rflags & REXEC_COPY_STR)
+                             ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
+                             : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
        {
            SV * const targ = cx->sb_targ;
 

diff --git a/regcomp.h b/regcomp.h
index cd6a71a..198961c 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -729,6 +729,7 @@ re.pm, especially to the documentation.
 #define RE_DEBUG_EXTRA_STATE       0x080000
 #define RE_DEBUG_EXTRA_OPTIMISE    0x100000
 #define RE_DEBUG_EXTRA_BUFFERS     0x400000
+#define RE_DEBUG_EXTRA_GPOS        0x800000
 /* combined */
 #define RE_DEBUG_EXTRA_STACK       0x280000
 
@@ -784,6 +785,8 @@ re.pm, especially to the documentation.
 #define DEBUG_TRIE_r(x) DEBUG_r( \
     if (re_debug_flags & (RE_DEBUG_COMPILE_TRIE \
         | RE_DEBUG_EXECUTE_TRIE )) x )
+#define DEBUG_GPOS_r(x) DEBUG_r( \
+    if (re_debug_flags & RE_DEBUG_EXTRA_GPOS) x )
 
 /* initialization */
 /* get_sv() can return NULL during global destruction. */

diff --git a/regexec.c b/regexec.c
index 56dfe12..8d9d171 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -1821,26 +1821,38 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *stre
 
     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
        MAGIC *mg;
-
-       if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
+       if (flags & REXEC_IGNOREPOS){   /* Means: check only at start */
            reginfo.ganch = startpos + prog->gofs;
-       else if (sv && SvTYPE(sv) >= SVt_PVMG
+           DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
+             "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",prog->gofs));
+       } else if (sv && SvTYPE(sv) >= SVt_PVMG
                  && SvMAGIC(sv)
                  && (mg = mg_find(sv, PERL_MAGIC_regex_global))
                  && mg->mg_len >= 0) {
            reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
+           DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
+               "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",mg->mg_len));
+
            if (prog->extflags & RXf_ANCH_GPOS) {
                if (s > reginfo.ganch)
                    goto phooey;
                s = reginfo.ganch - prog->gofs;
+               DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
+                    "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",prog->gofs));
                if (s < strbeg)
                    goto phooey;
            }
        }
        else if (data) {
            reginfo.ganch = strbeg + PTR2UV(data);
-       } else                          /* pos() not defined */
+            DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
+                "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
+
+       } else {                                /* pos() not defined */
            reginfo.ganch = strbeg;
+            DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
+                "GPOS: reginfo.ganch = strbeg\n"));
+       }
     }
     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
         /* We have to be careful. If the previous successful match

diff --git a/t/op/subst.t b/t/op/subst.t
index 92dac1b..2f6e759 100644 (file)
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 141 );
+plan( tests => 142 );
 
 $x = 'foo';
 $_ = "x";
@@ -596,4 +596,5 @@ 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' );