correctly detect lookaround for \K reporting

pod/perldiag.pod

@@ -3289,7 +3289,10 @@ line.  See L<perlrun|perlrun/-i[extension]> for more details.
 =item \K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/%s/
 
 (F) Your regular expression used C<\K> in a lookhead or lookbehind
-assertion, which isn't permitted.
+assertion, which currently isn't permitted.
+
+This may change in the future, see L<Support \K in
+lookarounds|https://github.com/Perl/perl5/issues/18134>.
 
 =item Label not found for "last %s"
 

regcomp.c

@@ -242,8 +242,7 @@ struct RExC_state_t {
     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
                                            through */
     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
-    I32		in_lookbehind;
-    I32		in_lookahead;
+    I32		in_lookaround;
     I32		contains_locale;
     I32		override_recoding;
     I32         recode_x_to_native;
@@ -330,8 +329,7 @@ struct RExC_state_t {
 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
 #define RExC_study_chunk_recursed_bytes  \
                                    (pRExC_state->study_chunk_recursed_bytes)
-#define RExC_in_lookbehind	(pRExC_state->in_lookbehind)
-#define RExC_in_lookahead	(pRExC_state->in_lookahead)
+#define RExC_in_lookaround	(pRExC_state->in_lookaround)
 #define RExC_contains_locale	(pRExC_state->contains_locale)
 #define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
 
@@ -7767,8 +7765,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
 
     RExC_seen = 0;
     RExC_maxlen = 0;
-    RExC_in_lookbehind = 0;
-    RExC_in_lookahead = 0;
+    RExC_in_lookaround = 0;
     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
     RExC_recode_x_to_native = 0;
     RExC_in_multi_char_class = 0;
@@ -11137,6 +11134,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
     I32 after_freeze = 0;
     I32 num; /* numeric backreferences */
     SV * max_open;  /* Max number of unclosed parens */
+    I32 was_in_lookaround = RExC_in_lookaround;
 
     char * parse_start = RExC_parse; /* MJD */
     char * const oregcomp_parse = RExC_parse;
@@ -11158,13 +11156,6 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
 
     *flagp = 0;				/* Initialize. */
 
-    if (RExC_in_lookbehind) {
-	RExC_in_lookbehind++;
-    }
-    if (RExC_in_lookahead) {
-        RExC_in_lookahead++;
-    }
-
     /* Having this true makes it feasible to have a lot fewer tests for the
      * parse pointer being in scope.  For example, we can write
      *      while(isFOO(*RExC_parse)) RExC_parse++;
@@ -11418,11 +11409,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
 
             lookbehind_alpha_assertions:
                 RExC_seen |= REG_LOOKBEHIND_SEEN;
-                RExC_in_lookbehind++;
                 /*FALLTHROUGH*/
 
             alpha_assertions:
 
+                RExC_in_lookaround++;
                 RExC_seen_zerolen++;
 
                 if (! start_arg) {
@@ -11625,7 +11616,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
 		}
 
                 RExC_seen |= REG_LOOKBEHIND_SEEN;
-		RExC_in_lookbehind++;
+		RExC_in_lookaround++;
 		RExC_parse++;
                 if (RExC_parse >= RExC_end) {
                     vFAIL("Sequence (?... not terminated");
@@ -11634,7 +11625,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
                 break;
 	    case '=':           /* (?=...) */
 		RExC_seen_zerolen++;
-                RExC_in_lookahead++;
+                RExC_in_lookaround++;
                 break;
 	    case '!':           /* (?!...) */
 		RExC_seen_zerolen++;
@@ -11646,6 +11637,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
 	            nextchar(pRExC_state);
 	            return ret;
 	        }
+                RExC_in_lookaround++;
 	        break;
 	    case '|':           /* (?|...) */
 	        /* branch reset, behave like a (?:...) except that
@@ -12466,14 +12458,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
 	NOT_REACHED; /* NOTREACHED */
     }
 
-    if (RExC_in_lookbehind) {
-	RExC_in_lookbehind--;
-    }
-    if (RExC_in_lookahead) {
-        RExC_in_lookahead--;
-    }
     if (after_freeze > RExC_npar)
         RExC_npar = after_freeze;
+
+    RExC_in_lookaround = was_in_lookaround;
+
     return(ret);
 }
 
@@ -13603,7 +13592,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
             RExC_seen |= REG_GPOS_SEEN;
 	    goto finish_meta_pat;
 	case 'K':
-            if (!RExC_in_lookbehind && !RExC_in_lookahead) {
+            if (!RExC_in_lookaround) {
                 RExC_seen_zerolen++;
                 ret = reg_node(pRExC_state, KEEPS);
                 /* XXX:dmq : disabling in-place substitution seems to

t/lib/croak/regcomp

@@ -77,15 +77,109 @@ EXPECT
 Too many nested open parens in regex; marked by <-- HERE in m/(( <-- HERE a))/ at - line 3.
 ########
 # NAME \K not permitted in lookahead
-$x =~ /(?=a\Ka)a/;
+qr/(?=a\Ka)a/;
 EXPECT
 \K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?=a\K <-- HERE a)a/ at - line 1.
 ########
+# NAME \K not permitted in lookahead (alpha)
+no warnings 'experimental::alpha_assertions';
+qr/(*positive_lookahead:a\Ka)a/;
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(*positive_lookahead:a\K <-- HERE a)a/ at - line 2.
+########
+# NAME \K not permitted in negative lookahead
+qr/(?!a\Ka)a/;
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?!a\K <-- HERE a)a/ at - line 1.
+########
+# NAME \K not permitted in negative lookahead (alpha)
+no warnings 'experimental::alpha_assertions';
+qr/(*negative_lookahead:a\Ka)a/;
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(*negative_lookahead:a\K <-- HERE a)a/ at - line 2.
+########
 # NAME \K not permitted in lookbehind
-$x =~ /(?<=a\Ka)a/;
+qr/(?<=a\Ka)a/;
 EXPECT
 \K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?<=a\K <-- HERE a)a/ at - line 1.
 ########
+# NAME \K not permitted in lookbehind (alpha)
+no warnings 'experimental::alpha_assertions';
+qr/(*positive_lookbehind:a\Ka)a/;
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(*positive_lookbehind:a\K <-- HERE a)a/ at - line 2.
+########
+# NAME \K not permitted in negative lookbehind
+qr/(?<!a\Ka)a/;
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?<!a\K <-- HERE a)a/ at - line 1.
+########
+# NAME \K not permitted in negative lookbehind (alpha)
+no warnings 'experimental::alpha_assertions';
+qr/(*negative_lookbehind:a\Ka)a/;
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(*negative_lookbehind:a\K <-- HERE a)a/ at - line 2.
+########
+# NAME \K nesting in lookahead after lookahead
+qr{(?=(?=x)x\K)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?=(?=x)x\K <-- HERE )x/ at - line 1.
+########
+# NAME \K nesting in lookahead after negative lookahead
+qr{(?=(?!y)x\K)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?=(?!y)x\K <-- HERE )x/ at - line 1.
+########
+# NAME \K nesting in lookahead in negative lookahead
+qr{(?=(?!y\K)x)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?=(?!y\K <-- HERE )x)x/ at - line 1.
+########
+# NAME \K nesting in lookahead in lookahead
+qr{(?=(?=x\K)x)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?=(?=x\K <-- HERE )x)x/ at - line 1.
+########
+# NAME \K nesting in lookbehind after lookbehind
+qr{(?<=(?<=x)x\K)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?<=(?<=x)x\K <-- HERE )x/ at - line 1.
+########
+# NAME \K nesting in lookahead after lookbehind
+qr{(?=(?<=x)x\K)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?=(?<=x)x\K <-- HERE )x/ at - line 1.
+########
+# NAME \K nesting in lookbehind after lookahead
+qr{(?<=(?=x)x\K)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?<=(?=x)x\K <-- HERE )x/ at - line 1.
+########
+# NAME \K nesting in negative lookbehind after lookahead
+qr{(?<!(?=x)x\K)x};
+EXPECT
+\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/(?<!(?=x)x\K <-- HERE )x/ at - line 1.
+########
+# NAME \K is permitted after the lookahead GH#18123
+qr/(?=(?=x)x)\K/;
+qr/(?!(?=x)x)\K/;
+qr/(?=(?!x)x)\K/;
+qr/(?!(?!x)x)\K/;
+qr/(?<=(?=x)x)\K/;
+qr/(?<!(?=x)x)\K/;
+qr/(?<=(?!x)x)\K/;
+qr/(?<!(?!x)x)\K/;
+qr/(?=(?<=x)x)\K/;
+qr/(?!(?<=x)x)\K/;
+qr/(?=(?<!x)x)\K/;
+qr/(?!(?<!x)x)\K/;
+qr/(?<=(?<=x)x)\K/;
+qr/(?<!(?<=x)x)\K/;
+qr/(?<=(?<!x)x)\K/;
+qr/(?<!(?<!x)x)\K/;
+EXPECT
+OPTIONS nonfatal
+########
 # NAME numeric parsing buffer overflow in numeric.c
 0=~/\p{nV:-0}/
 EXPECT

t/test.pl

@@ -1103,6 +1103,7 @@ sub fresh_perl_like {
 #   regex - the expected output is a regular expression
 #   random - all lines match but in any order
 #   fatal - the code will fail fatally (croak, die)
+#   nonfatal - the code is not expected to fail fatally
 #
 # If the actual output contains a line "SKIPPED" the test will be
 # skipped.
@@ -1311,7 +1312,7 @@ sub run_multiple_progs {
 	my $option_regex = 0;
 	my $option_random = 0;
 	my $fatal = $FATAL;
-	if ($expected =~ s/^OPTIONS? (.+)\n//) {
+	if ($expected =~ s/^OPTIONS? (.+)(?:\n|\Z)//) {
 	    foreach my $option (split(' ', $1)) {
 		if ($option eq 'regex') { # allow regular expressions
 		    $option_regex = 1;
@@ -1322,6 +1323,10 @@ sub run_multiple_progs {
 		elsif ($option eq 'fatal') { # perl should fail
 		    $fatal = 1;
 		}
+                elsif ($option eq 'nonfatal') {
+                    # used to turn off default fatal
+                    $fatal = 0;
+                }
 		else {
 		    die "$0: Unknown OPTION '$option'\n";
 		}