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

diff --git a/pp_ctl.c b/pp_ctl.c
index 1cdf8be..a44f37f 100644 (file)
--- 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 329af8b..b538427 100644 (file)
--- 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 53b1664..c410627 100644 (file)
--- 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 67410a5..b1170f1 100644 (file)
--- 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 7bcc196..abb10fd 100755 (executable)
--- 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 70219ab..6b3ce58 100755 (executable)
--- 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";
+