Improve -DT output and fix wild buffer pointer error

p4raw-id: //depot/perl@25674

diff --git a/toke.c b/toke.c
index 998e7a1..717bfdc 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -66,17 +66,22 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
 
 /* #define LEX_NOTPARSING              11 is done in perl.h. */
 
-#define LEX_NORMAL             10
-#define LEX_INTERPNORMAL        9
-#define LEX_INTERPCASEMOD       8
-#define LEX_INTERPPUSH          7
-#define LEX_INTERPSTART                 6
-#define LEX_INTERPEND           5
-#define LEX_INTERPENDMAYBE      4
-#define LEX_INTERPCONCAT        3
-#define LEX_INTERPCONST                 2
-#define LEX_FORMLINE            1
-#define LEX_KNOWNEXT            0
+#define LEX_NORMAL             10 /* normal code (ie not within "...")     */
+#define LEX_INTERPNORMAL        9 /* code within a string, eg "$foo[$x+1]" */
+#define LEX_INTERPCASEMOD       8 /* expecting a \U, \Q or \E etc          */
+#define LEX_INTERPPUSH          7 /* starting a new sublex parse level     */
+#define LEX_INTERPSTART                 6 /* expecting the start of a $var         */
+
+                                  /* at end of code, eg "$x" followed by:  */
+#define LEX_INTERPEND           5 /* ... eg not one of [, { or ->          */
+#define LEX_INTERPENDMAYBE      4 /* ... eg one of [, { or ->              */
+
+#define LEX_INTERPCONCAT        3 /* expecting anything, eg at start of
+                                       string or after \E, $foo, etc       */
+#define LEX_INTERPCONST                 2 /* NOT USED */
+#define LEX_FORMLINE            1 /* expecting a format line               */
+#define LEX_KNOWNEXT            0 /* next token known; just return it      */
+
 
 #ifdef DEBUGGING
 static const char* const lex_state_names[] = {
@@ -315,25 +320,35 @@ S_tokereport(pTHX_ const char* s, I32 rv)
            Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
            break;
        case TOKENTYPE_OPVAL:
-           if (yylval.opval)
+           if (yylval.opval) {
                Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
                                    PL_op_name[yylval.opval->op_type]);
+               if (yylval.opval->op_type == OP_CONST) {
+                   Perl_sv_catpvf(aTHX_ report, " %s",
+                       SvPEEK(cSVOPx_sv(yylval.opval)));
+               }
+
+           }
            else
                Perl_sv_catpv(aTHX_ report, "(opval=null)");
            break;
        }
-        Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop));
-        if (s - PL_bufptr > 0)
-            sv_catpvn(report, PL_bufptr, s - PL_bufptr);
-        else {
-            if (PL_oldbufptr && *PL_oldbufptr)
-                sv_catpv(report, PL_tokenbuf);
-        }
-        PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report));
+        PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
     };
     return (int)rv;
 }
 
+
+/* print the buffer with suitable escapes */
+
+STATIC void
+S_printbuf(pTHX_ const char* fmt, const char* s)
+{
+    SV* tmp = newSVpvn("", 0);
+    PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+    SvREFCNT_dec(tmp);
+}
+
 #endif
 
 /*
@@ -2403,8 +2418,13 @@ Perl_yylex(pTHX)
     I32 orig_keyword = 0;
 
     DEBUG_T( {
-       PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
-                                       lex_state_names[PL_lex_state]);
+       SV* tmp = newSVpvn("", 0);
+       PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
+           (IV)CopLINE(PL_curcop),
+           lex_state_names[PL_lex_state],
+           exp_name[PL_expect],
+           pv_display(tmp, s, strlen(s), 0, 60));
+       SvREFCNT_dec(tmp);
     } );
     /* check if there's an identifier for us to look at */
     if (PL_pending_ident)
@@ -2428,10 +2448,6 @@ Perl_yylex(pTHX)
            PL_expect = PL_lex_expect;
            PL_lex_defer = LEX_NORMAL;
        }
-       DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
-              (IV)PL_nexttype[PL_nexttoke]); });
-
        return REPORT(PL_nexttype[PL_nexttoke]);
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
@@ -2463,7 +2479,7 @@ Perl_yylex(pTHX)
        }
        else {
            DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Saw case modifier at '%s'\n", PL_bufptr); });
+              "### Saw case modifier\n"); });
            s = PL_bufptr + 1;
            if (s[1] == '\\' && s[2] == 'E') {
                PL_bufptr = s + 3;
@@ -2520,7 +2536,7 @@ Perl_yylex(pTHX)
        if (PL_bufptr == PL_bufend)
            return REPORT(sublex_done());
        DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Interpolated variable at '%s'\n", PL_bufptr); });
+              "### Interpolated variable\n"); });
        PL_expect = XTERM;
        PL_lex_dojoin = (*PL_bufptr == '@');
        PL_lex_state = LEX_INTERPNORMAL;
@@ -2620,10 +2636,6 @@ Perl_yylex(pTHX)
     s = PL_bufptr;
     PL_oldoldbufptr = PL_oldbufptr;
     PL_oldbufptr = s;
-    DEBUG_T( {
-       PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
-                     exp_name[PL_expect], s);
-    } );
 
   retry:
     switch (*s) {
@@ -3048,8 +3060,8 @@ Perl_yylex(pTHX)
 
            if (strnEQ(s,"=>",2)) {
                s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
-                DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                            "### Saw unary minus before =>, forcing word '%s'\n", s);
+                DEBUG_T( { S_printbuf(aTHX_
+                       "### Saw unary minus before =>, forcing word %s\n", s);
                 } );
                OPERATOR('-');          /* unary minus */
            }
@@ -3927,18 +3939,14 @@ Perl_yylex(pTHX)
     case '0': case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
        s = scan_num(s, &yylval);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw number in '%s'\n", s);
-        } );
+       DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
        if (PL_expect == XOPERATOR)
            no_op("Number",s);
        TERM(THING);
 
     case '\'':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw string before '%s'\n", s);
-        } );
+       DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
                PL_expect = XTERM;
@@ -3955,9 +3963,7 @@ Perl_yylex(pTHX)
 
     case '"':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw string before '%s'\n", s);
-        } );
+       DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
                PL_expect = XTERM;
@@ -3982,9 +3988,7 @@ Perl_yylex(pTHX)
 
     case '`':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw backtick string before '%s'\n", s);
-        } );
+       DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
        if (PL_expect == XOPERATOR)
            no_op("Backticks",s);
        if (!s)
@@ -5553,7 +5557,7 @@ S_pending_ident(pTHX)
     PL_pending_ident = 0;
 
     DEBUG_T({ PerlIO_printf(Perl_debug_log,
-          "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
+          "### Pending identifier '%s'\n", PL_tokenbuf); });
 
     /* if we're in a my(), we can't allow dynamics here.
        $foo'bar has already been turned into $foo::bar, so