Make source filters work in evalbytes

When a filter is added, the current buffer is hung on the end of
the filters array, and a new substring of it becomes the current
buffer.

4 files changed, 112 insertions, 29 deletions

diff --git a/ext/XS-APItest/t/eval-filter.t b/ext/XS-APItest/t/eval-filter.t
index d4a9153613..f54bd83707 100644
--- a/ext/XS-APItest/t/eval-filter.t
+++ b/ext/XS-APItest/t/eval-filter.t
@@ -1,16 +1,25 @@
 #!perl -w
 use strict;
 
-use Test::More tests => 3;
+use Test::More tests => 5;
 use XS::APItest;
 
 {
     use feature "unicode_eval";
     my $unfiltered_foo = "foo";
-    eval "BEGIN { filter() }";
-    like $@, qr/^Source filters apply only to byte streams at /,
+    BEGIN {
+      eval "BEGIN { filter() }";
+      like $@, qr/^Source filters apply only to byte streams at /,
 	'filters die under unicode_eval';
+    }
     is "foo", $unfiltered_foo, 'filters leak not out of unicode evals';
+
+    use feature "evalbytes";
+    our $thingy;
+    BEGIN { evalbytes "BEGIN { filter() }\n\$thingy = 'foo'" }
+    is $thingy, "fee",
+	"source filters apply to evalbytten strings";
+    is "foo", $unfiltered_foo, 'filters leak not out of byte evals';
 }
 
 BEGIN { eval "BEGIN{ filter() }" }
diff --git a/parser.h b/parser.h
index c19bc28258..36b1a43f54 100644
--- a/parser.h
+++ b/parser.h
@@ -107,6 +107,7 @@ typedef struct yy_parser {
 
     bool	in_pod;		/* lexer is within a =pod section */
     U8		lex_fakeeof;	/* precedence at which to fake EOF */
+    bool	filtered;	/* source filters in evalbytes */
     U32		lex_flags;
 } yy_parser;
 
@@ -116,8 +117,11 @@ typedef struct yy_parser {
 
 #ifdef PERL_CORE
 # define LEX_START_SAME_FILTER	0x00000001
+# define LEX_IGNORE_UTF8_HINTS	0x00000002
+# define LEX_EVALBYTES		0x00000004
+# define LEX_START_FLAGS \
+	(LEX_START_SAME_FILTER|LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES)
 #endif
-#define LEX_IGNORE_UTF8_HINTS	0x00000002
 
 /* flags for parser API */
 #define PARSE_OPTIONAL          0x00000001
diff --git a/pp_ctl.c b/pp_ctl.c
index 9b9bff9a8f..7b059dee6e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4127,6 +4127,7 @@ PP(pp_entereval)
     CV* runcv;
     U32 seq;
     HV *saved_hh = NULL;
+    const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
 
     if (PL_op->op_private & OPpEVAL_HAS_HH) {
 	saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
@@ -4146,10 +4147,10 @@ PP(pp_entereval)
 
 	sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
 
-	if (PL_op->op_private & OPpEVAL_BYTES && SvUTF8(sv))
+	if (bytes && SvUTF8(sv))
 	    SvPVbyte_force(sv, len);
     }
-    else if (PL_op->op_private & OPpEVAL_BYTES && SvUTF8(sv)) {
+    else if (bytes && SvUTF8(sv)) {
 	/* Don’t modify someone else’s scalar */
 	STRLEN len;
 	sv = newSVsv(sv);
@@ -4160,9 +4161,10 @@ PP(pp_entereval)
     TAINT_PROPER("eval");
 
     ENTER_with_name("eval");
-    lex_start(sv, NULL, LEX_START_SAME_FILTER |
-			  ( PL_op->op_private & OPpEVAL_UNICODE
-			     ? LEX_IGNORE_UTF8_HINTS : 0 ));
+    lex_start(sv, NULL, PL_op->op_private & OPpEVAL_UNICODE
+			   ? LEX_IGNORE_UTF8_HINTS
+			   : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
+	     );
     SAVETMPS;
 
     /* switch to eval mode */
diff --git a/toke.c b/toke.c
index b1acdd3408..e01080b765 100644
--- a/toke.c
+++ b/toke.c
@@ -686,7 +686,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
     const char *s = NULL;
     STRLEN len;
     yy_parser *parser, *oparser;
-    if (flags && flags & ~(LEX_START_SAME_FILTER|LEX_IGNORE_UTF8_HINTS))
+    if (flags && flags & ~LEX_START_FLAGS)
 	Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
 
     /* create and initialise a parser */
@@ -743,9 +743,9 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
 	parser->linestart = SvPVX(parser->linestr);
     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
     parser->last_lop = parser->last_uni = NULL;
-    parser->lex_flags = flags & LEX_IGNORE_UTF8_HINTS;
+    parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES);
 
-    parser->in_pod = 0;
+    parser->in_pod = parser->filtered = 0;
 }
 
 
@@ -1263,7 +1263,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
     }
     if (flags & LEX_FAKE_EOF) {
 	goto eof;
-    } else if (!PL_parser->rsfp) {
+    } else if (!PL_parser->rsfp && !PL_parser->filtered) {
 	got_some = 0;
     } else if (filter_gets(linestr, old_bufend_pos)) {
 	got_some = 1;
@@ -1280,7 +1280,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
 	else if (PL_parser->rsfp)
 	    (void)PerlIO_close(PL_parser->rsfp);
 	PL_parser->rsfp = NULL;
-	PL_parser->in_pod = 0;
+	PL_parser->in_pod = PL_parser->filtered = 0;
 #ifdef PERL_MAD
 	if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
 	    PL_faketokens = 1;
@@ -3854,6 +3854,45 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
 			  SvPV_nolen(datasv)));
     av_unshift(PL_rsfp_filters, 1);
     av_store(PL_rsfp_filters, 0, datasv) ;
+    if (
+	!PL_parser->filtered
+     && PL_parser->lex_flags & LEX_EVALBYTES
+     && PL_bufptr < PL_bufend
+    ) {
+	const char *s = PL_bufptr;
+	while (s < PL_bufend) {
+	    if (*s == '\n') {
+		SV *linestr = PL_parser->linestr;
+		char *buf = SvPVX(linestr);
+		STRLEN const bufptr_pos = PL_parser->bufptr - buf;
+		STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
+		STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
+		STRLEN const linestart_pos = PL_parser->linestart - buf;
+		STRLEN const last_uni_pos =
+		    PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
+		STRLEN const last_lop_pos =
+		    PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
+		av_push(PL_rsfp_filters, linestr);
+		PL_parser->linestr = 
+		    newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
+		buf = SvPVX(PL_parser->linestr);
+		PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
+		PL_parser->bufptr = buf + bufptr_pos;
+		PL_parser->oldbufptr = buf + oldbufptr_pos;
+		PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
+		PL_parser->linestart = buf + linestart_pos;
+		if (PL_parser->last_uni)
+		    PL_parser->last_uni = buf + last_uni_pos;
+		if (PL_parser->last_lop)
+		    PL_parser->last_lop = buf + last_lop_pos;
+		SvLEN(linestr) = SvCUR(linestr);
+		SvCUR(linestr) = s-SvPVX(linestr);
+		PL_parser->filtered = 1;
+		break;
+	    }
+	    s++;
+	}
+    }
     return(datasv);
 }
 
@@ -3896,7 +3935,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
     /* This API is bad. It should have been using unsigned int for maxlen.
        Not sure if we want to change the API, but if not we should sanity
        check the value here.  */
-    const unsigned int correct_length
+    unsigned int correct_length
 	= maxlen < 0 ?
 #ifdef PERL_MICRO
 	0x7FFFFFFF
@@ -3948,6 +3987,31 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
 			      idx));
 	return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
     }
+    if (SvTYPE(datasv) != SVt_PVIO) {
+	if (correct_length) {
+ 	    /* Want a block */
+	    const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
+	    if (!remainder) return 0; /* eof */
+	    if (correct_length > remainder) correct_length = remainder;
+	    sv_catpvn(buf_sv, SvEND(datasv), correct_length);
+	    SvCUR_set(datasv, SvCUR(datasv) + correct_length);
+	} else {
+	    /* Want a line */
+	    const char *s = SvEND(datasv);
+	    const char *send = SvPVX(datasv) + SvLEN(datasv);
+	    while (s < send) {
+		if (*s == '\n') {
+		    s++;
+		    break;
+		}
+		s++;
+	    }
+	    if (s == send) return 0; /* eof */
+	    sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
+	    SvCUR_set(datasv, s-SvPVX(datasv));
+	}
+	return SvCUR(buf_sv);
+    }
     /* Get function pointer hidden within datasv	*/
     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
     DEBUG_P(PerlIO_printf(Perl_debug_log,
@@ -4100,7 +4164,7 @@ Perl_madlex(pTHX)
 	}
 
 	/* put off final whitespace till peg */
-	if (optype == ';' && !PL_rsfp) {
+	if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
 	    PL_nextwhite = PL_thiswhite;
 	    PL_thiswhite = 0;
 	}
@@ -4684,7 +4748,7 @@ Perl_yylex(pTHX)
 	if (PL_madskills)
 	    PL_faketokens = 0;
 #endif
-	if (!PL_rsfp) {
+	if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
 	    PL_last_uni = 0;
 	    PL_last_lop = 0;
 	    if (PL_lex_brackets &&
@@ -4831,7 +4895,7 @@ Perl_yylex(pTHX)
 		    PL_parser->in_pod = 0;
 		}
 	    }
-	    if (PL_rsfp)
+	    if (PL_rsfp || PL_parser->filtered)
 		incline(s);
 	} while (PL_parser->in_pod);
 	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -5057,15 +5121,17 @@ Perl_yylex(pTHX)
 	if (PL_madskills)
 	    PL_faketokens = 0;
 #endif
-	if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
-	    if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
+	if (PL_lex_state != LEX_NORMAL ||
+	     (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
+	    if (*s == '#' && s == PL_linestart && PL_in_eval
+	     && !PL_rsfp && !PL_parser->filtered) {
 		/* handle eval qq[#line 1 "foo"\n ...] */
 		CopLINE_dec(PL_curcop);
 		incline(s);
 	    }
 	    if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
 		s = SKIPSPACE0(s);
-		if (!PL_in_eval || PL_rsfp)
+		if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
 		    incline(s);
 	    }
 	    else {
@@ -5842,7 +5908,7 @@ Perl_yylex(pTHX)
 	    if (PL_expect == XSTATE && isALPHA(tmp) &&
 		(s == PL_linestart+1 || s[-2] == '\n') )
 		{
-		    if (PL_in_eval && !PL_rsfp) {
+		    if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
 			d = PL_bufend;
 			while (s < d) {
 			    if (*s++ == '\n') {
@@ -9259,7 +9325,8 @@ S_scan_heredoc(pTHX_ register char *s)
     register char *d;
     register char *e;
     char *peek;
-    const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
+    const int outer = (PL_rsfp || PL_parser->filtered)
+		   && !(PL_lex_inwhat == OP_SCALAR);
 #ifdef PERL_MAD
     I32 stuffstart = s - SvPVX(PL_linestr);
     char *tstart;
@@ -9383,7 +9450,8 @@ S_scan_heredoc(pTHX_ register char *s)
     PL_multi_start = CopLINE(PL_curcop);
     PL_multi_open = PL_multi_close = '<';
     term = *PL_tokenbuf;
-    if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
+    if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp
+     && !PL_parser->filtered) {
 	char * const bufptr = PL_sublex_info.super_bufptr;
 	char * const bufend = PL_sublex_info.super_bufend;
 	char * const olds = s - SvCUR(herewas);
@@ -9806,7 +9874,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 		char * const svlast = SvEND(sv) - 1;
 
 		for (; s < ns; s++) {
-		    if (*s == '\n' && !PL_rsfp)
+		    if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
 			CopLINE_inc(PL_curcop);
 		}
 		if (!found)
@@ -9873,7 +9941,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 	if (PL_multi_open == PL_multi_close) {
 	    for (; s < PL_bufend; s++,to++) {
 	    	/* embedded newlines increment the current line number */
-		if (*s == '\n' && !PL_rsfp)
+		if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
 		    CopLINE_inc(PL_curcop);
 		/* handle quoted delimiters */
 		if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
@@ -9905,7 +9973,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 	    /* read until we run out of string, or we find the terminator */
 	    for (; s < PL_bufend; s++,to++) {
 	    	/* embedded newlines increment the line count */
-		if (*s == '\n' && !PL_rsfp)
+		if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
 		    CopLINE_inc(PL_curcop);
 		/* backslashes can escape the open or closing characters */
 		if (*s == '\\' && s+1 < PL_bufend) {
@@ -10465,7 +10533,7 @@ S_scan_formline(pTHX_ register char *s)
 		break;
             }
 	}
-	if (PL_in_eval && !PL_rsfp) {
+	if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
 	    eol = (char *) memchr(s,'\n',PL_bufend-s);
 	    if (!eol++)
 		eol = PL_bufend;
@@ -10496,7 +10564,7 @@ S_scan_formline(pTHX_ register char *s)
 	      break;
 	}
 	s = (char*)eol;
-	if (PL_rsfp) {
+	if (PL_rsfp || PL_parser->filtered) {
 	    bool got_some;
 #ifdef PERL_MAD
 	    if (PL_madskills) {