[perl #114040] Fix here-docs in multiline re-evals

Commit 5097bf9b8 only partially fixed this, or, rather, did the
groundwork for fixing it.

If we have a pattern like this:

/(?{<<foo . baz
bar
foo
})/

Then PL_linestr contains this while we are parsing the block:

"(?{<<foo . baz\nbar\nfoo\n})"

The code for parsing a here-doc in a multiline PL_linestr buffer
(which applies to here-docs in string evals or in quote-like operat-
ors) likes to modify PL_linestr to contain everything after the
<<heredoc marker except the here-doc body, which has been stolen (but
it oddly includes the last character of the marker, which does not
matter, as PL_bufptr is set to PL_linestart+1):

"o . baz\n})"

The regexp block parsing code expects to be able to extract the entire
block (as a string) from PL_linestr after parsing it.  So it is not
helpful for S_scan_heredoc to go and modify it like that.

Before modifying PL_linestr, we can set aside a copy of the source
code (in PL_sublex_info.re_eval_str) from the beginning of the regexp
block to the end of PL_linestr, so that the regexp block code can
retrieve the original source from there.

We also adjust PL_sublex_info.re_eval_start so that at the end of the
regexp block PL_bufptr - PL_sublex_info.re_eval_start is the length of
the block.

Instead of clobbering PL_linestr, we can copy everything after the
here-doc to when the body begins.  And this for two reasons: it
requires less allocation (I would have made that change in the end
anyway, for efficiency), and it makes it easier to calculate how much
to subtract from re_eval_start.

This fix does not apply to here-docs in quotes in multiline string
evals, which crashes and always has.

diff --git a/perl.h b/perl.h
index 36eec0d..f4dc00e 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3458,6 +3458,7 @@ struct _sublex_info {
     OP *sub_op;                /* "lex_op" to use */
     char *super_bufptr;        /* PL_parser->bufptr that was */
     char *re_eval_start;/* start of "(?{..." text */
+    SV *re_eval_str;   /* "(?{...})" text */
     SV *repl;          /* replacement of s/// or y/// */
 };
 

diff --git a/t/base/lex.t b/t/base/lex.t
index aaa2aeb..75529d8 100644 (file)
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..63\n";
+print "1..65\n";
 
 $x = 'x';
 
@@ -313,3 +313,13 @@ print $_ || "not ok 62\n";
 $_ = "not ok 63 - s/// in s/// pattern\n";
 s/${s|||;\""}not //;
 print;
+
+/(?{print <<END
+ok 64 - here-doc in re-eval
+END
+})/;
+
+eval '/(?{print <<END
+ok 65 - here-doc in re-eval in string eval
+END
+})/';

diff --git a/toke.c b/toke.c
index 7e3309d..48d4f3d 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2461,6 +2461,7 @@ S_sublex_push(pTHX)
     SAVEI8(PL_lex_state);
     SAVESPTR(PL_lex_repl);
     SAVEPPTR(PL_sublex_info.re_eval_start);
+    SAVESPTR(PL_sublex_info.re_eval_str);
     SAVEPPTR(PL_sublex_info.super_bufptr);
     SAVEVPTR(PL_lex_inpat);
     SAVEI16(PL_lex_inwhat);
@@ -2501,6 +2502,7 @@ S_sublex_push(pTHX)
     PL_lex_stuff = NULL;
     PL_sublex_info.repl = NULL;
     PL_sublex_info.re_eval_start = NULL;
+    PL_sublex_info.re_eval_str = NULL;
 
     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
        = SvPVX(PL_linestr);
@@ -4734,18 +4736,30 @@ Perl_yylex(pTHX)
                Perl_croak(aTHX_ "Bad evalled substitution pattern");
            PL_lex_repl = NULL;
        }
-       if (PL_sublex_info.re_eval_start) {
+       /* Paranoia.  re_eval_start is adjusted when S_scan_heredoc sets
+          re_eval_str.  If the here-doc body’s length equals the previous
+          value of re_eval_start, re_eval_start will now be null.  So
+          check re_eval_str as well. */
+       if (PL_sublex_info.re_eval_start || PL_sublex_info.re_eval_str) {
+           SV *sv;
            if (*PL_bufptr != ')')
                Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
            PL_bufptr++;
            /* having compiled a (?{..}) expression, return the original
             * text too, as a const */
+           if (PL_sublex_info.re_eval_str) {
+               sv = PL_sublex_info.re_eval_str;
+               PL_sublex_info.re_eval_str = NULL;
+               SvCUR_set(sv, PL_bufptr - PL_sublex_info.re_eval_start);
+               SvPV_shrink_to_cur(sv);
+           }
+           else sv = newSVpvn(PL_sublex_info.re_eval_start,
+                              PL_bufptr - PL_sublex_info.re_eval_start);
            start_force(PL_curforce);
            /* XXX probably need a CURMAD(something) here */
            NEXTVAL_NEXTTOKE.opval =
                    (OP*)newSVOP(OP_CONST, 0,
-                       newSVpvn(PL_sublex_info.re_eval_start,
-                               PL_bufptr - PL_sublex_info.re_eval_start));
+                                sv);
            force_next(THING);
            PL_sublex_info.re_eval_start = NULL;
            PL_expect = XTERM;
@@ -9674,6 +9688,7 @@ S_scan_heredoc(pTHX_ register char *s)
        goto retval;
     }
     else if (!infile || found_newline) {
+       char * const olds = s - SvCUR(herewas);
        d = s;
        while (s < PL_bufend &&
          (*s != '\n' || memNE(s,PL_tokenbuf,len)) ) {
@@ -9697,11 +9712,22 @@ S_scan_heredoc(pTHX_ register char *s)
        s += len - 1;
        CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
 
-       sv_catpvn(herewas,s,PL_bufend-s);
-       sv_setsv(PL_linestr,herewas);
-       PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
+       /* s now points to the newline after the heredoc terminator.
+          d points to the newline before the body of the heredoc.
+        */
+       if (PL_sublex_info.re_eval_start) {
+           /* Set aside the rest of the regexp */
+           if (!PL_sublex_info.re_eval_str)
+               PL_sublex_info.re_eval_str =
+                      newSVpvn(PL_sublex_info.re_eval_start,
+                               PL_bufend - PL_sublex_info.re_eval_start);
+           PL_sublex_info.re_eval_start -= s-d;
+       }
+       /* Copy everything from s onwards back to d. */
+       Move(s,d,PL_bufend-s + 1,char);
+       SvCUR_set(PL_linestr, SvCUR(PL_linestr) - (s-d));
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
-       PL_last_lop = PL_last_uni = NULL;
+       s = olds;
     }
     else
        sv_setpvs(tmpstr,"");   /* avoid "uninitialized" warning */