From: Ilya Zakharevich Date: Tue, 8 Dec 1998 09:02:04 +0000 (+0200) Subject: Bugs in hairy interactions of feature in REx X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ad94a51148da69b36625e16c155cd6147ed14f1a;p=p5sagit%2Fp5-mst-13.2.git Bugs in hairy interactions of feature in REx To: perl5-porters@perl.org (Mailing list Perl5) Message-ID: \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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 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"; +