integrate binary compatible variant of change#3098 from mainline

p4raw-link: @3098 on //depot/perl: 0244c3a403af2426ac6678d042024bb183ebbfa9

p4raw-id: //depot/maint-5.005/perl@3188

diff --git a/op.c b/op.c
index 97fc41b..f360add 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2228,8 +2228,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 e06764c..cab0bbc 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2184,7 +2184,8 @@ PERLVAR(srand_called,     bool)
 PERLVAR(uudmap[256],   char)
 PERLVAR(bitcount,              char*)
 PERLVAR(filter_debug,  int)
-
+PERLVAR(super_bufptr,  char*)  /* PL_bufptr that was */
+PERLVAR(super_bufend,  char*)  /* PL_bufend that was */
 
 /*
  * The following is a buffer where new variables must

diff --git a/t/base/lex.t b/t/base/lex.t
index 045cb22..8e2452d 100755 (executable)
--- 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..30\n";
+print "1..35\n";
 
 $x = 'x';
 
@@ -117,3 +115,30 @@ $foo =~ s/^not /substr(<<EOF, 0, 0)/e;
   Ignored
 EOF
 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 = 31;
+
+{
+# 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 dc083cc..52a42af 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -53,6 +53,9 @@ static void restore_rsfp _((void *f));
 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
 static void restore_expect _((void *e));
 static void restore_lex_expect _((void *e));
+
+static char *PL_super_bufptr;
+static char *PL_super_bufend;
 #endif /* PERL_OBJECT */
 
 static char ident_too_long[] = "Identifier too long";
@@ -5125,6 +5128,9 @@ scan_subst(char *start)
 
     if (es) {
        SV *repl;
+       PL_super_bufptr = s;
+       PL_super_bufend = PL_bufend;
+       PL_multi_end = 0;
        pm->op_pmflags |= PMf_EVAL;
        repl = newSVpv("",0);
        while (es-- > 0)
@@ -5287,7 +5293,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_super_bufptr;
+       char *bufend = PL_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)) ) {
@@ -5351,8 +5383,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);