X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=70efde4090547a2269631b7fd5208f09c1edd6fd;hb=fa58a56f3cdf71021d7d7a49e98845f57652a3fe;hp=06135731b1d3aa633bd5f445e93259ad6954733b;hpb=5129b2ca8d01c31a5ccad56604afff370ba7562e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/dump.c b/dump.c index 0613573..70efde4 100644 --- a/dump.c +++ b/dump.c @@ -1,7 +1,7 @@ /* dump.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -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))) @@ -169,9 +196,7 @@ Perl_dump_eval(pTHX) /* -=for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\ - |const STRLEN count|const STRLEN max - |STRLEN const *escaped, const U32 flags +=for apidoc pv_escape Escapes at most the first "count" chars of pv and puts the results into dsv such that the size of the escaped string will not exceed "max" chars @@ -231,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)) @@ -308,10 +333,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, return SvPVX(dsv); } /* -=for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\ - |const STRLEN count|const STRLEN max\ - |const char const *start_color| const char const *end_color\ - |const U32 flags +=for apidoc pv_pretty Converts a string into something presentable, handling escaping via pv_escape() and supporting quoting and ellipses. @@ -347,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); } @@ -377,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); @@ -399,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); } @@ -411,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; } @@ -488,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); @@ -511,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\"]", @@ -538,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); } @@ -996,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, "'="); @@ -1044,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; @@ -1054,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; @@ -1262,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); @@ -1336,7 +1361,8 @@ 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 @@ -1480,7 +1506,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: @@ -1495,7 +1520,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,"); } @@ -1664,15 +1688,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) @@ -1753,17 +1777,54 @@ 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 = *Perl_hv_backreferences_p(aTHX_ (HV*)sv); + 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 */ HE *he; - HV * const hv = (HV*)sv; + HV * const hv = MUTABLE_HV(sv); int count = maxnest - nest; hv_iterinit(hv); @@ -1809,7 +1870,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo do_op_dump(level+1, file, CvROOT(sv)); } } else { - SV * const constant = cv_const_sv((CV *)sv); + SV * const constant = cv_const_sv((const CV *)sv); Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv))); @@ -1847,7 +1908,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: @@ -1902,8 +1963,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. */ @@ -1914,8 +1975,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)); @@ -1924,8 +1985,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)); @@ -1955,8 +2016,7 @@ 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; } @@ -2037,7 +2097,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; @@ -2154,9 +2214,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; @@ -2165,26 +2232,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 */ } } } @@ -2192,10 +2266,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))) @@ -2247,7 +2332,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: @@ -2373,13 +2458,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; } @@ -2543,7 +2628,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); @@ -2623,7 +2708,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"); @@ -2654,7 +2739,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"); @@ -2838,7 +2923,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)); @@ -2931,7 +3016,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. */ @@ -2952,7 +3037,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;