diff options
author | Gurusamy Sarathy <gsar@cpan.org> | 1999-03-28 07:37:43 +0000 |
---|---|---|
committer | Gurusamy Sarathy <gsar@cpan.org> | 1999-03-28 07:37:43 +0000 |
commit | fb8eb184c37d9945af355cc34b5ee96ba224871b (patch) | |
tree | 4442bf51f1ea94e298d0073b7099c705ca40163d | |
parent | 91ba5197f61f83a7e86025d567042c3128e00ed0 (diff) | |
download | perl-fb8eb184c37d9945af355cc34b5ee96ba224871b.tar.gz |
integrate binary compatible variant of change#3098 from mainline
p4raw-link: @3098 on //depot/perl: 0244c3a403af2426ac6678d042024bb183ebbfa9
p4raw-id: //depot/maint-5.005/perl@3188
-rw-r--r-- | op.c | 5 | ||||
-rw-r--r-- | perl.h | 3 | ||||
-rwxr-xr-x | t/base/lex.t | 31 | ||||
-rw-r--r-- | toke.c | 37 |
4 files changed, 69 insertions, 7 deletions
@@ -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+", @@ -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 045cb22eb0..8e2452d8bb 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..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++; +} @@ -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); |