X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/59b714e260d430f6d20c1573b9cd0f5fe0955ad8..b24379876fe7e174792c61c877962fe23c802eb8:/dump.c diff --git a/dump.c b/dump.c index 724baf8..54999ad 100644 --- a/dump.c +++ b/dump.c @@ -92,20 +92,34 @@ 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; @@ -116,13 +130,13 @@ Perl_dump_packsubs(pTHX_ const HV *stash) 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 */ } } } @@ -131,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))) @@ -505,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\"]", @@ -1040,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; @@ -1258,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); @@ -1477,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: @@ -1492,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,"); } @@ -1560,7 +1587,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 @@ -1752,12 +1780,48 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (SvOOK(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, 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; @@ -1953,8 +2017,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; } @@ -2152,9 +2215,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; @@ -2163,10 +2233,17 @@ 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; @@ -2177,12 +2254,12 @@ Perl_xmldump_packsubs(pTHX_ const HV *stash) 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 */ } } } @@ -2190,10 +2267,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)))