diff options
author | David Mitchell <davem@iabyn.com> | 2013-07-19 02:08:56 +0100 |
---|---|---|
committer | David Mitchell <davem@iabyn.com> | 2013-07-28 10:33:37 +0100 |
commit | cf44e600505da0c8da2d64849647ce2d39c46808 (patch) | |
tree | 0d736bf3d2a0605ca6e29770e270282d43a9ddfc | |
parent | f1fb9b037a1fe86e0ccdfbf27affa94647af2a37 (diff) | |
download | perl-cf44e600505da0c8da2d64849647ce2d39c46808.tar.gz |
fix intuit_start() with \G
Intuit assumed that any anchor, including \G, anchored at BOS or after \n.
This obviously isn't the case for \G, so exclude RXf_ANCH_GPOS from the
RXf_ANCH branch.
This has never been spotted before, since intuit used to be skipped when
\G was present.
-rw-r--r-- | regexec.c | 13 | ||||
-rw-r--r-- | t/re/pat.t | 22 |
2 files changed, 26 insertions, 9 deletions
@@ -557,13 +557,9 @@ Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, * with giant delta may be not rechecked). */ -/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */ - /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend. Otherwise, only SvCUR(sv) is used to get strbeg. */ -/* XXXX We assume that strpos is strbeg unless sv. */ - /* XXXX Some places assume that there is a fixed substring. An update may be needed if optimizer marks as "INTUITable" RExen without fixed substrings. Similarly, it is assumed that @@ -671,14 +667,15 @@ Perl_re_intuit_start(pTHX_ } check = prog->check_substr; } - if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */ - ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE) + if ((prog->extflags & RXf_ANCH) /* Match at beg-of-str or after \n */ + && !(prog->extflags & RXf_ANCH_GPOS)) /* \G isn't a BOS or \n */ + { + ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE) || ( (prog->extflags & RXf_ANCH_BOL) && !multiline ) ); /* Check after \n? */ if (!ml_anch) { - if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */ - && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */ + if ( !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */ && (strpos != strbeg)) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); goto fail; diff --git a/t/re/pat.t b/t/re/pat.t index 207166637c..897c3d37fb 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -20,7 +20,7 @@ BEGIN { require './test.pl'; } -plan tests => 681; # Update this when adding/deleting tests. +plan tests => 688; # Update this when adding/deleting tests. run_tests() unless caller; @@ -727,6 +727,26 @@ sub run_tests { unlike($str, qr/^...\G/, $message); ok($str =~ /\G../ && $& eq 'cd', $message); ok($str =~ /.\G./ && $& eq 'bc', $message); + + } + + { + my $message = '\G and intuit and anchoring'; + $_ = "abcdef"; + pos = 0; + ok($_ =~ /\Gabc/, $message); + ok($_ =~ /^\Gabc/, $message); + + pos = 3; + ok($_ =~ /\Gdef/, $message); + pos = 3; + ok($_ =~ /\Gdef$/, $message); + pos = 3; + ok($_ =~ /abc\Gdef$/, $message); + pos = 3; + ok($_ =~ /^abc\Gdef$/, $message); + pos = 3; + ok($_ =~ /c\Gd/, $message); } { |