toke.c: fix =cut detection

A line starting with `=cut` is only a cut directive if the next
character is not a word character. Checking for isALPHA is insufficient
because POD directives can contain digits (e.g. `=head1`, `=head2`).

Add the same check to the string eval case, where it was missing
entirely.

Fixes #22759.

Author: mauke

pod/perldelta.pod

@@ -427,6 +427,15 @@ manager will later use a regex to expand these into links.
 
 =item *
 
+The perl parser would erroneously parse like C<=cut> some other POD directives
+whose names start with I<cut>, prematurely terminating an embedded POD section.
+The following cases were affected: I<cut> followed by a digit (e.g.
+C<=cut2studio>), I<cut> followed by an underscore (e.g. C<=cut_grass>), and in
+string C<eval>, any identifier starting with I<cut> (e.g. C<=cute>).
+[GH #22759]
+
+=item *
+
 Builds with C<-msse> and quadmath on 32-bit x86 systems would crash
 with a misaligned access early in the build. [GH #22577]
 

t/base/lex.t

@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..120\n";
+print "1..129\n";
 
 $x = 'x';
 
@@ -586,3 +586,124 @@ $test++;
 print "not " unless ref $::{bas} eq 'SCALAR';
 print "ok $test - second constant in 'const1 const2' is not upgraded\n";
 $test++;
+
+# Test various "not quite =cut" POD directives, which should not terminate a
+# POD section.
+
+$foo = "";
+
+=pod
+
+=cute
+$foo = "not ";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cute does not end POD\n";
+$test++;
+
+$foo = "";
+
+=pod
+
+=cut2
+$foo = "not ";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cut2 does not end POD\n";
+$test++;
+
+$foo = "";
+
+=pod
+
+=cut_
+$foo = "not ";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cut_ does not end POD\n";
+$test++;
+
+$foo = "not ";
+
+=pod
+
+=cut$cene
+$foo = "";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cut\$cene ends POD\n";
+$test++;
+
+# Same as above, but in string eval.
+
+eval q{
+$foo = "";
+
+=pod
+
+=cute
+$foo = "not ";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cute does not end POD in string eval\n";
+$test++;
+
+$foo = "";
+
+=pod
+
+=cut2
+$foo = "not ";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cut2 does not end POD in string eval\n";
+$test++;
+
+$foo = "";
+
+=pod
+
+=cut_
+$foo = "not ";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cut_ does not end POD in string eval\n";
+$test++;
+
+$foo = "not ";
+
+=pod
+
+=cut$cene
+$foo = "";
+
+=pod
+
+=cut
+
+print $foo, "ok $test - =cut\$cene ends POD in string eval\n";
+$test++;
+};
+
+print $@ eq "" ? "" : "not ", "ok $test - did not throw an error\n# $@\n";

toke.c

@@ -7349,7 +7349,7 @@ yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s)
         if (PL_parser->in_pod) {
             /* Incest with pod. */
             if (    memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
-                && !isALPHA(s[4]))
+                && !isIDCONT_A(s[4]))
             {
                 SvPVCLEAR(PL_linestr);
                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
@@ -9372,7 +9372,8 @@ yyl_try(pTHX_ char *s)
                     while (s < d) {
                         if (*s++ == '\n') {
                             incline(s, PL_bufend);
-                            if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
+                            if (memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
+                                && !isIDCONT_A(s[4]))
                             {
                                 s = (char *) memchr(s,'\n', d - s);
                                 if (s)