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 (file)
--- 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/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
 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 (file)
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 (file)
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 (file)
--- 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;
     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");
     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 = 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, "");
     } 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;
        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
            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;
                fake_eof = LEX_FAKE_EOF;
            }
            PL_bufptr = PL_bufend;

+           CopLINE_inc(PL_curcop);

            if (!lex_next_chunk(fake_eof)) {
            if (!lex_next_chunk(fake_eof)) {

+               CopLINE_dec(PL_curcop);

                s = PL_bufptr;
                TOKEN(';');     /* not infinite loop because rsfp is NULL now */
            }
                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;
 #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;
            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) {
        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;
        }
 #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);
        }
        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);
        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
        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 ) = ' ';
        if (*s == term && memEQ(s,PL_tokenbuf,len)) {
            STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
            *(SvPVX(PL_linestr) + off ) = ' ';