From cf44e600505da0c8da2d64849647ce2d39c46808 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Fri, 19 Jul 2013 02:08:56 +0100
Subject: [PATCH] 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.
---
 regexec.c  | 13 +++++--------
 t/re/pat.t | 22 +++++++++++++++++++++-
 2 files changed, 26 insertions(+), 9 deletions(-)

diff --git a/regexec.c b/regexec.c
index 94dc3ce..43d66c9 100644
--- a/regexec.c
+++ b/regexec.c
@@ -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 2071666..897c3d3 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);
     }
 
     {
-- 
2.7.4