From: Zefram <zefram@fysh.org>
Date: Wed, 25 Nov 2009 22:17:52 +0000 (+0000)
Subject: perl-5.11.2 breaks NYTProf savesrc option (Lexer API suspected)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=17cc9359ea8ee1b546aa067b91362160e3c1e1ee;p=p5sagit%2Fp5-mst-13.2.git

perl-5.11.2 breaks NYTProf savesrc option (Lexer API suspected)

Tim Bunce wrote:
>The primary issue is the off-by-one error in the array indexing.

There's a bit more to it than that.  The indexing was off-by-one for
*some* places that process a new line, but correct for others, so the
saved source as a whole was mangled rather than simply offset.  Also,
there were some redundant calls to update_debugger_info(), so some lines
got saved twice, in some cases off-by-one for one saving and not for
the other.  The saved source is, therefore, hopelessly broken in 5.11.2.

Attached patch fixes the source saving.  Includes a new test, which works
through all reachable places that source lines get saved.  This should
close RT #70804.

-zefram
---

diff --git a/MANIFEST b/MANIFEST
index bc4460d..04e197d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4188,6 +4188,8 @@ t/comp/decl.t			See if declarations work
 t/comp/fold.t			See if constant folding works
 t/comp/hints.aux		Auxillary file for %^H test
 t/comp/hints.t			See if %^H works
+t/comp/line_debug_0.aux		Auxiliary file for @{"_<$file"} test
+t/comp/line_debug.t		See if @{"_<$file"} works
 t/comp/multiline.t		See if multiline strings work
 t/comp/opsubs.t			See if q() etc. are not parsed as functions
 t/comp/our.t			Tests for our declaration
diff --git a/t/comp/line_debug.t b/t/comp/line_debug.t
new file mode 100644
index 0000000..175c71a
--- /dev/null
+++ b/t/comp/line_debug.t
@@ -0,0 +1,31 @@
+#!./perl
+
+chdir 't' if -d 't';
+
+sub ok {
+    my($test,$ok) = @_;
+    print "not " unless $ok;
+    print "ok $test\n";
+}
+
+# The auxiliary file contains a bunch of code that systematically exercises
+# every place that can call lex_next_chunk() (except for the one that's not
+# used by the main Perl parser).
+open AUX, "<", "comp/line_debug_0.aux" or die $!;
+my @lines = <AUX>;
+close AUX;
+my $nlines = @lines;
+
+print "1..", 2+$nlines, "\n";
+
+$^P = 0x2;
+do "comp/line_debug_0.aux";
+
+ok 1, scalar(@{"_<comp/line_debug_0.aux"}) == 1+$nlines;
+ok 2, !defined(${"_<comp/line_debug_0.aux"}[0]);
+
+for(1..$nlines) {
+	ok 2+$_, ${"_<comp/line_debug_0.aux"}[$_] eq $lines[$_-1];
+}
+
+1;
diff --git a/t/comp/line_debug_0.aux b/t/comp/line_debug_0.aux
new file mode 100644
index 0000000..2d31d74
--- /dev/null
+++ b/t/comp/line_debug_0.aux
@@ -0,0 +1,20 @@
+$z = 'line one';
+$z
+    =
+    'multiline statement';
+$z = 'line five';
+$z = '
+    multiline
+    string
+';
+$z = 'line ten';
+$z = <<EOS;
+    multiline
+    heredoc
+EOS
+$z = 'line fifteen';
+format Z =
+    @<<<< multiline format
+    $z
+.
+$z = 'line twenty';
diff --git a/toke.c b/toke.c
index f214ddf..72fc10b 100644
--- a/toke.c
+++ b/toke.c
@@ -1197,6 +1197,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
     STRLEN old_bufend_pos, new_bufend_pos;
     STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
     STRLEN linestart_pos, last_uni_pos, last_lop_pos;
+    bool got_some_for_debugger = 0;
     bool got_some;
     if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
 	Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
@@ -1231,6 +1232,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
 	got_some = 0;
     } else if (filter_gets(linestr, old_bufend_pos)) {
 	got_some = 1;
+	got_some_for_debugger = 1;
     } else {
 	if (!SvPOK(linestr))   /* can get undefined by filter_gets */
 	    sv_setpvs(linestr, "");
@@ -1270,7 +1272,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
 	PL_parser->last_uni = buf + last_uni_pos;
     if (PL_parser->last_lop)
 	PL_parser->last_lop = buf + last_lop_pos;
-    if (got_some && (PERLDB_LINE || PERLDB_SAVESRC) &&
+    if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
 	    PL_curstash != PL_debstash) {
 	/* debugger active and we're not compiling the debugger code,
 	 * so store the line into the debugger's array of lines
@@ -4324,10 +4326,13 @@ Perl_yylex(pTHX)
 		fake_eof = LEX_FAKE_EOF;
 	    }
 	    PL_bufptr = PL_bufend;
+	    CopLINE_inc(PL_curcop);
 	    if (!lex_next_chunk(fake_eof)) {
+		CopLINE_dec(PL_curcop);
 		s = PL_bufptr;
 		TOKEN(';');	/* not infinite loop because rsfp is NULL now */
 	    }
+	    CopLINE_dec(PL_curcop);
 #ifdef PERL_MAD
 	    if (!PL_rsfp)
 		PL_realtokenstart = -1;
@@ -4363,8 +4368,6 @@ Perl_yylex(pTHX)
 	    incline(s);
 	} while (PL_doextract);
 	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
-	if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
-	    update_debugger_info(PL_linestr, NULL, 0);
 	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 	PL_last_lop = PL_last_uni = NULL;
 	if (CopLINE(PL_curcop) == 1) {
@@ -12018,10 +12021,12 @@ S_scan_heredoc(pTHX_ register char *s)
 	}
 #endif
 	PL_bufptr = s;
+	CopLINE_inc(PL_curcop);
 	if (!outer || !lex_next_chunk(0)) {
 	    CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 	    missingterm(PL_tokenbuf);
 	}
+	CopLINE_dec(PL_curcop);
 	s = PL_bufptr;
 #ifdef PERL_MAD
 	stuffstart = s - SvPVX(PL_linestr);
@@ -12044,8 +12049,6 @@ S_scan_heredoc(pTHX_ register char *s)
 	else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
 	    PL_bufend[-1] = '\n';
 #endif
-	if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
-	    update_debugger_info(PL_linestr, NULL, 0);
 	if (*s == term && memEQ(s,PL_tokenbuf,len)) {
 	    STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
 	    *(SvPVX(PL_linestr) + off ) = ' ';