X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/126f53f392147cb95f8643714b33fe373747680a..9bb1f94743dcc3e9cf99470838be36cca2cfa0f6:/dump.c diff --git a/dump.c b/dump.c index 88adc9f..83ced6a 100644 --- a/dump.c +++ b/dump.c @@ -9,8 +9,10 @@ */ /* - * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and - * it has not been hard for me to read your mind and memory.'" + * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and + * it has not been hard for me to read your mind and memory.' + * + * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"] */ /* This file contains utility routines to dump the contents of SV and OP @@ -90,37 +92,51 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) void Perl_dump_all(pTHX) { + dump_all_perl(FALSE); +} + +void +Perl_dump_all_perl(pTHX_ bool justperl) +{ + dVAR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) op_dump(PL_main_root); - dump_packsubs(PL_defstash); + dump_packsubs_perl(PL_defstash, justperl); } void Perl_dump_packsubs(pTHX_ const HV *stash) { + PERL_ARGS_ASSERT_DUMP_PACKSUBS; + dump_packsubs_perl(stash, FALSE); +} + +void +Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) +{ dVAR; I32 i; - PERL_ARGS_ASSERT_DUMP_PACKSUBS; + PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - const GV * const gv = (GV*)HeVAL(entry); + const GV * const gv = (const GV *)HeVAL(entry); if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) continue; if (GvCVu(gv)) - dump_sub(gv); + dump_sub_perl(gv, justperl); if (GvFORM(gv)) dump_form(gv); if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { const HV * const hv = GvHV(gv); if (hv && (hv != PL_defstash)) - dump_packsubs(hv); /* nested package */ + dump_packsubs_perl(hv, justperl); /* nested package */ } } } @@ -129,10 +145,21 @@ Perl_dump_packsubs(pTHX_ const HV *stash) void Perl_dump_sub(pTHX_ const GV *gv) { - SV * const sv = sv_newmortal(); - PERL_ARGS_ASSERT_DUMP_SUB; + dump_sub_perl(gv, FALSE); +} +void +Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) +{ + SV * sv; + + PERL_ARGS_ASSERT_DUMP_SUB_PERL; + + if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) + return; + + sv = sv_newmortal(); gv_fullname3(sv, gv, NULL); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); if (CvISXSUB(GvCV(gv))) @@ -229,7 +256,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) { /* This won't alter the UTF-8 flag */ - sv_setpvn(dsv, "", 0); + sv_setpvs(dsv, ""); } if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) @@ -342,29 +369,29 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { /* This won't alter the UTF-8 flag */ - sv_setpvn(dsv, "", 0); + sv_setpvs(dsv, ""); } if ( dq == '"' ) - sv_catpvn(dsv, "\"", 1); + sv_catpvs(dsv, "\""); else if ( flags & PERL_PV_PRETTY_LTGT ) - sv_catpvn(dsv, "<", 1); + sv_catpvs(dsv, "<"); if ( start_color != NULL ) - Perl_sv_catpv( aTHX_ dsv, start_color); + sv_catpv(dsv, start_color); pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR ); if ( end_color != NULL ) - Perl_sv_catpv( aTHX_ dsv, end_color); + sv_catpv(dsv, end_color); if ( dq == '"' ) - sv_catpvn( dsv, "\"", 1 ); + sv_catpvs( dsv, "\""); else if ( flags & PERL_PV_PRETTY_LTGT ) - sv_catpvn( dsv, ">", 1); + sv_catpvs(dsv, ">"); if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) - sv_catpvn( dsv, "...", 3 ); + sv_catpvs(dsv, "..."); return SvPVX(dsv); } @@ -372,9 +399,6 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, /* =for apidoc pv_display - char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len, - STRLEN pvlim, U32 flags) - Similar to pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE); @@ -394,7 +418,7 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') - sv_catpvn( dsv, "\\0", 2 ); + sv_catpvs( dsv, "\\0"); return SvPVX(dsv); } @@ -406,13 +430,13 @@ Perl_sv_peek(pTHX_ SV *sv) int unref = 0; U32 type; - sv_setpvn(t, "", 0); + sv_setpvs(t, ""); retry: if (!sv) { sv_catpv(t, "VOID"); goto finish; } - else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') { + else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') { sv_catpv(t, "WILD"); goto finish; } @@ -483,7 +507,7 @@ Perl_sv_peek(pTHX_ SV *sv) sv_catpv(t, "..."); goto finish; } - sv = (SV*)SvRV(sv); + sv = SvRV(sv); goto retry; } type = SvTYPE(sv); @@ -506,8 +530,11 @@ Perl_sv_peek(pTHX_ SV *sv) else { SV * const tmp = newSVpvs(""); sv_catpv(t, "("); - if (SvOOK(sv)) - Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); + if (SvOOK(sv)) { + STRLEN delta; + SvOOK_offset(sv, delta); + Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); + } Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); if (SvUTF8(sv)) Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", @@ -533,6 +560,8 @@ Perl_sv_peek(pTHX_ SV *sv) finish: while (unref--) sv_catpv(t, ")"); + if (PL_tainting && SvTAINTED(sv)) + sv_catpv(t, " [tainted]"); return SvPV_nolen(t); } @@ -991,13 +1020,13 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) #ifdef PERL_MAD if (PL_madskills && o->op_madprop) { - SV * const tmpsv = newSVpvn("", 0); + SV * const tmpsv = newSVpvs(""); MADPROP* mp = o->op_madprop; Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n"); level++; while (mp) { const char tmp = mp->mad_key; - sv_setpvn(tmpsv,"'",1); + sv_setpvs(tmpsv,"'"); if (tmp) sv_catpvn(tmpsv, &tmp, 1); sv_catpv(tmpsv, "'="); @@ -1039,7 +1068,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) #ifdef USE_ITHREADS Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else - if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */ + if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */ if (cSVOPo->op_sv) { SV * const tmpsv = newSV(0); ENTER; @@ -1049,7 +1078,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) UTF-8 cleanliness of the dump file handle? */ SvUTF8_on(tmpsv); #endif - gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL); + gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL); Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV_nolen_const(tmpsv)); LEAVE; @@ -1257,6 +1286,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 else if (v == &PL_vtbl_utf8) s = "utf8"; else if (v == &PL_vtbl_arylen_p) s = "arylen_p"; else if (v == &PL_vtbl_hintselem) s = "hintselem"; + else if (v == &PL_vtbl_hints) s = "hints"; else s = NULL; if (s) Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); @@ -1331,11 +1361,17 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 } else if (mg->mg_len == HEf_SVKEY) { PerlIO_puts(file, " => HEf_SVKEY\n"); - do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ + do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, + maxnest, dumpops, pvlim); /* MG is already +1 */ continue; } + else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); else - PerlIO_puts(file, " ???? - please notify IZ"); + PerlIO_puts( + file, + " ???? - " __FILE__ + " does not know how to handle this MG_LEN" + ); PerlIO_putc(file, '\n'); } if (mg->mg_type == PERL_MAGIC_utf8) { @@ -1475,7 +1511,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,"); if (CvMETHOD(sv)) sv_catpv(d, "METHOD,"); - if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,"); if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,"); break; case SVt_PVHV: @@ -1490,7 +1525,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (isGV_with_GP(sv)) { if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); - if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,"); } @@ -1537,12 +1571,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo s = SvPVX_const(d); #ifdef DEBUG_LEAKING_SCALARS - Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n", + Perl_dump_indent(aTHX_ level, file, + "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n", sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", sv->sv_debug_line, sv->sv_debug_inpad ? "for" : "by", sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", - sv->sv_debug_cloned ? " (cloned)" : ""); + sv->sv_debug_cloned ? " (cloned)" : "", + sv->sv_debug_serial + ); #endif Perl_dump_indent(aTHX_ level, file, "SV = "); if (type < SVt_LAST) { @@ -1558,7 +1595,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo return; } if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM) + && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM + && type != SVt_PVIO) || (type == SVt_IV && !SvROK(sv))) { if (SvIsUV(sv) #ifdef PERL_OLD_COPY_ON_WRITE @@ -1659,15 +1697,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv)); Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv)); Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); - sv_setpvn(d, "", 0); + sv_setpvs(d, ""); if (AvREAL(sv)) sv_catpv(d, ",REAL"); if (AvREIFY(sv)) sv_catpv(d, ",REIFY"); Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", SvCUR(d) ? SvPVX_const(d) + 1 : ""); - if (nest < maxnest && av_len((AV*)sv) >= 0) { + if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) { int count; - for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) { - SV** const elt = av_fetch((AV*)sv,count,0); + for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) { + SV** const elt = av_fetch(MUTABLE_AV(sv),count,0); Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count); if (elt) @@ -1748,13 +1786,49 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); } if (SvOOK(sv)) { - const AV * const backrefs + AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); + struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; if (backrefs) { Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n", PTR2UV(backrefs)); - do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest, + do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, + dumpops, pvlim); + } + if (meta) { + /* FIXME - mro_algs kflags can signal a UTF-8 name. */ + Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n", + (int)meta->mro_which->length, + meta->mro_which->name, + PTR2UV(meta->mro_which)); + Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n", + (UV)meta->cache_gen); + Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n", + (UV)meta->pkg_gen); + if (meta->mro_linear_all) { + Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n", + PTR2UV(meta->mro_linear_all)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, dumpops, pvlim); + } + if (meta->mro_linear_current) { + Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n", + PTR2UV(meta->mro_linear_current)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->mro_nextmethod) { + Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n", + PTR2UV(meta->mro_nextmethod)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->isa) { + Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n", + PTR2UV(meta->isa)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, + dumpops, pvlim); + } } } if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ @@ -1843,7 +1917,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); } if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))) - do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim); + do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); break; case SVt_PVGV: case SVt_PVLV: @@ -1898,8 +1972,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo else { Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n", PTR2UV(IoTOP_GV(sv))); - do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest, - dumpops, pvlim); + do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, + maxnest, dumpops, pvlim); } /* Source filters hide things that are not GVs in these three, so let's be careful out there. */ @@ -1910,8 +1984,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo else { Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n", PTR2UV(IoFMT_GV(sv))); - do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest, - dumpops, pvlim); + do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, + maxnest, dumpops, pvlim); } if (IoBOTTOM_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); @@ -1920,8 +1994,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo else { Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n", PTR2UV(IoBOTTOM_GV(sv))); - do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest, - dumpops, pvlim); + do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, + maxnest, dumpops, pvlim); } if (isPRINT(IoTYPE(sv))) Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); @@ -1951,14 +2025,12 @@ Perl_runops_debug(pTHX) { dVAR; if (!PL_op) { - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); return 0; } DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); do { - PERL_ASYNC_CHECK(); if (PL_debug) { if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) PerlIO_printf(Perl_debug_log, @@ -2033,7 +2105,7 @@ Perl_debop(pTHX_ const OP *o) SV *sv; if (cv) { AV * const padlist = CvPADLIST(cv); - AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); + AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE)); sv = *av_fetch(comppad, o->op_targ, FALSE); } else sv = NULL; @@ -2150,9 +2222,16 @@ Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *ar void Perl_xmldump_all(pTHX) { + xmldump_all_perl(FALSE); +} + +void +Perl_xmldump_all_perl(pTHX_ bool justperl) +{ PerlIO_setlinebuf(PL_xmlfp); if (PL_main_root) op_xmldump(PL_main_root); + xmldump_packsubs_perl(PL_defstash, justperl); if (PL_xmlfp != (PerlIO*)PerlIO_stdout()) PerlIO_close(PL_xmlfp); PL_xmlfp = 0; @@ -2161,26 +2240,33 @@ Perl_xmldump_all(pTHX) void Perl_xmldump_packsubs(pTHX_ const HV *stash) { + PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS; + xmldump_packsubs_perl(stash, FALSE); +} + +void +Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl) +{ I32 i; HE *entry; - PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS; + PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - GV *gv = (GV*)HeVAL(entry); + GV *gv = MUTABLE_GV(HeVAL(entry)); HV *hv; if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) continue; if (GvCVu(gv)) - xmldump_sub(gv); + xmldump_sub_perl(gv, justperl); if (GvFORM(gv)) xmldump_form(gv); if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (hv = GvHV(gv)) && hv != PL_defstash) - xmldump_packsubs(hv); /* nested package */ + xmldump_packsubs_perl(hv, justperl); /* nested package */ } } } @@ -2188,10 +2274,21 @@ Perl_xmldump_packsubs(pTHX_ const HV *stash) void Perl_xmldump_sub(pTHX_ const GV *gv) { - SV * const sv = sv_newmortal(); - PERL_ARGS_ASSERT_XMLDUMP_SUB; + xmldump_sub_perl(gv, FALSE); +} + +void +Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl) +{ + SV * sv; + + PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL; + + if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) + return; + sv = sv_newmortal(); gv_fullname3(sv, gv, NULL); Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv)); if (CvXSUB(GvCV(gv))) @@ -2243,7 +2340,7 @@ Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) PERL_ARGS_ASSERT_SV_CATXMLPVN; - sv_catpvn(dsv,"",0); + sv_catpvs(dsv,""); dsvcur = SvCUR(dsv); /* in case we have to restart */ retry: @@ -2369,13 +2466,13 @@ Perl_sv_xmlpeek(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_XMLPEEK; sv_utf8_upgrade(t); - sv_setpvn(t, "", 0); + sv_setpvs(t, ""); /* retry: */ if (!sv) { sv_catpv(t, "VOID=\"\""); goto finish; } - else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') { + else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') { sv_catpv(t, "WILD=\"\""); goto finish; } @@ -2539,7 +2636,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) if (PM_GETRE(pm)) { REGEXP *const r = PM_GETRE(pm); SV * const tmpsv = newSVpvn_utf8("", 0, TRUE); - sv_catxmlsv(tmpsv, (SV*)r); + sv_catxmlsv(tmpsv, MUTABLE_SV(r)); Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n", SvPVX(tmpsv)); SvREFCNT_dec(tmpsv); @@ -2619,7 +2716,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next); #endif if (o->op_flags) { - SV * const tmpsv = newSVpvn("", 0); + SV * const tmpsv = newSVpvs(""); switch (o->op_flags & OPf_WANT) { case OPf_WANT_VOID: sv_catpv(tmpsv, ",VOID"); @@ -2650,7 +2747,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) SvREFCNT_dec(tmpsv); } if (o->op_private) { - SV * const tmpsv = newSVpvn("", 0); + SV * const tmpsv = newSVpvs(""); if (PL_opargs[o->op_type] & OA_TARGLEX) { if (o->op_private & OPpTARGET_MY) sv_catpv(tmpsv, ",TARGET_MY"); @@ -2834,7 +2931,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) ENTER; SAVEFREESV(tmpsv1); SAVEFREESV(tmpsv2); - gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL); + gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL); s = SvPV(tmpsv1,len); sv_catxmlpvn(tmpsv2, s, len, 1); S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len)); @@ -2927,7 +3024,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) level++; while (mp) { char tmp = mp->mad_key; - sv_setpvn(tmpsv,"\"",1); + sv_setpvs(tmpsv,"\""); if (tmp) sv_catxmlpvn(tmpsv, &tmp, 1, 0); if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */ @@ -2948,7 +3045,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) break; case MAD_SV: sv_catpv(tmpsv, " val=\""); - sv_catxmlsv(tmpsv, (SV*)mp->mad_val); + sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val)); sv_catpv(tmpsv, "\""); Perl_xmldump_indent(aTHX_ level, file, "\n", SvPVX(tmpsv)); break;