mention that caller() does not show XSUBs

[perl5.git] / dump.c

diff --git a/dump.c b/dump.c
index f1622a9..5ca838b 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -26,12 +26,11 @@
 #define PERL_IN_DUMP_C
 #include "perl.h"
 #include "regcomp.h"
-#include "proto.h"
 
 
 static const char* const svtypenames[SVt_LAST] = {
     "NULL",
-    "BIND",
+    "DUMMY",
     "IV",
     "NV",
     "PV",
@@ -51,7 +50,7 @@ static const char* const svtypenames[SVt_LAST] = {
 
 static const char* const svshorttypenames[SVt_LAST] = {
     "UNDEF",
-    "BIND",
+    "DUMMY",
     "IV",
     "NV",
     "PV",
@@ -457,7 +456,8 @@ Perl_sv_peek(pTHX_ SV *sv)
        sv_catpv(t, "VOID");
        goto finish;
     }
-    else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
+    else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
+        /* detect data corruption under memory poisoning */
        sv_catpv(t, "WILD");
        goto finish;
     }
@@ -561,7 +561,7 @@ Perl_sv_peek(pTHX_ SV *sv)
                Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
                               sv_uni_display(tmp, sv, 6 * SvCUR(sv),
                                              UNI_DISPLAY_QQ));
-           SvREFCNT_dec(tmp);
+           SvREFCNT_dec_NN(tmp);
        }
     }
     else if (SvNOKp(sv)) {
@@ -625,7 +625,7 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
        SV * const tmpsv = pm_description(pm);
        Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
-       SvREFCNT_dec(tmpsv);
+       SvREFCNT_dec_NN(tmpsv);
     }
 
     Perl_dump_indent(aTHX_ level-1, file, "}\n");
@@ -672,6 +672,8 @@ S_pm_description(pTHX_ const PMOP *pm)
             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
                 sv_catpv(desc, ",ALL");
         }
+        if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
+            sv_catpv(desc, ",SKIPWHITE");
     }
 
     append_flags(desc, pmflags, pmflags_flags_names);
@@ -779,7 +781,6 @@ const struct flag_to_name op_sassign_names[] = {
        {(flag), (name)} \
     }
 
-OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
@@ -790,6 +791,7 @@ OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
+OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
 
 struct op_private_by_op {
     U16 op_type;
@@ -802,7 +804,6 @@ const struct op_private_by_op op_private_names[] = {
     {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
     {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
     {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
-    {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
     {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
     {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
     {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
@@ -818,6 +819,7 @@ const struct op_private_by_op op_private_names[] = {
     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
+    {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
 };
 
@@ -866,7 +868,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
         else                                                            \
             PerlIO_printf(file, " flags=\"%s\"",                        \
                           SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");        \
-        SvREFCNT_dec(tmpsv);                                            \
+        SvREFCNT_dec_NN(tmpsv);                                            \
     }
 
 #if !defined(PERL_MAD)
@@ -941,6 +943,12 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
             if (oppriv & OPpFT_AFTER_t)                                 \
                 sv_catpv(tmpsv, ",AFTER_t");                            \
        }                                                               \
+       else if (o->op_type == OP_AASSIGN) {                            \
+           if (oppriv & OPpASSIGN_COMMON)                              \
+               sv_catpvs(tmpsv, ",COMMON");                            \
+           if (oppriv & OPpMAYBE_LVSUB)                                \
+               sv_catpvs(tmpsv, ",MAYBE_LVSUB");                       \
+       }                                                               \
        if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO)            \
            sv_catpv(tmpsv, ",INTRO");                                  \
        if (o->op_type == OP_PADRANGE)                                  \
@@ -954,7 +962,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
        } else if (!xml)                                                \
             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
                              (UV)oppriv);                               \
-       SvREFCNT_dec(tmpsv);                                            \
+       SvREFCNT_dec_NN(tmpsv);                                         \
     }
 
 
@@ -1047,7 +1055,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
        level--;
        Perl_dump_indent(aTHX_ level, file, "}\n");
 
-       SvREFCNT_dec(tmpsv);
+       SvREFCNT_dec_NN(tmpsv);
     }
 #endif
 
@@ -1282,7 +1290,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
                if (mg->mg_type != PERL_MAGIC_utf8) {
                    SV * const sv = newSVpvs("");
                    PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
-                   SvREFCNT_dec(sv);
+                   SvREFCNT_dec_NN(sv);
                }
             }
            else if (mg->mg_len == HEf_SVKEY) {
@@ -1445,7 +1453,7 @@ const struct flag_to_name regexp_flags_names[] = {
     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
-    {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
+    {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
     {RXf_CANY_SEEN,       "CANY_SEEN,"},
     {RXf_NOSCAN,          "NOSCAN,"},
@@ -1454,10 +1462,12 @@ const struct flag_to_name regexp_flags_names[] = {
     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
+    {RXf_SPLIT,           "SPLIT,"},
     {RXf_COPY_DONE,       "COPY_DONE,"},
     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
     {RXf_TAINTED,         "TAINTED,"},
     {RXf_START_ONLY,      "START_ONLY,"},
+    {RXf_SKIPWHITE,       "SKIPWHITE,"},
     {RXf_WHITE,           "WHITE,"},
     {RXf_NULL,            "NULL,"},
 };
@@ -1587,12 +1597,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
 
        if (type ==  SVt_NULL) {
-           SvREFCNT_dec(d);
+           SvREFCNT_dec_NN(d);
            return;
        }
     } else {
        PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
-       SvREFCNT_dec(d);
+       SvREFCNT_dec_NN(d);
        return;
     }
 
@@ -1646,11 +1656,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     }
 
     if (type < SVt_PV) {
-       SvREFCNT_dec(d);
+       SvREFCNT_dec_NN(d);
        return;
     }
 
-    if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
+    if ((type <= SVt_PVLV && !isGV_with_GP(sv))
+     || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
        const bool re = isREGEXP(sv);
        const char * const ptr =
            re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
@@ -1702,8 +1713,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
            do_hv_dump(level, file, "  STASH", SvSTASH(sv));
 
        if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
-           Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
-           Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
            Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
        }
     }
@@ -1795,10 +1804,42 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        }
        PerlIO_putc(file, '\n');
        Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
-       Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
+        {
+            STRLEN count = 0;
+            HE **ents = HvARRAY(sv);
+
+            if (ents) {
+                HE *const *const last = ents + HvMAX(sv);
+                count = last + 1 - ents;
+                
+                do {
+                    if (!*ents)
+                        --count;
+                } while (++ents <= last);
+            }
+
+            if (SvOOK(sv)) {
+                struct xpvhv_aux *const aux = HvAUX(sv);
+                Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
+                                 " (cached = %"UVuf")\n",
+                                 (UV)count, (UV)aux->xhv_fill_lazy);
+            } else {
+                Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
+                                 (UV)count);
+            }
+        }
        Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
-       Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
-       Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
+        if (SvOOK(sv)) {
+           Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
+           Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+           Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
+            if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
+                PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
+            }
+#endif
+            PerlIO_putc(file, '\n');
+        }
        {
            MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
            if (mg && mg->mg_obj) {
@@ -2079,15 +2120,23 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
       dumpregexp:
        {
            struct regexp * const r = ReANY((REGEXP*)sv);
-           flags = RX_EXTFLAGS((REGEXP*)sv);
-           sv_setpv(d,"");
-           append_flags(d, flags, regexp_flags_names);
-           if (*(SvEND(d) - 1) == ',') {
-               SvCUR_set(d, SvCUR(d) - 1);
-               SvPVX(d)[SvCUR(d)] = '\0';
-           }
+#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
+            sv_setpv(d,"");                                 \
+            append_flags(d, flags, regexp_flags_names);     \
+            if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
+                SvCUR_set(d, SvCUR(d) - 1);                 \
+                SvPVX(d)[SvCUR(d)] = '\0';                  \
+            }                                               \
+} STMT_END
+            SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
+            Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
+                                (UV)(r->compflags), SvPVX_const(d));
+
+            SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
            Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
-                               (UV)flags, SvPVX_const(d));
+                                (UV)(r->extflags), SvPVX_const(d));
+#undef SV_SET_STRINGIFY_REGEXP_FLAGS
+
            Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
                                (UV)(r->intflags));
            Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
@@ -2137,7 +2186,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        }
        break;
     }
-    SvREFCNT_dec(d);
+    SvREFCNT_dec_NN(d);
 }
 
 void
@@ -2164,6 +2213,9 @@ Perl_runops_debug(pTHX)
 
     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
     do {
+#ifdef PERL_TRACE_OPS
+        ++PL_op_exec_cnt[PL_op->op_type];
+#endif
        if (PL_debug) {
            if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
                PerlIO_printf(Perl_debug_log,
@@ -2187,6 +2239,7 @@ Perl_runops_debug(pTHX)
         OP_ENTRY_PROBE(OP_NAME(PL_op));
     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
+    PERL_ASYNC_CHECK();
 
     TAINT_NOT;
     return 0;
@@ -2226,7 +2279,7 @@ Perl_debop(pTHX_ const OP *o)
 #endif
            gv_fullname3(sv, cGVOPo_gv, NULL);
            PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
-           SvREFCNT_dec(sv);
+           SvREFCNT_dec_NN(sv);
        }
        else
            PerlIO_printf(Perl_debug_log, "(NULL)");
@@ -2635,7 +2688,7 @@ Perl_sv_xmlpeek(pTHX_ SV *sv)
        sv_catpv(t, "VOID=\"\"");
        goto finish;
     }
-    else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
+    else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
        sv_catpv(t, "WILD=\"\"");
        goto finish;
     }
@@ -2745,8 +2798,8 @@ Perl_sv_xmlpeek(pTHX_ SV *sv)
     case SVt_PVGV:
        sv_catpv(t, " GV=\"");
        break;
-    case SVt_BIND:
-       sv_catpv(t, " BIND=\"");
+    case SVt_DUMMY:
+       sv_catpv(t, " DUMMY=\"");
        break;
     case SVt_REGEXP:
        sv_catpv(t, " REGEXP=\"");
@@ -2802,7 +2855,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
        sv_catxmlsv(tmpsv, MUTABLE_SV(r));
        Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
             SvPVX(tmpsv));
-       SvREFCNT_dec(tmpsv);
+       SvREFCNT_dec_NN(tmpsv);
        Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
             (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
     }
@@ -2811,7 +2864,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
        SV * const tmpsv = pm_description(pm);
        Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
-       SvREFCNT_dec(tmpsv);
+       SvREFCNT_dec_NN(tmpsv);
     }
 
     level--;
@@ -3034,7 +3087,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
        level--;
        Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
 
-       SvREFCNT_dec(tmpsv);
+       SvREFCNT_dec_NN(tmpsv);
     }
 
     switch (optype) {