X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/58430ea8e40621565404595aac210ff61babed01..97eac949b0a5801c6ea6dfa29f54d0e6ecbb7137:/dump.c?ds=sidebyside diff --git a/dump.c b/dump.c index eb050b3..c848dcd 100644 --- a/dump.c +++ b/dump.c @@ -20,6 +20,8 @@ * by Devel::Peek. * * It also holds the debugging version of the runops function. + +=head1 Display and Dump functions */ #include "EXTERN.h" @@ -181,7 +183,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, chsize = 2; switch (c) { - case '\\' : /* fallthrough */ + case '\\' : /* FALLTHROUGH */ case '%' : if ( c == esc ) { octbuf[1] = esc; } else { @@ -471,7 +473,7 @@ Perl_sv_peek(pTHX_ SV *sv) finish: while (unref--) sv_catpv(t, ")"); - if (TAINTING_get && SvTAINTED(sv)) + if (TAINTING_get && sv && SvTAINTED(sv)) sv_catpv(t, " [tainted]"); return SvPV_nolen(t); } @@ -493,7 +495,6 @@ Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) { - dVAR; PERL_ARGS_ASSERT_DUMP_VINDENT; PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); @@ -518,8 +519,6 @@ Perl_dump_all(pTHX) void Perl_dump_all_perl(pTHX_ bool justperl) { - - dVAR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) op_dump(PL_main_root); @@ -544,7 +543,6 @@ Perl_dump_packsubs(pTHX_ const HV *stash) void Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) { - dVAR; I32 i; PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; @@ -623,7 +621,6 @@ Perl_dump_form(pTHX_ const GV *gv) void Perl_dump_eval(pTHX) { - dVAR; op_dump(PL_eval_root); } @@ -754,6 +751,10 @@ S_sequence_num(pTHX_ const OP *o) return PL_op_seq; } + + + + const struct flag_to_name op_flags_names[] = { {OPf_KIDS, ",KIDS"}, {OPf_PARENS, ",PARENS"}, @@ -763,259 +764,10 @@ const struct flag_to_name op_flags_names[] = { {OPf_SPECIAL, ",SPECIAL"} }; -const struct flag_to_name op_trans_names[] = { - {OPpTRANS_FROM_UTF, ",FROM_UTF"}, - {OPpTRANS_TO_UTF, ",TO_UTF"}, - {OPpTRANS_IDENTICAL, ",IDENTICAL"}, - {OPpTRANS_SQUASH, ",SQUASH"}, - {OPpTRANS_COMPLEMENT, ",COMPLEMENT"}, - {OPpTRANS_GROWS, ",GROWS"}, - {OPpTRANS_DELETE, ",DELETE"} -}; - -const struct flag_to_name op_entersub_names[] = { - {OPpENTERSUB_DB, ",DB"}, - {OPpENTERSUB_HASTARG, ",HASTARG"}, - {OPpENTERSUB_AMPER, ",AMPER"}, - {OPpENTERSUB_NOPAREN, ",NOPAREN"}, - {OPpENTERSUB_INARGS, ",INARGS"} -}; - -const struct flag_to_name op_const_names[] = { - {OPpCONST_NOVER, ",NOVER"}, - {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"}, - {OPpCONST_STRICT, ",STRICT"}, - {OPpCONST_ENTERED, ",ENTERED"}, - {OPpCONST_BARE, ",BARE"} -}; - -const struct flag_to_name op_sort_names[] = { - {OPpSORT_NUMERIC, ",NUMERIC"}, - {OPpSORT_INTEGER, ",INTEGER"}, - {OPpSORT_REVERSE, ",REVERSE"}, - {OPpSORT_INPLACE, ",INPLACE"}, - {OPpSORT_DESCEND, ",DESCEND"}, - {OPpSORT_QSORT, ",QSORT"}, - {OPpSORT_STABLE, ",STABLE"} -}; - -const struct flag_to_name op_open_names[] = { - {OPpOPEN_IN_RAW, ",IN_RAW"}, - {OPpOPEN_IN_CRLF, ",IN_CRLF"}, - {OPpOPEN_OUT_RAW, ",OUT_RAW"}, - {OPpOPEN_OUT_CRLF, ",OUT_CRLF"} -}; - -const struct flag_to_name op_sassign_names[] = { - {OPpASSIGN_BACKWARDS, ",BACKWARDS"}, - {OPpASSIGN_CV_TO_GV, ",CV2GV"} -}; - -const struct flag_to_name op_leave_names[] = { - {OPpREFCOUNTED, ",REFCOUNTED"}, - {OPpLVALUE, ",LVALUE"} -}; - -#define OP_PRIVATE_ONCE(op, flag, name) \ - const struct flag_to_name CAT2(op, _names)[] = { \ - {(flag), (name)} \ - } - -OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED"); -OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST"); -OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE"); -OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO"); -OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM"); -OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV"); -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"); -OP_PRIVATE_ONCE(op_dbstate, OPpHUSH_VMSISH, ",HUSH_VMSISH"); - -struct op_private_by_op { - U16 op_type; - U16 len; - const struct flag_to_name *start; -}; - -const struct op_private_by_op op_private_names[] = { - {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, - {OP_LEAVE, C_ARRAY_LENGTH(op_leave_names), op_leave_names }, - {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, - {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_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 }, - {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names }, - {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names }, - {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names }, - {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names }, - {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names }, - {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names }, - {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names }, - {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_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_DBSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names }, - {OP_NEXTSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names }, - {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names } -}; - -static bool -S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { - const struct op_private_by_op *start = op_private_names; - const struct op_private_by_op *const end - = op_private_names + C_ARRAY_LENGTH(op_private_names); - - /* This is a linear search, but no worse than the code that it replaced. - It's debugging code - size is more important than speed. */ - do { - if (optype == start->op_type) { - S_append_flags(aTHX_ tmpsv, op_private, start->start, - start->start + start->len); - return TRUE; - } - } while (++start < end); - return FALSE; -} - -#define DUMP_OP_FLAGS(o,xml,level,file) \ - if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \ - SV * const tmpsv = newSVpvs(""); \ - switch (o->op_flags & OPf_WANT) { \ - case OPf_WANT_VOID: \ - sv_catpv(tmpsv, ",VOID"); \ - break; \ - case OPf_WANT_SCALAR: \ - sv_catpv(tmpsv, ",SCALAR"); \ - break; \ - case OPf_WANT_LIST: \ - sv_catpv(tmpsv, ",LIST"); \ - break; \ - default: \ - sv_catpv(tmpsv, ",UNKNOWN"); \ - break; \ - } \ - append_flags(tmpsv, o->op_flags, op_flags_names); \ - if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \ - if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \ - if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \ - if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \ - if (!xml) \ - Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \ - SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\ - else \ - PerlIO_printf(file, " flags=\"%s\"", \ - SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \ - } - -#if !defined(PERL_MAD) -# define xmldump_attr1(level, file, pat, arg) -#else -# define xmldump_attr1(level, file, pat, arg) \ - S_xmldump_attr(aTHX_ level, file, pat, arg) -#endif - -#define DUMP_OP_PRIVATE(o,xml,level,file) \ - if (o->op_private) { \ - U32 optype = o->op_type; \ - U32 oppriv = o->op_private; \ - SV * const tmpsv = newSVpvs(""); \ - if (PL_opargs[optype] & OA_TARGLEX) { \ - if (oppriv & OPpTARGET_MY) \ - sv_catpv(tmpsv, ",TARGET_MY"); \ - } \ - else if (optype == OP_ENTERSUB || \ - optype == OP_RV2SV || \ - optype == OP_GVSV || \ - optype == OP_RV2AV || \ - optype == OP_RV2HV || \ - optype == OP_RV2GV || \ - optype == OP_AELEM || \ - optype == OP_HELEM ) \ - { \ - if (optype == OP_ENTERSUB) { \ - append_flags(tmpsv, oppriv, op_entersub_names); \ - } \ - else { \ - switch (oppriv & OPpDEREF) { \ - case OPpDEREF_SV: \ - sv_catpv(tmpsv, ",SV"); \ - break; \ - case OPpDEREF_AV: \ - sv_catpv(tmpsv, ",AV"); \ - break; \ - case OPpDEREF_HV: \ - sv_catpv(tmpsv, ",HV"); \ - break; \ - } \ - if (oppriv & OPpMAYBE_LVSUB) \ - sv_catpv(tmpsv, ",MAYBE_LVSUB"); \ - } \ - if (optype == OP_AELEM || optype == OP_HELEM) { \ - if (oppriv & OPpLVAL_DEFER) \ - sv_catpv(tmpsv, ",LVAL_DEFER"); \ - } \ - else if (optype == OP_RV2HV || optype == OP_PADHV) { \ - if (oppriv & OPpMAYBE_TRUEBOOL) \ - sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \ - if (oppriv & OPpTRUEBOOL) \ - sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \ - } \ - else { \ - if (oppriv & HINT_STRICT_REFS) \ - sv_catpv(tmpsv, ",STRICT_REFS"); \ - if (oppriv & OPpOUR_INTRO) \ - sv_catpv(tmpsv, ",OUR_INTRO"); \ - } \ - } \ - else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \ - } \ - else if (OP_IS_FILETEST(o->op_type)) { \ - if (oppriv & OPpFT_ACCESS) \ - sv_catpv(tmpsv, ",FT_ACCESS"); \ - if (oppriv & OPpFT_STACKED) \ - sv_catpv(tmpsv, ",FT_STACKED"); \ - if (oppriv & OPpFT_STACKING) \ - sv_catpv(tmpsv, ",FT_STACKING"); \ - 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) \ - Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \ - (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \ - if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \ - o->op_type == OP_PADAV || o->op_type == OP_PADHV || \ - o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \ - && oppriv & OPpSLICEWARNING ) \ - sv_catpvs(tmpsv, ",SLICEWARNING"); \ - if (SvCUR(tmpsv)) { \ - if (xml) \ - xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \ - else \ - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \ - } else if (!xml) \ - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \ - (UV)oppriv); \ - } - void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) { - dVAR; UV seq; const OPCODE optype = o->op_type; @@ -1072,49 +824,114 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); #endif - DUMP_OP_FLAGS(o,0,level,file); - DUMP_OP_PRIVATE(o,0,level,file); - -#ifdef PERL_MAD - if (PL_madskills && o->op_madprop) { - 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_setpvs(tmpsv,"'"); - if (tmp) - sv_catpvn(tmpsv, &tmp, 1); - sv_catpv(tmpsv, "'="); - switch (mp->mad_type) { - case MAD_NULL: - sv_catpv(tmpsv, "NULL"); - Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); - break; - case MAD_PV: - sv_catpv(tmpsv, "<"); - sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen); - sv_catpv(tmpsv, ">"); - Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); - break; - case MAD_OP: - if ((OP*)mp->mad_val) { - Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); - do_op_dump(level, file, (OP*)mp->mad_val); - } - break; - default: - sv_catpv(tmpsv, "(UNK)"); - Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); - break; - } - mp = mp->mad_next; - } - level--; - Perl_dump_indent(aTHX_ level, file, "}\n"); + if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { + SV * const tmpsv = newSVpvs(""); + switch (o->op_flags & OPf_WANT) { + case OPf_WANT_VOID: + sv_catpv(tmpsv, ",VOID"); + break; + case OPf_WANT_SCALAR: + sv_catpv(tmpsv, ",SCALAR"); + break; + case OPf_WANT_LIST: + sv_catpv(tmpsv, ",LIST"); + break; + default: + sv_catpv(tmpsv, ",UNKNOWN"); + break; + } + append_flags(tmpsv, o->op_flags, op_flags_names); + if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); + if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); + if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); + if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); + if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB"); + Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", + SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); + } + + if (o->op_private) { + U16 oppriv = o->op_private; + I16 op_ix = PL_op_private_bitdef_ix[o->op_type]; + SV * tmpsv = NULL; + + if (op_ix != -1) { + U16 stop = 0; + tmpsv = newSVpvs(""); + for (; !stop; op_ix++) { + U16 entry = PL_op_private_bitdefs[op_ix]; + U16 bit = (entry >> 2) & 7; + U16 ix = entry >> 5; + + stop = (entry & 1); + + if (entry & 2) { + /* bitfield */ + I16 const *p = &PL_op_private_bitfields[ix]; + U16 bitmin = (U16) *p++; + I16 label = *p++; + I16 enum_label; + U16 mask = 0; + U16 i; + U16 val; + + for (i = bitmin; i<= bit; i++) + mask |= (1<>= bit; + enum_label = -1; + while (*p != -1) { + if (val == *p++) { + enum_label = *p; + break; + } + p++; + } + if (val == 0 && enum_label == -1) + /* don't display anonymous zero values */ + continue; + + sv_catpv(tmpsv, ","); + if (label != -1) { + sv_catpv(tmpsv, &PL_op_private_labels[label]); + sv_catpv(tmpsv, "="); + } + sv_catpv(tmpsv, &PL_op_private_labels[enum_label]); + + } + else { + /* bit flag */ + if ( oppriv & (1<op_sv), NULL); name = SvPV_const(tmpsv, len); Perl_dump_indent(aTHX_ level, file, "GV = %s\n", @@ -1227,7 +1039,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) } if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) do_op_dump(level, file, kid); } Perl_dump_indent(aTHX_ level-1, file, "}\n"); @@ -1516,8 +1328,10 @@ const struct flag_to_name cv_flags_names[] = { {CVf_CVGV_RC, "CVGV_RC,"}, {CVf_DYNFILE, "DYNFILE,"}, {CVf_AUTOLOAD, "AUTOLOAD,"}, - {CVf_HASEVAL, "HASEVAL"}, + {CVf_HASEVAL, "HASEVAL,"}, {CVf_SLABBED, "SLABBED,"}, + {CVf_NAMED, "NAMED,"}, + {CVf_LEXICAL, "LEXICAL,"}, {CVf_ISXSUB, "ISXSUB,"} }; @@ -1532,7 +1346,6 @@ const struct flag_to_name gp_flags_names[] = { {GVf_INTRO, "INTRO,"}, {GVf_MULTI, "MULTI,"}, {GVf_ASSUMECV, "ASSUMECV,"}, - {GVf_IN_PAD, "IN_PAD,"} }; const struct flag_to_name gp_flags_imported_names[] = { @@ -1551,10 +1364,7 @@ const struct flag_to_name regexp_extflags_names[] = { {RXf_PMf_FOLD, "PMf_FOLD,"}, {RXf_PMf_EXTENDED, "PMf_EXTENDED,"}, {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"}, - {RXf_ANCH_BOL, "ANCH_BOL,"}, - {RXf_ANCH_MBOL, "ANCH_MBOL,"}, - {RXf_ANCH_SBOL, "ANCH_SBOL,"}, - {RXf_ANCH_GPOS, "ANCH_GPOS,"}, + {RXf_IS_ANCHORED, "IS_ANCHORED,"}, {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"}, {RXf_EVAL_SEEN, "EVAL_SEEN,"}, {RXf_CHECK_ALL, "CHECK_ALL,"}, @@ -1586,12 +1396,14 @@ const struct flag_to_name regexp_core_intflags_names[] = { {PREGf_CANY_SEEN, "CANY_SEEN,"}, {PREGf_GPOS_SEEN, "GPOS_SEEN,"}, {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"}, + {PREGf_ANCH_MBOL, "ANCH_MBOL,"}, + {PREGf_ANCH_SBOL, "ANCH_SBOL,"}, + {PREGf_ANCH_GPOS, "ANCH_GPOS,"}, }; void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { - dVAR; SV *d; const char *s; U32 flags; @@ -1664,7 +1476,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo sv_catpv(d, " ),"); } } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: evaled_or_uv: if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); @@ -1675,7 +1487,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (SvVALID(sv)) sv_catpv(d, "VALID,"); if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,"); if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,"); - /* FALL THROUGH */ + /* FALLTHROUGH */ case SVt_PVNV: if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,"); goto evaled_or_uv; @@ -1758,12 +1570,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) || type == SVt_NV) { STORE_NUMERIC_LOCAL_SET_STANDARD(); - /* %Vg doesn't work? --jhi */ -#ifdef USE_LONG_DOUBLE - Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv)); -#else - Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); -#endif + Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); } @@ -1870,9 +1677,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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(MUTABLE_AV(sv)) >= 0) { + if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) { SSize_t count; - for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) { + for (count = 0; count <= av_tindex(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); @@ -1881,15 +1688,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } } break; - case SVt_PVHV: + case SVt_PVHV: { + U32 usedkeys; + if (SvOOK(sv)) { + struct xpvhv_aux *const aux = HvAUX(sv); + Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n", + (UV)aux->xhv_aux_flags); + } Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv))); - if (HvARRAY(sv) && HvUSEDKEYS(sv)) { + usedkeys = HvUSEDKEYS(sv); + if (HvARRAY(sv) && usedkeys) { /* Show distribution of HEs in the ARRAY */ int freq[200]; -#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1)) +#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1)) int i; int max = 0; - U32 pow2 = 2, keys = HvUSEDKEYS(sv); + U32 pow2 = 2, keys = usedkeys; NV theoret, sum = 0; PerlIO_printf(file, " ("); @@ -1931,13 +1745,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } while ((keys = keys >> 1)) pow2 = pow2 << 1; - theoret = HvUSEDKEYS(sv); + theoret = usedkeys; theoret += theoret * (theoret-1)/pow2; PerlIO_putc(file, '\n'); Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100); } PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv)); + Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys); { STRLEN count = 0; HE **ents = HvARRAY(sv); @@ -2110,6 +1924,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } } break; + } /* case SVt_PVHV */ case SVt_PVCV: if (CvAUTOLOAD(sv)) { @@ -2126,7 +1941,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), SvUTF8(sv))); } - /* FALL THROUGH */ + /* FALLTHROUGH */ case SVt_PVFM: do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); if (!CvISXSUB(sv)) { @@ -2197,7 +2012,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv)); Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv))); Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv)); - if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T') + if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim); } @@ -2213,6 +2028,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv)); do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv))); if (!GvGP(sv)) break; @@ -2224,9 +2040,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv))); Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv))); Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv)); + Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf + " (%s)\n", + (UV)GvGPFLAGS(sv), + GvALIASED_SV(sv) ? "ALIASED_SV" : ""); Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv)); Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); do_gv_dump (level, file, " EGV", GvEGV(sv)); break; case SVt_PVIO: @@ -2371,8 +2190,6 @@ For an example of its output, see L. void Perl_sv_dump(pTHX_ SV *sv) { - dVAR; - PERL_ARGS_ASSERT_SV_DUMP; if (SvROK(sv)) @@ -2384,7 +2201,6 @@ Perl_sv_dump(pTHX_ SV *sv) int Perl_runops_debug(pTHX) { - dVAR; if (!PL_op) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); return 0; @@ -2427,7 +2243,7 @@ Perl_runops_debug(pTHX) I32 Perl_debop(pTHX_ const OP *o) { - dVAR; + int count; PERL_ARGS_ASSERT_DEBOP; @@ -2449,24 +2265,24 @@ Perl_debop(pTHX_ const OP *o) break; case OP_GVSV: case OP_GV: - if (cGVOPo_gv) { + if (cGVOPo_gv && isGV(cGVOPo_gv)) { SV * const sv = newSV(0); -#ifdef PERL_MAD - /* FIXME - is this making unwarranted assumptions about the - UTF-8 cleanliness of the dump file handle? */ - SvUTF8_on(sv); -#endif 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))); + SvREFCNT_dec_NN(sv); + } else PerlIO_printf(Perl_debug_log, "(NULL)"); break; - { - int count; - case OP_PADSV: case OP_PADAV: case OP_PADHV: @@ -2500,7 +2316,6 @@ Perl_debop(pTHX_ const OP *o) PerlIO_printf(Perl_debug_log, ")"); } break; - } default: break; @@ -2512,7 +2327,6 @@ Perl_debop(pTHX_ const OP *o) STATIC CV* S_deb_curcv(pTHX_ const I32 ix) { - dVAR; const PERL_CONTEXT * const cx = &cxstack[ix]; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) return cx->blk_sub.cv; @@ -2529,8 +2343,6 @@ S_deb_curcv(pTHX_ const I32 ix) void Perl_watch(pTHX_ char **addr) { - dVAR; - PERL_ARGS_ASSERT_WATCH; PL_watchaddr = addr; @@ -2542,8 +2354,6 @@ Perl_watch(pTHX_ char **addr) STATIC void S_debprof(pTHX_ const OP *o) { - dVAR; - PERL_ARGS_ASSERT_DEBPROF; if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) @@ -2556,7 +2366,6 @@ S_debprof(pTHX_ const OP *o) void Perl_debprofdump(pTHX) { - dVAR; unsigned i; if (!PL_profiledata) return; @@ -2568,697 +2377,6 @@ Perl_debprofdump(pTHX) } } -#ifdef PERL_MAD -/* - * XML variants of most of the above routines - */ - -STATIC void -S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...) -{ - va_list args; - - PERL_ARGS_ASSERT_XMLDUMP_ATTR; - - PerlIO_printf(file, "\n "); - va_start(args, pat); - xmldump_vindent(level, file, pat, &args); - va_end(args); -} - - -void -Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) -{ - va_list args; - PERL_ARGS_ASSERT_XMLDUMP_INDENT; - va_start(args, pat); - xmldump_vindent(level, file, pat, &args); - va_end(args); -} - -void -Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) -{ - PERL_ARGS_ASSERT_XMLDUMP_VINDENT; - - PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); - PerlIO_vprintf(file, pat, *args); -} - -void -Perl_xmldump_all(pTHX) -{ - xmldump_all_perl(FALSE); -} - -void -Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL) -{ - PerlIO_setlinebuf(PL_xmlfp); - if (PL_main_root) - op_xmldump(PL_main_root); - /* someday we might call this, when it outputs XML: */ - /* xmldump_packsubs_perl(PL_defstash, justperl); */ - if (PL_xmlfp != (PerlIO*)PerlIO_stdout()) - PerlIO_close(PL_xmlfp); - PL_xmlfp = 0; -} - -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; - - if (!HvARRAY(stash)) - return; - for (i = 0; i <= (I32) HvMAX(stash); i++) { - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - GV *gv = MUTABLE_GV(HeVAL(entry)); - HV *hv; - if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) - continue; - if (GvCVu(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_perl(hv, justperl); /* nested package */ - } - } -} - -void -Perl_xmldump_sub(pTHX_ const GV *gv) -{ - 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))) - Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n", - PTR2UV(CvXSUB(GvCV(gv))), - (int)CvXSUBANY(GvCV(gv)).any_i32); - else if (CvROOT(GvCV(gv))) - op_xmldump(CvROOT(GvCV(gv))); - else - Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\n"); -} - -void -Perl_xmldump_form(pTHX_ const GV *gv) -{ - SV * const sv = sv_newmortal(); - - PERL_ARGS_ASSERT_XMLDUMP_FORM; - - gv_fullname3(sv, gv, NULL); - Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv)); - if (CvROOT(GvFORM(gv))) - op_xmldump(CvROOT(GvFORM(gv))); - else - Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\n"); -} - -void -Perl_xmldump_eval(pTHX) -{ - op_xmldump(PL_eval_root); -} - -char * -Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv) -{ - PERL_ARGS_ASSERT_SV_CATXMLSV; - return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv)); -} - -char * -Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8) -{ - PERL_ARGS_ASSERT_SV_CATXMLPV; - return sv_catxmlpvn(dsv, pv, strlen(pv), utf8); -} - -char * -Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) -{ - unsigned int c; - const char * const e = pv + len; - const char * const start = pv; - STRLEN dsvcur; - STRLEN cl; - - PERL_ARGS_ASSERT_SV_CATXMLPVN; - - sv_catpvs(dsv,""); - dsvcur = SvCUR(dsv); /* in case we have to restart */ - - retry: - while (pv < e) { - if (utf8) { - c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl); - if (cl == 0) { - SvCUR(dsv) = dsvcur; - pv = start; - utf8 = 0; - goto retry; - } - } - else - c = (*pv & 255); - - if (isCNTRL_L1(c) - && c != '\t' - && c != '\n' - && c != '\r' - && c != LATIN1_TO_NATIVE(0x85)) - { - Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c); - } - else switch (c) { - case '<': - sv_catpvs(dsv, "<"); - break; - case '>': - sv_catpvs(dsv, ">"); - break; - case '&': - sv_catpvs(dsv, "&"); - break; - case '"': - sv_catpvs(dsv, """); - break; - default: - if (c < 0xD800) { - if (! isPRINT(c)) { - Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c); - } - else { - const char string = (char) c; - sv_catpvn(dsv, &string, 1); - } - break; - } - if ((c >= 0xD800 && c <= 0xDB7F) || - (c >= 0xDC00 && c <= 0xDFFF) || - (c >= 0xFFF0 && c <= 0xFFFF) || - c > 0x10ffff) - Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c); - else - Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c); - } - - if (utf8) - pv += UTF8SKIP(pv); - else - pv++; - } - - return SvPVX(dsv); -} - -char * -Perl_sv_xmlpeek(pTHX_ SV *sv) -{ - SV * const t = sv_newmortal(); - STRLEN n_a; - int unref = 0; - - PERL_ARGS_ASSERT_SV_XMLPEEK; - - sv_utf8_upgrade(t); - sv_setpvs(t, ""); - /* retry: */ - if (!sv) { - sv_catpv(t, "VOID=\"\""); - goto finish; - } - else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') { - sv_catpv(t, "WILD=\"\""); - goto finish; - } - else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { - if (sv == &PL_sv_undef) { - sv_catpv(t, "SV_UNDEF=\"1\""); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - else if (sv == &PL_sv_no) { - sv_catpv(t, "SV_NO=\"1\""); - 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) == 0 && - SvNVX(sv) == 0.0) - goto finish; - } - else if (sv == &PL_sv_yes) { - sv_catpv(t, "SV_YES=\"1\""); - 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(sv) && *SvPVX(sv) == '1' && - SvNVX(sv) == 1.0) - goto finish; - } - else { - sv_catpv(t, "SV_PLACEHOLDER=\"1\""); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - sv_catpv(t, " XXX=\"\" "); - } - else if (SvREFCNT(sv) == 0) { - sv_catpv(t, " refcnt=\"0\""); - unref++; - } - else if (DEBUG_R_TEST_) { - int is_tmp = 0; - SSize_t ix; - /* is this SV on the tmps stack? */ - for (ix=PL_tmps_ix; ix>=0; ix--) { - if (PL_tmps_stack[ix] == sv) { - is_tmp = 1; - break; - } - } - if (SvREFCNT(sv) > 1) - Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv), - is_tmp ? "T" : ""); - else if (is_tmp) - sv_catpv(t, " DRT=\"\""); - } - - if (SvROK(sv)) { - sv_catpv(t, " ROK=\"\""); - } - switch (SvTYPE(sv)) { - default: - sv_catpv(t, " FREED=\"1\""); - goto finish; - - case SVt_NULL: - sv_catpv(t, " UNDEF=\"1\""); - goto finish; - case SVt_IV: - sv_catpv(t, " IV=\""); - break; - case SVt_NV: - sv_catpv(t, " NV=\""); - break; - case SVt_PV: - sv_catpv(t, " PV=\""); - break; - case SVt_PVIV: - sv_catpv(t, " PVIV=\""); - break; - case SVt_PVNV: - sv_catpv(t, " PVNV=\""); - break; - case SVt_PVMG: - sv_catpv(t, " PVMG=\""); - break; - case SVt_PVLV: - sv_catpv(t, " PVLV=\""); - break; - case SVt_PVAV: - sv_catpv(t, " AV=\""); - break; - case SVt_PVHV: - sv_catpv(t, " HV=\""); - break; - case SVt_PVCV: - if (CvGV(sv)) - Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv))); - else - sv_catpv(t, " CV=\"()\""); - goto finish; - case SVt_PVGV: - sv_catpv(t, " GV=\""); - break; - case SVt_INVLIST: - sv_catpv(t, " DUMMY=\""); - break; - case SVt_REGEXP: - sv_catpv(t, " REGEXP=\""); - break; - case SVt_PVFM: - sv_catpv(t, " FM=\""); - break; - case SVt_PVIO: - sv_catpv(t, " IO=\""); - break; - } - - if (SvPOKp(sv)) { - if (SvPVX(sv)) { - sv_catxmlsv(t, sv); - } - } - else if (SvNOKp(sv)) { - STORE_NUMERIC_LOCAL_SET_STANDARD(); - Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - } - else if (SvIOKp(sv)) { - if (SvIsUV(sv)) - Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv)); - else - Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv)); - } - else - sv_catpv(t, ""); - sv_catpv(t, "\""); - - finish: - while (unref--) - sv_catpv(t, ")"); - return SvPV(t, n_a); -} - -void -Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) -{ - PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP; - - if (!pm) { - Perl_xmldump_indent(aTHX_ level, file, "\n"); - return; - } - Perl_xmldump_indent(aTHX_ level, file, "op_private & OPpRUNTIME) ? "RUN" : "COMP"); - } - else - Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n"); - 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_NN(tmpsv); - } - - level--; - if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) { - Perl_xmldump_indent(aTHX_ level, file, ">\n"); - Perl_xmldump_indent(aTHX_ level+1, file, "\n"); - do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot); - Perl_xmldump_indent(aTHX_ level+1, file, "\n"); - Perl_xmldump_indent(aTHX_ level, file, "\n"); - } - else - Perl_xmldump_indent(aTHX_ level, file, "/>\n"); -} - -void -Perl_pmop_xmldump(pTHX_ const PMOP *pm) -{ - do_pmop_xmldump(0, PL_xmlfp, pm); -} - -void -Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) -{ - UV seq; - int contents = 0; - const OPCODE optype = o->op_type; - - PERL_ARGS_ASSERT_DO_OP_XMLDUMP; - - if (!o) - return; - seq = sequence_num(o); - Perl_xmldump_indent(aTHX_ level, file, - " ", - OP_NAME(o), - seq); - level++; - if (o->op_next) - PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"", - sequence_num(o->op_next)); - else - PerlIO_printf(file, "DONE\""); - - if (o->op_targ) { - if (optype == OP_NULL) - { - PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]); - if (o->op_targ == OP_NEXTSTATE) - { - if (CopLINE(cCOPo)) - PerlIO_printf(file, " line=\"%"UVuf"\"", - (UV)CopLINE(cCOPo)); - if (CopSTASHPV(cCOPo)) - PerlIO_printf(file, " package=\"%s\"", - CopSTASHPV(cCOPo)); - if (CopLABEL(cCOPo)) - PerlIO_printf(file, " label=\"%s\"", - CopLABEL(cCOPo)); - } - } - else - PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ); - } -#ifdef DUMPADDR - PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next); -#endif - - DUMP_OP_FLAGS(o,1,0,file); - DUMP_OP_PRIVATE(o,1,0,file); - - switch (optype) { - case OP_AELEMFAST: - if (o->op_flags & OPf_SPECIAL) { - break; - } - case OP_GVSV: - case OP_GV: -#ifdef USE_ITHREADS - S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix); -#else - if (cSVOPo->op_sv) { - SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE); - SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE); - char *s; - STRLEN len; - ENTER; - SAVEFREESV(tmpsv1); - SAVEFREESV(tmpsv2); - 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)); - LEAVE; - } - else - S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\""); -#endif - break; - case OP_CONST: - case OP_HINTSEVAL: - case OP_METHOD_NAMED: -#ifndef USE_ITHREADS - /* with ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so skip */ - S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv)); -#endif - break; - case OP_ANONCODE: - if (!contents) { - contents = 1; - PerlIO_printf(file, ">\n"); - } - do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv)); - break; - case OP_NEXTSTATE: - case OP_DBSTATE: - if (CopLINE(cCOPo)) - S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"", - (UV)CopLINE(cCOPo)); - if (CopSTASHPV(cCOPo)) - S_xmldump_attr(aTHX_ level, file, "package=\"%s\"", - CopSTASHPV(cCOPo)); - if (CopLABEL(cCOPo)) - S_xmldump_attr(aTHX_ level, file, "label=\"%s\"", - CopLABEL(cCOPo)); - break; - case OP_ENTERLOOP: - S_xmldump_attr(aTHX_ level, file, "redo=\""); - if (cLOOPo->op_redoop) - PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop)); - else - PerlIO_printf(file, "DONE\""); - S_xmldump_attr(aTHX_ level, file, "next=\""); - if (cLOOPo->op_nextop) - PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop)); - else - PerlIO_printf(file, "DONE\""); - S_xmldump_attr(aTHX_ level, file, "last=\""); - if (cLOOPo->op_lastop) - PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop)); - else - PerlIO_printf(file, "DONE\""); - break; - case OP_COND_EXPR: - case OP_RANGE: - case OP_MAPWHILE: - case OP_GREPWHILE: - case OP_OR: - case OP_AND: - S_xmldump_attr(aTHX_ level, file, "other=\""); - if (cLOGOPo->op_other) - PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other)); - else - PerlIO_printf(file, "DONE\""); - break; - case OP_LEAVE: - case OP_LEAVEEVAL: - case OP_LEAVESUB: - case OP_LEAVESUBLV: - case OP_LEAVEWRITE: - case OP_SCOPE: - if (o->op_private & OPpREFCOUNTED) - S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ); - break; - default: - break; - } - - if (PL_madskills && o->op_madprop) { - char prevkey = '\0'; - SV * const tmpsv = newSVpvn_utf8("", 0, TRUE); - const MADPROP* mp = o->op_madprop; - - if (!contents) { - contents = 1; - PerlIO_printf(file, ">\n"); - } - Perl_xmldump_indent(aTHX_ level, file, "\n"); - level++; - while (mp) { - char tmp = mp->mad_key; - sv_setpvs(tmpsv,"\""); - if (tmp) - sv_catxmlpvn(tmpsv, &tmp, 1, 0); - if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */ - sv_catxmlpvn(tmpsv, &prevkey, 1, 0); - else - prevkey = tmp; - sv_catpv(tmpsv, "\""); - switch (mp->mad_type) { - case MAD_NULL: - sv_catpv(tmpsv, "NULL"); - Perl_xmldump_indent(aTHX_ level, file, "\n", SvPVX(tmpsv)); - break; - case MAD_PV: - sv_catpv(tmpsv, " val=\""); - sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1); - sv_catpv(tmpsv, "\""); - Perl_xmldump_indent(aTHX_ level, file, "\n", SvPVX(tmpsv)); - break; - case MAD_SV: - sv_catpv(tmpsv, " val=\""); - sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val)); - sv_catpv(tmpsv, "\""); - Perl_xmldump_indent(aTHX_ level, file, "\n", SvPVX(tmpsv)); - break; - case MAD_OP: - if ((OP*)mp->mad_val) { - Perl_xmldump_indent(aTHX_ level, file, "\n", SvPVX(tmpsv)); - do_op_xmldump(level+1, file, (OP*)mp->mad_val); - Perl_xmldump_indent(aTHX_ level, file, "\n"); - } - break; - default: - Perl_xmldump_indent(aTHX_ level, file, "\n", SvPVX(tmpsv)); - break; - } - mp = mp->mad_next; - } - level--; - Perl_xmldump_indent(aTHX_ level, file, "\n"); - - SvREFCNT_dec_NN(tmpsv); - } - - switch (optype) { - case OP_PUSHRE: - case OP_MATCH: - case OP_QR: - case OP_SUBST: - if (!contents) { - contents = 1; - PerlIO_printf(file, ">\n"); - } - do_pmop_xmldump(level, file, cPMOPo); - break; - default: - break; - } - - if (o->op_flags & OPf_KIDS) { - OP *kid; - if (!contents) { - contents = 1; - PerlIO_printf(file, ">\n"); - } - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) - do_op_xmldump(level, file, kid); - } - - if (contents) - Perl_xmldump_indent(aTHX_ level-1, file, "\n", OP_NAME(o)); - else - PerlIO_printf(file, " />\n"); -} - -void -Perl_op_xmldump(pTHX_ const OP *o) -{ - PERL_ARGS_ASSERT_OP_XMLDUMP; - - do_op_xmldump(0, PL_xmlfp, o); -} -#endif /* * Local variables: