X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bf1c7d4ad82bf8cd8059466e31fadb0318adffe3..8586647e338e8eb42c00fe6f687105c9b8a36d44:/dump.c diff --git a/dump.c b/dump.c index 54a4fb5..a2c0bbc 100644 --- a/dump.c +++ b/dump.c @@ -369,7 +369,9 @@ Perl_sv_peek(pTHX_ SV *sv) sv_catpv(t, "WILD"); goto finish; } - else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { + else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes + || sv == &PL_sv_zero || sv == &PL_sv_placeholder) + { if (sv == &PL_sv_undef) { sv_catpv(t, "SV_UNDEF"); if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| @@ -398,6 +400,17 @@ Perl_sv_peek(pTHX_ SV *sv) SvNVX(sv) == 1.0) goto finish; } + else if (sv == &PL_sv_zero) { + sv_catpv(t, "SV_ZERO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX_const(sv) && *SvPVX_const(sv) == '0' && + SvNVX(sv) == 0.0) + goto finish; + } else { sv_catpv(t, "SV_PLACEHOLDER"); if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| @@ -565,7 +578,10 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, /* output preceding blank line */ PerlIO_puts(file, " "); for (i = level-1; i >= 0; i--) - PerlIO_puts(file, i == 0 || (bar & (1 << i)) ? "| " : " "); + PerlIO_puts(file, ( i == 0 + || (i < UVSIZE*8 && (bar & ((UV)1 << i))) + ) + ? "| " : " "); PerlIO_puts(file, "\n"); /* output sequence number */ @@ -684,27 +700,33 @@ Perl_dump_sub(pTHX_ const GV *gv) void Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) { - STRLEN len; - SV * const sv = newSVpvs_flags("", SVs_TEMP); - SV *tmpsv; - const char * name; + CV *cv; PERL_ARGS_ASSERT_DUMP_SUB_PERL; - if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) + cv = isGV_with_GP(gv) ? GvCV(gv) : + (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); + if (justperl && (CvISXSUB(cv) || !CvROOT(cv))) return; - tmpsv = newSVpvs_flags("", SVs_TEMP); - gv_fullname3(sv, gv, NULL); - name = SvPV_const(sv, len); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", - generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); - if (CvISXSUB(GvCV(gv))) + if (isGV_with_GP(gv)) { + SV * const namesv = newSVpvs_flags("", SVs_TEMP); + SV *escsv = newSVpvs_flags("", SVs_TEMP); + const char *namepv; + STRLEN namelen; + gv_fullname3(namesv, gv, NULL); + namepv = SvPV_const(namesv, namelen); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", + generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); + } else { + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); + } + if (CvISXSUB(cv)) Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", - PTR2UV(CvXSUB(GvCV(gv))), - (int)CvXSUBANY(GvCV(gv)).any_i32); - else if (CvROOT(GvCV(gv))) - op_dump(CvROOT(GvCV(gv))); + PTR2UV(CvXSUB(cv)), + (int)CvXSUBANY(cv).any_i32); + else if (CvROOT(cv)) + op_dump(CvROOT(cv)); else Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\n"); } @@ -731,6 +753,37 @@ Perl_dump_eval(pTHX) } +/* returns a temp SV displaying the name of a GV. Handles the case where + * a GV is in fact a ref to a CV */ + +static SV * +S_gv_display(pTHX_ GV *gv) +{ + SV * const name = newSVpvs_flags("", SVs_TEMP); + if (gv) { + SV * const raw = newSVpvs_flags("", SVs_TEMP); + STRLEN len; + const char * rawpv; + + if (isGV_with_GP(gv)) + gv_fullname3(raw, gv, NULL); + else { + assert(SvROK(gv)); + assert(SvTYPE(SvRV(gv)) == SVt_PVCV); + Perl_sv_catpvf(aTHX_ raw, "cv ref: %s", + SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0))); + } + rawpv = SvPV_const(raw, len); + generic_pv_escape(name, rawpv, len, SvUTF8(raw)); + } + else + sv_catpvs(name, "(NULL)"); + + return name; +} + + + /* forward decl */ static void S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o); @@ -739,7 +792,6 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o); static void S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) { - char ch; UV kidbar; if (!pm) @@ -747,14 +799,11 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1; - if (pm->op_pmflags & PMf_ONCE) - ch = '?'; - else - ch = '/'; - - if (PM_GETRE(pm)) + if (PM_GETRE(pm)) { + char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/'; S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); + } else S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); @@ -897,7 +946,7 @@ const struct flag_to_name op_flags_names[] = { /* indexed by enum OPclass */ -const char * op_class_names[] = { +const char * const op_class_names[] = { "NULL", "OP", "UNOP", @@ -1073,19 +1122,9 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) S_opdump_indent(aTHX_ o, level, bar, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else - if (cSVOPo->op_sv) { - STRLEN len; - const char * name; - SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); - SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP); - - gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL); - name = SvPV_const(tmpsv, len); - S_opdump_indent(aTHX_ o, level, bar, file, "GV = %s\n", - generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv))); - } - else - S_opdump_indent(aTHX_ o, level, bar, file, "GV = NULL\n"); + S_opdump_indent(aTHX_ o, level, bar, file, + "GV = %" SVf " (0x%" UVxf ")\n", + SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv)); #endif break; @@ -1196,6 +1235,31 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) S_opdump_indent(aTHX_ o, level, bar, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ); break; + + case OP_DUMP: + case OP_GOTO: + case OP_NEXT: + case OP_LAST: + case OP_REDO: + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; + { + SV * const label = newSVpvs_flags("", SVs_TEMP); + generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0); + S_opdump_indent(aTHX_ o, level, bar, file, + "PV = \"%" SVf "\" (0x%" UVxf ")\n", + SVfARG(label), PTR2UV(cPVOPo->op_pv)); + break; + } + + case OP_TRANS: + case OP_TRANSR: + S_opdump_indent(aTHX_ o, level, bar, file, + "PV = 0x%" UVxf "\n", + PTR2UV(cPVOPo->op_pv)); + break; + + default: break; } @@ -1775,7 +1839,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, "\n"); } Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); - if (!re) + if (re && type == SVt_PVLV) + /* LV-as-REGEXP usurps len field to store pointer to + * regexp struct */ + Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", + PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx)); + else Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", (IV)SvLEN(sv)); #ifdef PERL_COPY_ON_WRITE @@ -1845,7 +1914,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (UV)aux->xhv_aux_flags); } Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); - usedkeys = HvUSEDKEYS(sv); + usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); if (HvARRAY(sv) && usedkeys) { /* Show distribution of HEs in the ARRAY */ int freq[200]; @@ -2356,9 +2425,7 @@ For an example of its output, see L. void Perl_sv_dump(pTHX_ SV *sv) { - PERL_ARGS_ASSERT_SV_DUMP; - - if (SvROK(sv)) + if (sv && SvROK(sv)) do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); else do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); @@ -2367,16 +2434,30 @@ Perl_sv_dump(pTHX_ SV *sv) int Perl_runops_debug(pTHX) { +#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY + SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm; + + PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; +#endif + if (!PL_op) { 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 { #ifdef PERL_TRACE_OPS ++PL_op_exec_cnt[PL_op->op_type]; #endif +#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY + if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base) + Perl_croak_nocontext( + "panic: previous op failed to extend arg stack: " + "base=%p, sp=%p, hwm=%p\n", + PL_stack_base, PL_stack_sp, + PL_stack_base + PL_curstackinfo->si_stack_hwm); + PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; +#endif if (PL_debug) { ENTER; SAVETMPS; @@ -2406,6 +2487,10 @@ Perl_runops_debug(pTHX) DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); PERL_ASYNC_CHECK(); +#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY + if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm) + PL_curstackinfo->si_stack_hwm = orig_stack_hwm; +#endif TAINT_NOT; return 0; } @@ -2666,22 +2751,8 @@ Perl_debop(pTHX_ const OP *o) break; case OP_GVSV: case OP_GV: - if (cGVOPo_gv && isGV(cGVOPo_gv)) { - SV * const sv = newSV(0); - gv_fullname3(sv, cGVOPo_gv, NULL); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); - SvREFCNT_dec_NN(sv); - } - else if (cGVOPo_gv) { - SV * const sv = newSV(0); - assert(SvROK(cGVOPo_gv)); - assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV); - PerlIO_printf(Perl_debug_log, "(cv ref: %s)", - SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0))); - SvREFCNT_dec_NN(sv); - } - else - PerlIO_printf(Perl_debug_log, "(NULL)"); + PerlIO_printf(Perl_debug_log, "(%" SVf ")", + SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); break; case OP_PADSV: