From 583c9d5cccfe6eadf42350e2baa975576a360f02 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Mon, 6 Aug 2012 08:38:28 -0700
Subject: [perl #114040] Parse formats in interpolating constructs
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

For re-evals, this is something that broke recently, post-5.16 (the
jumbo fix).  For other interpolating constructs, this has never
worked, as far as I can tell.

The lexer was losing track of PL_lex_state (aka PL_parser->lex_state)
when parsing formats.  Usually, the state alternates between
LEX_FORMLINE (a picture line) and LEX_NORMAL (an argument line), but
the LEX_NORMAL should actually be whatever the state was before the
format started.

This commit adds a new parser member to track the ‘normal’ state when
parsing a format.

It also tweaks S_scan_formline to handle multi-line buffers outside of
string eval (such as happens in interpolating constructs).

That bufend assignment that is removed as a result is not necessary as
of a0d0e21ea6ea (perl 5.000).  That very commit added a bufend assign-
ment after the sv_gets (later filter_gets; later lex_next_chunk) fur-
ther down in the loop in scan_formline.
---
 parser.h        |  1 +
 t/comp/parser.t | 11 ++++++++++-
 toke.c          | 19 ++++++++++---------
 3 files changed, 21 insertions(+), 10 deletions(-)

diff --git a/parser.h b/parser.h
index 1d5a7a876b..bfb2480127 100644
--- a/parser.h
+++ b/parser.h
@@ -80,6 +80,7 @@ typedef struct yy_parser {
     HV		*in_my_stash;	/* declared class of this "my" declaration */
     PerlIO	*rsfp;		/* current source file pointer */
     AV		*rsfp_filters;	/* holds chain of active source filters */
+    U8		form_lex_state;	/* remember lex_state when parsing fmt */
 
 #ifdef PERL_MAD
     SV		*endwhite;
diff --git a/t/comp/parser.t b/t/comp/parser.t
index ac6742e103..8ada9ab720 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -3,7 +3,7 @@
 # Checks if the parser behaves correctly in edge cases
 # (including weird syntax errors)
 
-print "1..137\n";
+print "1..138\n";
 
 sub failed {
     my ($got, $expected, $name) = @_;
@@ -388,6 +388,15 @@ is $::{waru}, undef, 'sub w attr+proto ignored after compilation error';
 is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error';
 is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error';
 
+$test = $test + 1;
+"ok $test - format inside re-eval" =~ /(?{
+    format =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$_
+.
+write
+}).*/;
+
 # Add new tests HERE (above this line)
 
 # bug #74022: Loop on characters in \p{OtherIDContinue}
diff --git a/toke.c b/toke.c
index 89047c87da..84685b0d26 100644
--- a/toke.c
+++ b/toke.c
@@ -4771,7 +4771,7 @@ Perl_yylex(pTHX)
 
 	return yylex();
     case LEX_FORMLINE:
-	PL_lex_state = LEX_NORMAL;
+	PL_lex_state = PL_parser->form_lex_state;
 	s = scan_formline(PL_bufptr);
 	if (!PL_lex_formbrack)
 	{
@@ -5894,6 +5894,7 @@ Perl_yylex(pTHX)
 	    CURMAD('_', PL_thiswhite);
 	}
 	force_next(formbrack ? '.' : '}');
+	if (formbrack) LEAVE;
 #ifdef PERL_MAD
 	if (!PL_thistoken)
 	    PL_thistoken = newSVpvs("");
@@ -6026,6 +6027,9 @@ Perl_yylex(pTHX)
 		s--;
 		PL_expect = XBLOCK;
 		formbrack = TRUE;
+		ENTER;
+		SAVEI8(PL_parser->form_lex_state);
+		PL_parser->form_lex_state = PL_lex_state;
 		goto leftbracket;
 	    }
 	}
@@ -10641,13 +10645,9 @@ S_scan_formline(pTHX_ register char *s)
 		break;
             }
 	}
-	if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
-	    eol = (char *) memchr(s,'\n',PL_bufend-s);
-	    if (!eol++)
+	eol = (char *) memchr(s,'\n',PL_bufend-s);
+	if (!eol++)
 		eol = PL_bufend;
-	}
-	else
-	    eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 	if (*s != '#') {
 	    for (t = s; t < eol; t++) {
 		if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
@@ -10672,7 +10672,8 @@ S_scan_formline(pTHX_ register char *s)
 	      break;
 	}
 	s = (char*)eol;
-	if (PL_rsfp || PL_parser->filtered) {
+	if ((PL_rsfp || PL_parser->filtered)
+	 && PL_parser->form_lex_state == LEX_NORMAL) {
 	    bool got_some;
 #ifdef PERL_MAD
 	    if (PL_madskills) {
@@ -10699,7 +10700,7 @@ S_scan_formline(pTHX_ register char *s)
     if (SvCUR(stuff)) {
 	PL_expect = XTERM;
 	if (needargs) {
-	    PL_lex_state = LEX_NORMAL;
+	    PL_lex_state = PL_parser->form_lex_state;
 	    start_force(PL_curforce);
 	    NEXTVAL_NEXTTOKE.ival = 0;
 	    force_next(',');
-- 
cgit v1.2.1