RT #120446: /\Ga/ running slowly on long strings

This commit reverts my commit cf44e60
(except for the tests), which incorrectly disabled fix-string intuiting
in the presence of anchored \G. I thought that the old behaviour was
logically incorrect, but it wasn't (or at least I don't see it that way
now, and none of the tests I added at the time fail under the old regime).

Author: iabyn

regexec.c

@@ -667,16 +667,24 @@ Perl_re_intuit_start(pTHX_
         }
 	check = prog->check_substr;
     }
-    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)
+    if (prog->extflags & RXf_ANCH) { /* Match at \G, beg-of-str or after \n */
+	ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
 		     || ( (prog->extflags & RXf_ANCH_BOL)
 			  && !multiline ) );	/* Check after \n? */
 
 	if (!ml_anch) {
-	  if (    !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
-	       && (strpos != strbeg)) {
+          /* we are only allowed to match at BOS or \G */
+
+	  if (prog->extflags & RXf_ANCH_GPOS) {
+            /* in this case, we hope(!) that the caller has already
+             * set strpos to pos()-gofs, and will already have checked
+             * that this anchor position is legal
+             */
+            ;
+          }
+          else 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;
 	  }
@@ -2277,7 +2285,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
 
         /* in the presence of \G, we may need to start looking earlier in
          * the string than the suggested start point of stringarg:
-         * if gofs->prog is set, then that's a known, fixed minimum
+         * if prog->gofs is set, then that's a known, fixed minimum
          * offset, such as
          * /..\G/:   gofs = 2
          * /ab|c\G/: gofs = 1

t/re/pat.t

@@ -20,7 +20,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 701;  # Update this when adding/deleting tests.
+plan tests => 702;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1489,6 +1489,24 @@ EOP
 	is $^R, 42, 'assigning to *^R does not result in a crash';
     }
 
+    {
+        # [perl #120446]
+        # this code should be virtually instantaneous. If it takes 10s of
+        # seconds, there a bug in intuit_start.
+        # (this test doesn't actually test for slowness - that involves
+        # too much danger of false positives on loaded machines - but by
+        # putting it here, hopefully someone might notice if it suddenly
+        # runs slowly)
+        my $s = ('a' x 1_000_000) . 'b';
+        my $i = 0;
+        for (1..10_000) {
+            pos($s) = $_;
+            $i++ if $s =~/\Gb/g;
+        }
+        is($i, 0, "RT 120446: mustn't run slowly");
+    }
+
+
 } # End of sub run_tests
 
 1;