Bugs in hairy interactions of feature in REx

To: perl5-porters@perl.org (Mailing list Perl5)
Message-ID: <MLIST_199812080637.BAA16025@monk.mps.ohio-state.edu>

\G fixes (wasn't working right with //g, s///, and $_ in (?{})).

p4raw-id: //depot/cfgperl@2515

6 files changed, 158 insertions, 9 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index 1cdf8bee90..a44f37f291 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -166,7 +166,8 @@ PP(pp_substcont)
 	if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 				     s == m, cx->sb_targ, NULL,
 				     ((cx->sb_rflags & REXEC_COPY_STR)
-				      ? 0 : REXEC_COPY_STR)))
+				      ? REXEC_IGNOREPOS 
+				      : (REXEC_COPY_STR|REXEC_IGNOREPOS))))
 	{
 	    SV *targ = cx->sb_targ;
 	    sv_catpvn(dstr, s, cx->sb_strend - s);
diff --git a/pp_hot.c b/pp_hot.c
index 329af8bd88..b53842775e 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -874,6 +874,8 @@ PP(pp_match)
     if (rx->minlen > len) goto failure;
 
     truebase = t = s;
+
+    /* XXXX What part of this is needed with true \G-support? */
     if (global = pm->op_pmflags & PMf_GLOBAL) {
 	rx->startp[0] = 0;
 	if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
@@ -993,6 +995,7 @@ play_it_again:
 	    if (rx->startp[0] && rx->startp[0] == rx->endp[0])
 		++rx->endp[0];
 	    PUTBACK;			/* EVAL blocks may use stack */
+	    r_flags |= REXEC_IGNOREPOS;
 	    goto play_it_again;
 	}
 	else if (!iters)
@@ -1827,6 +1830,7 @@ PP(pp_subst)
 	    PUSHSUBST(cx);
 	    RETURNOP(cPMOP->op_pmreplroot);
 	}
+	r_flags |= REXEC_IGNOREPOS;
 	do {
 	    if (iters++ > maxiters)
 		DIE("Substitution loop");
@@ -1845,7 +1849,7 @@ PP(pp_subst)
 		sv_catpvn(dstr, c, clen);
 	    if (once)
 		break;
-	} while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, r_flags));
+	} while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags));
 	sv_catpvn(dstr, s, strend - s);
 
 	(void)SvOOK_off(TARG);
diff --git a/regexec.c b/regexec.c
index 53b1664ef4..c4106270a1 100644
--- a/regexec.c
+++ b/regexec.c
@@ -418,12 +418,12 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 
     if (prog->reganch & ROPT_GPOS_SEEN) {
 	MAGIC *mg;
-	int pos = 0;
 
-	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) 
-	    && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
-	    pos = mg->mg_len;
-	PL_reg_ganch = startpos + pos;
+	if (!(flags & REXEC_IGNOREPOS) && sv && SvTYPE(sv) >= SVt_PVMG
+	    && SvMAGIC(sv) && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
+	    PL_reg_ganch = strbeg + mg->mg_len;
+	else
+	    PL_reg_ganch = startpos;
     }
 
     /* Simplest case:  anchored match need be tried only once. */
diff --git a/regexp.h b/regexp.h
index 67410a5e7b..b1170f1e06 100644
--- a/regexp.h
+++ b/regexp.h
@@ -103,6 +103,7 @@ typedef struct regexp {
 #define REXEC_COPY_STR	1		/* Need to copy the string. */
 #define REXEC_CHECKED	2		/* check_substr already checked. */
 #define REXEC_SCREAM	4		/* use scream table. */
+#define REXEC_IGNOREPOS	8		/* \G matches at start. */
 
 #define ReREFCNT_inc(re) ((re && re->refcnt++), re)
 #define ReREFCNT_dec(re) pregfree(re)
diff --git a/t/op/pat.t b/t/op/pat.t
index 7bcc196ed1..abb10fd841 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..177\n";
+print "1..178\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -697,6 +697,13 @@ print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1;
 print "ok $test\n";
 $test++;
 
+$_ = 'aaa';
+pos = 1;
+@a = /\Ga/g;
+print "not " unless "@a" eq "a a";
+print "ok $test\n";
+$test++;
+
 $str = 'abcde';
 pos $str = 2;
 
diff --git a/t/op/subst.t b/t/op/subst.t
index 70219ab521..6b3ce5852f 100755
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -6,7 +6,7 @@ BEGIN {
     require Config; import Config;
 }
 
-print "1..71\n";
+print "1..91\n";
 
 $x = 'foo';
 $_ = "x";
@@ -315,3 +315,139 @@ $_ = 'x' x 20;
 s/\d*|x/<$&>/g; 
 $foo = '<>' . ('<x><>' x 20) ;
 print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n");
+
+$t = 'aaaaaaaaa'; 
+
+$_ = $t;
+pos = 6;
+s/\Ga/xx/g;
+print "not " unless $_ eq 'aaaaaaxxxxxx';
+print "ok 72\n";
+
+$_ = $t;
+pos = 6;
+s/\Ga/x/g;
+print "not " unless $_ eq 'aaaaaaxxx';
+print "ok 73\n";
+
+$_ = $t;
+pos = 6;
+s/\Ga/xx/;
+print "not " unless $_ eq 'aaaaaaxxaa';
+print "ok 74\n";
+
+$_ = $t;
+pos = 6;
+s/\Ga/x/;
+print "not " unless $_ eq 'aaaaaaxaa';
+print "ok 75\n";
+
+$_ = $t;
+s/\Ga/xx/g;
+print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx';
+print "ok 76\n";
+
+$_ = $t;
+s/\Ga/x/g;
+print "not " unless $_ eq 'xxxxxxxxx';
+print "ok 77\n";
+
+$_ = $t;
+s/\Ga/xx/;
+print "not " unless $_ eq 'xxaaaaaaaa';
+print "ok 78\n";
+
+$_ = $t;
+s/\Ga/x/;
+print "not " unless $_ eq 'xaaaaaaaa';
+print "ok 79\n";
+
+$t = 'aaa';
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/xx/g;
+print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa';
+print "ok 80\n";
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/x/g;
+print "not " unless "$_ @res" eq 'axx aaa a aaa aa';
+print "ok 81\n";
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/xx/;
+print "not " unless "$_ @res" eq 'axxa aaa a';
+print "ok 82\n";
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/x/;
+print "not " unless "$_ @res" eq 'axa aaa a';
+print "ok 83\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/xx/g;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
+print "ok 84\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x/g;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
+print "ok 85\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/xx/;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
+print "ok 86\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x/;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
+print "ok 87\n";
+
+sub x2 {'xx'}
+sub x1 {'x'}
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
+print "ok 88\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
+print "ok 89\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x2/e;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
+print "ok 90\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x1/e;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
+print "ok 91\n";
+