add more positive gofs GPOS tests and fix some bugs too

Perl · Sep 10, 2009 · 2c29696 · 2c29696
1 parent 831a7dd
commit 2c29696
Show file tree

Hide file tree

Showing 5 changed files with 31 additions and 11 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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' );