fix parsing of here documents in C<eval 's/.../<<FOO/e'>

p4raw-id: //depot/perl@3098

5 files changed, 80 insertions, 6 deletions

diff --git a/op.c b/op.c
index 88680579b8..220327ddca 100644
--- a/op.c
+++ b/op.c
@@ -2506,8 +2506,11 @@ pmruntime(OP *o, OP *expr, OP *repl)
 
     if (repl) {
 	OP *curop;
-	if (pm->op_pmflags & PMf_EVAL)
+	if (pm->op_pmflags & PMf_EVAL) {
 	    curop = 0;
+	    if (PL_curcop->cop_line < PL_multi_end)
+		PL_curcop->cop_line = PL_multi_end;
+	}
 #ifdef USE_THREADS
 	else if (repl->op_type == OP_THREADSV
 		 && strchr("&`'123456789+",
diff --git a/perl.h b/perl.h
index d50a3b6e57..c01701edc4 100644
--- a/perl.h
+++ b/perl.h
@@ -1541,6 +1541,8 @@ struct _sublex_info {
     I32 super_state;	/* lexer state to save */
     I32 sub_inwhat;	/* "lex_inwhat" to use */
     OP *sub_op;		/* "lex_op" to use */
+    char *super_bufptr;	/* PL_bufptr that was */
+    char *super_bufend;	/* PL_bufend that was */
 };
 
 typedef struct magic_state MGS;	/* struct magic_state defined in mg.c */
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 022fe924ab..49ffc263d4 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -202,6 +202,21 @@ Note that the behavior of:
 
 is unchanged (it continues to leave the file empty).
 
+=head2 C<eval '...'> improvements
+
+Line numbers (as reflected by caller() and most diagnostics) within
+C<eval '...'> were often incorrect when here documents were involved.
+This has been corrected.
+
+Lexical lookups for variables appearing in C<eval '...'> within
+functions that were themselves called within an C<eval '...'> were
+searching the wrong place for lexicals.  They now correctly terminate
+the lexical search at the subroutine call boundary.
+
+Parsing of here documents used to be flawed when they appeared as
+the replacement expression in C<eval 's/.../.../e'>.  This has
+been fixed.
+
 =head1 Supported Platforms
 
 =over 4
diff --git a/t/base/lex.t b/t/base/lex.t
index 6bb39d0ae7..d90d404cac 100755
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $
-
-print "1..41\n";
+print "1..46\n";
 
 $x = 'x';
 
@@ -155,6 +153,7 @@ print $foo;
   # These next two tests are trying to make sure that
   # $^FOO is always global; it doesn't make sense to `my' it.
   # 
+
   eval 'my $^X;';
   print "not " unless index ($@, 'Can\'t use global $^X in "my"') > -1;
   print "ok 37\n";
@@ -181,4 +180,29 @@ print $foo;
   
 }
 
+# see if eval '', s///e, and heredocs mix
 
+sub T {
+    my ($where, $num) = @_;
+    my ($p,$f,$l) = caller;
+    print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/;
+    print "ok $num\n";
+}
+
+my $test = 42;
+
+{
+# line 42 "plink"
+    local $_ = "not ok ";
+    eval q{
+	s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++;
+# fuggedaboudit
+EOT
+        print $_, $test++, "\n";
+	T('^main:\(eval \d+\):6$', $test++);
+# line 1 "plunk"
+	T('^main:plunk:1$', $test++);
+    };
+    print "# $@\nnot ok $test\n" if $@;
+    T '^main:plink:53$', $test++;
+}
diff --git a/toke.c b/toke.c
index d6fc1b81fd..1a17904f2c 100644
--- a/toke.c
+++ b/toke.c
@@ -5352,6 +5352,9 @@ scan_subst(char *start)
 
     if (es) {
 	SV *repl;
+	PL_sublex_info.super_bufptr = s;
+	PL_sublex_info.super_bufend = PL_bufend;
+	PL_multi_end = 0;
 	pm->op_pmflags |= PMf_EVAL;
 	repl = newSVpv("",0);
 	while (es-- > 0)
@@ -5541,7 +5544,33 @@ scan_heredoc(register char *s)
     PL_multi_start = PL_curcop->cop_line;
     PL_multi_open = PL_multi_close = '<';
     term = *PL_tokenbuf;
-    if (!outer) {
+    if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
+	char *bufptr = PL_sublex_info.super_bufptr;
+	char *bufend = PL_sublex_info.super_bufend;
+	char *olds = s - SvCUR(herewas);
+	s = strchr(bufptr, '\n');
+	if (!s)
+	    s = bufend;
+	d = s;
+	while (s < bufend &&
+	  (*s != term || memNE(s,PL_tokenbuf,len)) ) {
+	    if (*s++ == '\n')
+		PL_curcop->cop_line++;
+	}
+	if (s >= bufend) {
+	    PL_curcop->cop_line = PL_multi_start;
+	    missingterm(PL_tokenbuf);
+	}
+	sv_setpvn(herewas,bufptr,d-bufptr+1);
+	sv_setpvn(tmpstr,d+1,s-d);
+	s += len - 1;
+	sv_catpvn(herewas,s,bufend-s);
+	(void)strcpy(bufptr,SvPVX(herewas));
+
+	s = olds;
+	goto retval;
+    }
+    else if (!outer) {
 	d = s;
 	while (s < PL_bufend &&
 	  (*s != term || memNE(s,PL_tokenbuf,len)) ) {
@@ -5605,8 +5634,9 @@ scan_heredoc(register char *s)
 	    sv_catsv(tmpstr,PL_linestr);
 	}
     }
-    PL_multi_end = PL_curcop->cop_line;
     s++;
+retval:
+    PL_multi_end = PL_curcop->cop_line;
     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
 	SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
 	Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);