X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1d3259712a05143b33614901d9fae89e4bbfaa3e..3ce4c5325c6bf80779666a9007ef3a4d29f4fce1:/dump.c diff --git a/dump.c b/dump.c index 6122ea7..e548585 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -24,8 +24,10 @@ #define PERL_IN_DUMP_C #include "perl.h" #include "regcomp.h" +#include "proto.h" -static HV *Sequence; + +#define Sequence PL_op_sequence void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) @@ -39,6 +41,7 @@ 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; PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); } @@ -46,6 +49,7 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) void Perl_dump_all(pTHX) { + dVAR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) op_dump(PL_main_root); @@ -55,6 +59,7 @@ Perl_dump_all(pTHX) void Perl_dump_packsubs(pTHX_ const HV *stash) { + dVAR; I32 i; if (!HvARRAY(stash)) @@ -80,11 +85,11 @@ Perl_dump_packsubs(pTHX_ const HV *stash) void Perl_dump_sub(pTHX_ const GV *gv) { - SV *sv = sv_newmortal(); + SV * const sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv)); - if (CvXSUB(GvCV(gv))) + gv_fullname3(sv, gv, NULL); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); + if (CvISXSUB(GvCV(gv))) Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", PTR2UV(CvXSUB(GvCV(gv))), (int)CvXSUBANY(GvCV(gv)).any_i32); @@ -97,10 +102,10 @@ Perl_dump_sub(pTHX_ const GV *gv) void Perl_dump_form(pTHX_ const GV *gv) { - SV *sv = sv_newmortal(); + SV * const sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX(sv)); + gv_fullname3(sv, gv, NULL); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); if (CvROOT(GvFORM(gv))) op_dump(CvROOT(GvFORM(gv))); else @@ -110,6 +115,7 @@ Perl_dump_form(pTHX_ const GV *gv) void Perl_dump_eval(pTHX) { + dVAR; op_dump(PL_eval_root); } @@ -126,12 +132,12 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv break; } switch (*pv) { - case '\t': sv_catpvn(dsv, "\\t", 2); break; - case '\n': sv_catpvn(dsv, "\\n", 2); break; - case '\r': sv_catpvn(dsv, "\\r", 2); break; - case '\f': sv_catpvn(dsv, "\\f", 2); break; - case '"': sv_catpvn(dsv, "\\\"", 2); break; - case '\\': sv_catpvn(dsv, "\\\\", 2); break; + case '\t': sv_catpvs(dsv, "\\t"); break; + case '\n': sv_catpvs(dsv, "\\n"); break; + case '\r': sv_catpvs(dsv, "\\r"); break; + case '\f': sv_catpvs(dsv, "\\f"); break; + case '"': sv_catpvs(dsv, "\\\""); break; + case '\\': sv_catpvs(dsv, "\\\\"); break; default: if (isPRINT(*pv)) sv_catpvn(dsv, pv, 1); @@ -141,11 +147,11 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv Perl_sv_catpvf(aTHX_ dsv, "\\%o", (U8)*pv); } } - sv_catpvn(dsv, "\"", 1); + sv_catpvs(dsv, "\""); if (truncated) - sv_catpvn(dsv, "...", 3); + sv_catpvs(dsv, "..."); if (nul_terminated) - sv_catpvn(dsv, "\\0", 2); + sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } @@ -153,8 +159,8 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv char * Perl_sv_peek(pTHX_ SV *sv) { - SV *t = sv_newmortal(); - STRLEN n_a; + dVAR; + SV * const t = sv_newmortal(); int unref = 0; sv_setpvn(t, "", 0); @@ -192,7 +198,7 @@ Perl_sv_peek(pTHX_ SV *sv) !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| SVp_POK|SVp_NOK)) && SvCUR(sv) == 1 && - SvPVX(sv) && *SvPVX(sv) == '1' && + SvPVX_const(sv) && *SvPVX_const(sv) == '1' && SvNVX(sv) == 1.0) goto finish; } @@ -229,7 +235,7 @@ Perl_sv_peek(pTHX_ SV *sv) if (SvROK(sv)) { sv_catpv(t, "\\"); if (SvCUR(t) + unref > 10) { - SvCUR(t) = unref + 3; + SvCUR_set(t, unref + 3); *SvEND(t) = '\0'; sv_catpv(t, "..."); goto finish; @@ -296,14 +302,14 @@ Perl_sv_peek(pTHX_ SV *sv) } if (SvPOKp(sv)) { - if (!SvPVX(sv)) + if (!SvPVX_const(sv)) sv_catpv(t, "(null)"); else { - SV *tmp = newSVpvn("", 0); + SV *tmp = newSVpvs(""); sv_catpv(t, "("); if (SvOOK(sv)) - Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); - Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127)); + Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 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\"]", sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv), @@ -330,11 +336,11 @@ Perl_sv_peek(pTHX_ SV *sv) while (unref--) sv_catpv(t, ")"); } - return SvPV(t, n_a); + return SvPV_nolen(t); } void -Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm) +Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) { char ch; @@ -359,40 +365,52 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm) op_dump(pm->op_pmreplroot); } if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) { - SV *tmpsv = newSVpvn("", 0); - if (pm->op_pmdynflags & PMdf_USED) - sv_catpv(tmpsv, ",USED"); - if (pm->op_pmdynflags & PMdf_TAINTED) - sv_catpv(tmpsv, ",TAINTED"); - if (pm->op_pmflags & PMf_ONCE) - sv_catpv(tmpsv, ",ONCE"); - if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr - && !(PM_GETRE(pm)->reganch & ROPT_NOSCAN)) - sv_catpv(tmpsv, ",SCANFIRST"); - if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr - && PM_GETRE(pm)->reganch & ROPT_CHECK_ALL) - sv_catpv(tmpsv, ",ALL"); - if (pm->op_pmflags & PMf_SKIPWHITE) - sv_catpv(tmpsv, ",SKIPWHITE"); - if (pm->op_pmflags & PMf_CONST) - sv_catpv(tmpsv, ",CONST"); - if (pm->op_pmflags & PMf_KEEP) - sv_catpv(tmpsv, ",KEEP"); - if (pm->op_pmflags & PMf_GLOBAL) - sv_catpv(tmpsv, ",GLOBAL"); - if (pm->op_pmflags & PMf_CONTINUE) - sv_catpv(tmpsv, ",CONTINUE"); - if (pm->op_pmflags & PMf_RETAINT) - sv_catpv(tmpsv, ",RETAINT"); - if (pm->op_pmflags & PMf_EVAL) - sv_catpv(tmpsv, ",EVAL"); - Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + SV * const tmpsv = pm_description(pm); + Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); SvREFCNT_dec(tmpsv); } Perl_dump_indent(aTHX_ level-1, file, "}\n"); } +static +SV * +S_pm_description(pTHX_ const PMOP *pm) +{ + SV * const desc = newSVpvs(""); + const REGEXP * regex = PM_GETRE(pm); + const U32 pmflags = pm->op_pmflags; + + if (pm->op_pmdynflags & PMdf_USED) + sv_catpv(desc, ",USED"); + if (pm->op_pmdynflags & PMdf_TAINTED) + sv_catpv(desc, ",TAINTED"); + + if (pmflags & PMf_ONCE) + sv_catpv(desc, ",ONCE"); + if (regex && regex->check_substr) { + if (!(regex->reganch & ROPT_NOSCAN)) + sv_catpv(desc, ",SCANFIRST"); + if (regex->reganch & ROPT_CHECK_ALL) + sv_catpv(desc, ",ALL"); + } + if (pmflags & PMf_SKIPWHITE) + sv_catpv(desc, ",SKIPWHITE"); + if (pmflags & PMf_CONST) + sv_catpv(desc, ",CONST"); + if (pmflags & PMf_KEEP) + sv_catpv(desc, ",KEEP"); + if (pmflags & PMf_GLOBAL) + sv_catpv(desc, ",GLOBAL"); + if (pmflags & PMf_CONTINUE) + sv_catpv(desc, ",CONTINUE"); + if (pmflags & PMf_RETAINT) + sv_catpv(desc, ",RETAINT"); + if (pmflags & PMf_EVAL) + sv_catpv(desc, ",EVAL"); + return desc; +} + void Perl_pmop_dump(pTHX_ PMOP *pm) { @@ -402,40 +420,44 @@ Perl_pmop_dump(pTHX_ PMOP *pm) /* An op sequencer. We visit the ops in the order they're to execute. */ STATIC void -sequence(pTHX_ register OP *o) +S_sequence(pTHX_ register const OP *o) { + dVAR; SV *op; - char *key; + const char *key; STRLEN len; - static UV seq; - OP *oldop = 0, - *l; - - if (!Sequence) - Sequence = newHV(); + const OP *oldop = NULL; + OP *l; if (!o) return; - op = newSVuv(PTR2UV(o)); - key = SvPV(op, len); - if (hv_exists(Sequence, key, len)) - return; +#ifdef PERL_MAD + if (o->op_next == 0) + return; +#endif + + if (!Sequence) + Sequence = newHV(); for (; o; o = o->op_next) { op = newSVuv(PTR2UV(o)); - key = SvPV(op, len); + key = SvPV_const(op, len); if (hv_exists(Sequence, key, len)) break; switch (o->op_type) { case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } goto nothin; case OP_NULL: +#ifdef PERL_MAD + if (o == o->op_next) + return; +#endif if (oldop && o->op_next) continue; break; @@ -445,7 +467,7 @@ sequence(pTHX_ register OP *o) nothin: if (oldop && o->op_next) continue; - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; case OP_MAPWHILE: @@ -458,40 +480,40 @@ sequence(pTHX_ register OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cLOGOPo->op_other; l && l->op_type == OP_NULL; l = l->op_next) ; - sequence(aTHX_ l); + sequence(l); break; case OP_ENTERLOOP: case OP_ENTERITER: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cLOOPo->op_redoop; l && l->op_type == OP_NULL; l = l->op_next) ; - sequence(aTHX_ l); + sequence(l); for (l = cLOOPo->op_nextop; l && l->op_type == OP_NULL; l = l->op_next) ; - sequence(aTHX_ l); + sequence(l); for (l = cLOOPo->op_lastop; l && l->op_type == OP_NULL; l = l->op_next) ; - sequence(aTHX_ l); + sequence(l); break; case OP_QR: case OP_MATCH: case OP_SUBST: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cPMOPo->op_pmreplstart; l && l->op_type == OP_NULL; l = l->op_next) ; - sequence(aTHX_ l); + sequence(l); break; case OP_HELEM: break; default: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } oldop = o; @@ -499,27 +521,29 @@ sequence(pTHX_ register OP *o) } STATIC UV -sequence_num(pTHX_ OP *o) +S_sequence_num(pTHX_ const OP *o) { + dVAR; SV *op, **seq; - char *key; + const char *key; STRLEN len; if (!o) return 0; op = newSVuv(PTR2UV(o)); - key = SvPV(op, len); + key = SvPV_const(op, len); seq = hv_fetch(Sequence, key, len, 0); return seq ? SvUV(*seq): 0; } void -Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) +Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) { + dVAR; UV seq; - sequence(aTHX_ o); + sequence(o); Perl_dump_indent(aTHX_ level, file, "{\n"); level++; - seq = sequence_num(aTHX_ o); + seq = sequence_num(o); if (seq) PerlIO_printf(file, "%-4"UVf, seq); else @@ -529,7 +553,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) (int)(PL_dumpindent*level-4), "", OP_NAME(o)); if (o->op_next) PerlIO_printf(file, seq ? "%"UVf"\n" : "(%"UVf")\n", - sequence_num(aTHX_ o->op_next)); + sequence_num(o->op_next)); else PerlIO_printf(file, "DONE\n"); if (o->op_targ) { @@ -556,7 +580,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); #endif if (o->op_flags) { - SV *tmpsv = newSVpvn("", 0); + SV *tmpsv = newSVpvs(""); switch (o->op_flags & OPf_WANT) { case OPf_WANT_VOID: sv_catpv(tmpsv, ",VOID"); @@ -583,11 +607,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) sv_catpv(tmpsv, ",MOD"); if (o->op_flags & OPf_SPECIAL) sv_catpv(tmpsv, ",SPECIAL"); - Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); SvREFCNT_dec(tmpsv); } if (o->op_private) { - SV *tmpsv = newSVpvn("", 0); + SV *tmpsv = newSVpvs(""); if (PL_opargs[o->op_type] & OA_TARGLEX) { if (o->op_private & OPpTARGET_MY) sv_catpv(tmpsv, ",TARGET_MY"); @@ -753,9 +777,52 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) sv_catpv(tmpsv, ",INTRO"); if (SvCUR(tmpsv)) - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX(tmpsv) + 1); + Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); + SvREFCNT_dec(tmpsv); + } + +#ifdef PERL_MAD + if (PL_madskills && o->op_madprop) { + SV * const tmpsv = newSVpvn("", 0); + MADPROP* mp = o->op_madprop; + Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n"); + level++; + while (mp) { + char tmp = mp->mad_key; + sv_setpvn(tmpsv,"'",1); + 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"); + SvREFCNT_dec(tmpsv); } +#endif switch (o->op_type) { case OP_AELEMFAST: @@ -766,12 +833,17 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) #else if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */ if (cSVOPo->op_sv) { - SV *tmpsv = NEWSV(0,0); - STRLEN n_a; + SV * const tmpsv = newSV(0); ENTER; SAVEFREESV(tmpsv); - gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch); - Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a)); +#ifdef PERL_MAD + /* FIXME - it this making unwarranted assumptions about the + UTF-8 cleanliness of the dump file handle? */ + SvUTF8_on(tmpsv); +#endif + gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL); + Perl_dump_indent(aTHX_ level, file, "GV = %s\n", + SvPV_nolen_const(tmpsv)); LEAVE; } else @@ -803,17 +875,17 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) case OP_ENTERLOOP: Perl_dump_indent(aTHX_ level, file, "REDO ===> "); if (cLOOPo->op_redoop) - PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_redoop)); + PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOOPo->op_redoop)); else PerlIO_printf(file, "DONE\n"); Perl_dump_indent(aTHX_ level, file, "NEXT ===> "); if (cLOOPo->op_nextop) - PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_nextop)); + PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOOPo->op_nextop)); else PerlIO_printf(file, "DONE\n"); Perl_dump_indent(aTHX_ level, file, "LAST ===> "); if (cLOOPo->op_lastop) - PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_lastop)); + PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOOPo->op_lastop)); else PerlIO_printf(file, "DONE\n"); break; @@ -825,7 +897,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) case OP_AND: Perl_dump_indent(aTHX_ level, file, "OTHER ===> "); if (cLOGOPo->op_other) - PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOGOPo->op_other)); + PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOGOPo->op_other)); else PerlIO_printf(file, "DONE\n"); break; @@ -856,7 +928,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } void -Perl_op_dump(pTHX_ OP *o) +Perl_op_dump(pTHX_ const OP *o) { do_op_dump(0, Perl_debug_log, o); } @@ -872,11 +944,11 @@ Perl_gv_dump(pTHX_ GV *gv) } sv = sv_newmortal(); PerlIO_printf(Perl_debug_log, "{\n"); - gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv)); + gv_fullname3(sv, gv, NULL); + Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv)); if (gv != GvEGV(gv)) { - gv_efullname3(sv, GvEGV(gv), Nullch); - Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX(sv)); + gv_efullname3(sv, GvEGV(gv), NULL); + Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv)); } PerlIO_putc(Perl_debug_log, '\n'); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); @@ -887,16 +959,19 @@ Perl_gv_dump(pTHX_ GV *gv) * (with the PERL_MAGIC_ prefixed stripped) */ -static struct { const char type; const char *name; } magic_names[] = { +static const struct { const char type; const char *name; } magic_names[] = { { PERL_MAGIC_sv, "sv(\\0)" }, { PERL_MAGIC_arylen, "arylen(#)" }, - { PERL_MAGIC_glob, "glob(*)" }, + { PERL_MAGIC_rhash, "rhash(%)" }, { PERL_MAGIC_pos, "pos(.)" }, + { PERL_MAGIC_symtab, "symtab(:)" }, { PERL_MAGIC_backref, "backref(<)" }, + { PERL_MAGIC_arylen_p, "arylen_p(@)" }, { PERL_MAGIC_overload, "overload(A)" }, { PERL_MAGIC_bm, "bm(B)" }, { PERL_MAGIC_regdata, "regdata(D)" }, { PERL_MAGIC_env, "env(E)" }, + { PERL_MAGIC_hints, "hints(H)" }, { PERL_MAGIC_isa, "isa(I)" }, { PERL_MAGIC_dbfile, "dbfile(L)" }, { PERL_MAGIC_shared, "shared(N)" }, @@ -909,6 +984,7 @@ static struct { const char type; const char *name; } magic_names[] = { { PERL_MAGIC_envelem, "envelem(e)" }, { PERL_MAGIC_fm, "fm(f)" }, { PERL_MAGIC_regex_global, "regex_global(g)" }, + { PERL_MAGIC_hintselem, "hintselem(h)" }, { PERL_MAGIC_isaelem, "isaelem(i)" }, { PERL_MAGIC_nkeys, "nkeys(k)" }, { PERL_MAGIC_dbline, "dbline(l)" }, @@ -932,14 +1008,14 @@ static struct { const char type; const char *name; } magic_names[] = { }; void -Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) +Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { for (; mg; mg = mg->mg_moremagic) { Perl_dump_indent(aTHX_ level, file, " MAGIC = 0x%"UVxf"\n", PTR2UV(mg)); if (mg->mg_virtual) { const MGVTBL * const v = mg->mg_virtual; - const char *s = 0; + const char *s = NULL; if (v == &PL_vtbl_sv) s = "sv"; else if (v == &PL_vtbl_env) s = "env"; else if (v == &PL_vtbl_envelem) s = "envelem"; @@ -950,7 +1026,6 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne else if (v == &PL_vtbl_dbline) s = "dbline"; else if (v == &PL_vtbl_isa) s = "isa"; else if (v == &PL_vtbl_arylen) s = "arylen"; - else if (v == &PL_vtbl_glob) s = "glob"; else if (v == &PL_vtbl_mglob) s = "mglob"; else if (v == &PL_vtbl_nkeys) s = "nkeys"; else if (v == &PL_vtbl_taint) s = "taint"; @@ -968,6 +1043,8 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne else if (v == &PL_vtbl_amagicelem) s = "amagicelem"; else if (v == &PL_vtbl_backref) s = "backref"; 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"; if (s) Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); else @@ -981,8 +1058,8 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne { int n; - const char *name = 0; - for (n=0; magic_names[n].name; n++) { + const char *name = NULL; + for (n = 0; magic_names[n].name; n++) { if (mg->mg_type == magic_names[n].type) { name = magic_names[n].name; break; @@ -1020,7 +1097,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr)); if (mg->mg_len >= 0) { if (mg->mg_type != PERL_MAGIC_utf8) { - SV *sv = newSVpvn("", 0); + SV *sv = newSVpvs(""); PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); SvREFCNT_dec(sv); } @@ -1050,7 +1127,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne } void -Perl_magic_dump(pTHX_ MAGIC *mg) +Perl_magic_dump(pTHX_ const MAGIC *mg) { do_magic_dump(0, Perl_debug_log, mg, 0, 0, 0, 0); } @@ -1058,9 +1135,10 @@ Perl_magic_dump(pTHX_ MAGIC *mg) void Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) { + const char *hvname; Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); - if (sv && HvNAME(sv)) - PerlIO_printf(file, "\t\"%s\"\n", HvNAME(sv)); + if (sv && (hvname = HvNAME_get(sv))) + PerlIO_printf(file, "\t\"%s\"\n", hvname); else PerlIO_putc(file, '\n'); } @@ -1080,9 +1158,10 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) { Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) { + const char *hvname; PerlIO_printf(file, "\t\""); - if (GvSTASH(sv) && HvNAME(GvSTASH(sv))) - PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv))); + if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv)))) + PerlIO_printf(file, "%s\" :: \"", hvname); PerlIO_printf(file, "%s\"\n", GvNAME(sv)); } else @@ -1092,6 +1171,7 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 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; @@ -1131,12 +1211,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); - if (flags & SVf_AMAGIC && type != SVt_PVHV) - sv_catpv(d, "OVERLOAD,"); + if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,"); if (flags & SVp_IOK) sv_catpv(d, "pIOK,"); if (flags & SVp_NOK) sv_catpv(d, "pNOK,"); if (flags & SVp_POK) sv_catpv(d, "pPOK,"); - if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,"); + if (flags & SVp_SCREAM && type != SVt_PVHV) + sv_catpv(d, "SCREAM,"); switch (type) { case SVt_PVCV: @@ -1159,6 +1239,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,"); if (HvREHASH(sv)) sv_catpv(d, "REHASH,"); + if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,"); break; case SVt_PVGV: case SVt_PVLV: if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); @@ -1166,7 +1247,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,"); - if (flags & SVpad_OUR) sv_catpv(d, "OUR,"); + if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,"); + if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,"); if (GvIMPORTED(sv)) { sv_catpv(d, "IMPORT"); if (GvIMPORTED(sv) == GVf_IMPORTED) @@ -1183,25 +1265,28 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo /* FALL THROUGH */ default: if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); - if (SvIsUV(sv)) sv_catpv(d, "IsUV,"); + if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,"); break; case SVt_PVBM: if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); if (SvVALID(sv)) sv_catpv(d, "VALID,"); break; case SVt_PVMG: - if (flags & SVpad_TYPED) - sv_catpv(d, "TYPED,"); + if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,"); + break; + case SVt_PVAV: break; } /* SVphv_SHAREKEYS is also 0x20000000 */ if ((type != SVt_PVHV) && SvUTF8(sv)) sv_catpv(d, "UTF8"); - if (*(SvEND(d) - 1) == ',') - SvPVX(d)[--SvCUR(d)] = '\0'; + if (*(SvEND(d) - 1) == ',') { + SvCUR_set(d, SvCUR(d) - 1); + SvPVX(d)[SvCUR(d)] = '\0'; + } sv_catpv(d, ")"); - s = SvPVX(d); + s = SvPVX_const(d); #ifdef DEBUG_LEAKING_SCALARS Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n", @@ -1267,9 +1352,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SvREFCNT_dec(d); return; } - if (type >= SVt_PVIV || type == SVt_IV) { + if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV + && type != SVt_PVCV && !isGV_with_GP(sv)) + || type == SVt_IV) { if (SvIsUV(sv) -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE || SvIsCOW(sv) #endif ) @@ -1278,7 +1365,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv)); if (SvOOK(sv)) PerlIO_printf(file, " (OFFSET)"); -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW_shared_hash(sv)) PerlIO_printf(file, " (HASH)"); else if (SvIsCOW_normal(sv)) @@ -1286,7 +1373,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo #endif PerlIO_putc(file, '\n'); } - if (type >= SVt_PVNV || type == SVt_NV) { + if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV + && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)) + || type == SVt_NV) { STORE_NUMERIC_LOCAL_SET_STANDARD(); /* %Vg doesn't work? --jhi */ #ifdef USE_LONG_DOUBLE @@ -1305,12 +1394,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SvREFCNT_dec(d); return; } - if (type <= SVt_PVLV && type != SVt_PVGV) { - if (SvPVX(sv)) { - Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv))); + if (type <= SVt_PVLV && !isGV_with_GP(sv)) { + if (SvPVX_const(sv)) { + Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv))); if (SvOOK(sv)) - PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); - PerlIO_printf(file, "%s", pv_display(d, SvPVX(sv), SvCUR(sv), SvLEN(sv), pvlim)); + PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); + PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim)); if (SvUTF8(sv)) /* the 8? \x{....} */ PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ)); PerlIO_printf(file, "\n"); @@ -1337,13 +1426,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_putc(file, '\n'); 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", PTR2UV(AvARYLEN(sv))); - flags = AvFLAGS(sv); - sv_setpv(d, ""); - if (flags & AVf_REAL) sv_catpv(d, ",REAL"); - if (flags & AVf_REIFY) sv_catpv(d, ",REIFY"); - if (flags & AVf_REUSED) sv_catpv(d, ",REUSED"); - Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", SvCUR(d) ? SvPVX(d) + 1 : ""); + Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); + sv_setpvn(d, "", 0); + 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) { int count; for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) { @@ -1369,7 +1457,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, " ("); Zero(freq, FREQ_MAX + 1, int); for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { - HE* h; int count = 0; + HE* h; + int count = 0; for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) count++; if (count > FREQ_MAX) @@ -1413,15 +1502,31 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv)); Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv)); Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); - Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER(sv)); - Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER(sv))); - if (HvPMROOT(sv)) - Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(HvPMROOT(sv))); - if (HvNAME(sv)) - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", HvNAME(sv)); - if (nest < maxnest && !HvEITER(sv)) { /* Try to preserve iterator */ + Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv)); + Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv))); + { + MAGIC *mg = mg_find(sv, PERL_MAGIC_symtab); + if (mg && mg->mg_obj) { + Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj)); + } + } + { + const char *hvname = HvNAME_get(sv); + if (hvname) + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); + } + if (SvOOK(sv)) { + AV *backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv); + 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, + dumpops, pvlim); + } + } + if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ HE *he; - HV *hv = (HV*)sv; + HV * const hv = (HV*)sv; int count = maxnest - nest; hv_iterinit(hv); @@ -1430,10 +1535,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SV *elt, *keysv; const char *keypv; STRLEN len; - U32 hash = HeHASH(he); + const U32 hash = HeHASH(he); keysv = hv_iterkeysv(he); - keypv = SvPV(keysv, len); + keypv = SvPV_const(keysv, len); elt = hv_iterval(hv, he); Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); if (SvUTF8(keysv)) @@ -1448,17 +1553,38 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo break; case SVt_PVCV: if (SvPOK(sv)) - Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV_nolen(sv)); + Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV_nolen_const(sv)); /* FALL THROUGH */ case SVt_PVFM: do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); - if (CvSTART(sv)) - Perl_dump_indent(aTHX_ level, file, " START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)sequence_num(aTHX_ CvSTART(sv))); - Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv))); - if (CvROOT(sv) && dumpops) - do_op_dump(level+1, file, CvROOT(sv)); - Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv))); - Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n", (IV)CvXSUBANY(sv).any_i32); + if (!CvISXSUB(sv)) { + if (CvSTART(sv)) { + Perl_dump_indent(aTHX_ level, file, + " START = 0x%"UVxf" ===> %"IVdf"\n", + PTR2UV(CvSTART(sv)), + (IV)sequence_num(CvSTART(sv))); + } + Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", + PTR2UV(CvROOT(sv))); + if (CvROOT(sv) && dumpops) { + do_op_dump(level+1, file, CvROOT(sv)); + } + } else { + SV *constant = cv_const_sv((CV *)sv); + + Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv))); + + if (constant) { + Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf + " (CONST SV)\n", + PTR2UV(CvXSUBANY(sv).any_ptr)); + do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, + pvlim); + } else { + Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n", + (IV)CvXSUBANY(sv).any_i32); + } + } do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); @@ -1496,6 +1622,8 @@ 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", GvNAME(sv)); Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv)); do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); + if (!isGV_with_GP(sv)) + break; Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv))); if (!GvGP(sv)) break; @@ -1507,7 +1635,6 @@ 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"\n", (UV)GvGPFLAGS(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)); @@ -1523,13 +1650,36 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv)); if (IoTOP_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); - do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); + if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); + 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); + } + /* Source filters hide things that are not GVs in these three, so let's + be careful out there. */ if (IoFMT_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); - do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); + if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); + 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); + } if (IoBOTTOM_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); - do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); + if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); + 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); + } Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv)); if (isPRINT(IoTYPE(sv))) Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); @@ -1544,12 +1694,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo void Perl_sv_dump(pTHX_ SV *sv) { + dVAR; do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); } int Perl_runops_debug(pTHX) { + dVAR; if (!PL_op) { if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); @@ -1586,12 +1738,9 @@ Perl_runops_debug(pTHX) } I32 -Perl_debop(pTHX_ OP *o) +Perl_debop(pTHX_ const OP *o) { - AV *padlist, *comppad; - CV *cv; - SV *sv; - + dVAR; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -1603,9 +1752,14 @@ Perl_debop(pTHX_ OP *o) case OP_GVSV: case OP_GV: if (cGVOPo_gv) { - sv = NEWSV(0,0); - gv_fullname3(sv, cGVOPo_gv, Nullch); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); + SV *sv = newSV(0); +#ifdef PERL_MAD + /* FIXME - it 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(sv); } else @@ -1614,18 +1768,21 @@ Perl_debop(pTHX_ OP *o) case OP_PADSV: case OP_PADAV: case OP_PADHV: + { /* print the lexical's name */ - cv = deb_curcv(cxstack_ix); + CV *cv = deb_curcv(cxstack_ix); + SV *sv; if (cv) { - padlist = CvPADLIST(cv); - comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); + AV * const padlist = CvPADLIST(cv); + AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); sv = *av_fetch(comppad, o->op_targ, FALSE); } else - sv = Nullsv; + sv = NULL; if (sv) - PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); else PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ); + } break; default: break; @@ -1637,6 +1794,7 @@ Perl_debop(pTHX_ OP *o) STATIC CV* S_deb_curcv(pTHX_ I32 ix) { + dVAR; const PERL_CONTEXT *cx = &cxstack[ix]; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) return cx->blk_sub.cv; @@ -1645,7 +1803,7 @@ S_deb_curcv(pTHX_ I32 ix) else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN) return PL_main_cv; else if (ix <= 0) - return Nullcv; + return NULL; else return deb_curcv(ix - 1); } @@ -1653,6 +1811,7 @@ S_deb_curcv(pTHX_ I32 ix) void Perl_watch(pTHX_ char **addr) { + dVAR; PL_watchaddr = addr; PL_watchok = *addr; PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", @@ -1662,16 +1821,18 @@ Perl_watch(pTHX_ char **addr) STATIC void S_debprof(pTHX_ const OP *o) { + dVAR; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return; if (!PL_profiledata) - Newz(000, PL_profiledata, MAXO, U32); + Newxz(PL_profiledata, MAXO, U32); ++PL_profiledata[o->op_type]; } void Perl_debprofdump(pTHX) { + dVAR; unsigned i; if (!PL_profiledata) return; @@ -1682,3 +1843,895 @@ Perl_debprofdump(pTHX) PL_op_name[i]); } } + +#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; + 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; + 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) +{ + PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); + PerlIO_vprintf(file, pat, *args); +} + +void +Perl_xmldump_all(pTHX) +{ + PerlIO_setlinebuf(PL_xmlfp); + if (PL_main_root) + op_xmldump(PL_main_root); + if (PL_xmlfp != (PerlIO*)PerlIO_stdout()) + PerlIO_close(PL_xmlfp); + PL_xmlfp = 0; +} + +void +Perl_xmldump_packsubs(pTHX_ const HV *stash) +{ + I32 i; + HE *entry; + + 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); + HV *hv; + if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) + continue; + if (GvCVu(gv)) + xmldump_sub(gv); + if (GvFORM(gv)) + xmldump_form(gv); + if (HeKEY(entry)[HeKLEN(entry)-1] == ':' + && (hv = GvHV(gv)) && hv != PL_defstash) + xmldump_packsubs(hv); /* nested package */ + } + } +} + +void +Perl_xmldump_sub(pTHX_ const GV *gv) +{ + SV *sv = sv_newmortal(); + + gv_fullname3(sv, gv, Nullch); + 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 *sv = sv_newmortal(); + + gv_fullname3(sv, gv, Nullch); + 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) +{ + return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv)); +} + +char * +Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8) +{ + unsigned int c; + char *e = pv + len; + char *start = pv; + STRLEN dsvcur; + STRLEN cl; + + sv_catpvn(dsv,"",0); + dsvcur = SvCUR(dsv); /* in case we have to restart */ + + retry: + while (pv < e) { + if (utf8) { + c = utf8_to_uvchr((U8*)pv, &cl); + if (cl == 0) { + SvCUR(dsv) = dsvcur; + pv = start; + utf8 = 0; + goto retry; + } + } + else + c = (*pv & 255); + + switch (c) { + case 0x00: + case 0x01: + case 0x02: + case 0x03: + case 0x04: + case 0x05: + case 0x06: + case 0x07: + case 0x08: + case 0x0b: + case 0x0c: + case 0x0e: + case 0x0f: + case 0x10: + case 0x11: + case 0x12: + case 0x13: + case 0x14: + case 0x15: + case 0x16: + case 0x17: + case 0x18: + case 0x19: + case 0x1a: + case 0x1b: + case 0x1c: + case 0x1d: + case 0x1e: + case 0x1f: + case 0x7f: + case 0x80: + case 0x81: + case 0x82: + case 0x83: + case 0x84: + case 0x86: + case 0x87: + case 0x88: + case 0x89: + case 0x90: + case 0x91: + case 0x92: + case 0x93: + case 0x94: + case 0x95: + case 0x96: + case 0x97: + case 0x98: + case 0x99: + case 0x9a: + case 0x9b: + case 0x9c: + case 0x9d: + case 0x9e: + case 0x9f: + Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c); + break; + case '<': + Perl_sv_catpvf(aTHX_ dsv, "<"); + break; + case '>': + Perl_sv_catpvf(aTHX_ dsv, ">"); + break; + case '&': + Perl_sv_catpvf(aTHX_ dsv, "&"); + break; + case '"': + Perl_sv_catpvf(aTHX_ dsv, """); + break; + default: + if (c < 0xD800) { + if (c < 32 || c > 127) { + Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c); + } + else { + Perl_sv_catpvf(aTHX_ dsv, "%c", c); + } + 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 *t = sv_newmortal(); + STRLEN n_a; + int unref = 0; + + sv_utf8_upgrade(t); + sv_setpvn(t, "", 0); + /* retry: */ + if (!sv) { + sv_catpv(t, "VOID=\"\""); + goto finish; + } + else if (sv == (SV*)0x55555555 || 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; + I32 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_RV: + sv_catpv(t, " RV=\""); + 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_PVBM: + sv_catpv(t, " BM=\""); + 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: + if (unref) { + while (unref--) + sv_catpv(t, ")"); + } + return SvPV(t, n_a); +} + +void +Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) +{ + if (!pm) { + Perl_xmldump_indent(aTHX_ level, file, "\n"); + return; + } + Perl_xmldump_indent(aTHX_ level, file, "precomp; + SV *tmpsv = newSV(0); + SvUTF8_on(tmpsv); + sv_catxmlpvn(tmpsv, s, strlen(s), 1); + Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n", + SvPVX(tmpsv)); + SvREFCNT_dec(tmpsv); + Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n", + (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP"); + } + else + Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n"); + if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) { + SV * const tmpsv = pmflags_description(pm); + Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + SvREFCNT_dec(tmpsv); + } + + level--; + if (pm->op_type != OP_PUSHRE && pm->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_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; + if (!o) + return; + sequence(o); + 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 (o->op_type == 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=\"%"UVf"\"", + (UV)CopLINE(cCOPo)); + if (CopSTASHPV(cCOPo)) + PerlIO_printf(file, " package=\"%s\"", + CopSTASHPV(cCOPo)); + if (cCOPo->cop_label) + PerlIO_printf(file, " label=\"%s\"", + cCOPo->cop_label); + } + } + 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 + if (o->op_flags) { + SV *tmpsv = newSVpvn("", 0); + 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; + } + if (o->op_flags & OPf_KIDS) + sv_catpv(tmpsv, ",KIDS"); + if (o->op_flags & OPf_PARENS) + sv_catpv(tmpsv, ",PARENS"); + if (o->op_flags & OPf_STACKED) + sv_catpv(tmpsv, ",STACKED"); + if (o->op_flags & OPf_REF) + sv_catpv(tmpsv, ",REF"); + if (o->op_flags & OPf_MOD) + sv_catpv(tmpsv, ",MOD"); + if (o->op_flags & OPf_SPECIAL) + sv_catpv(tmpsv, ",SPECIAL"); + PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + SvREFCNT_dec(tmpsv); + } + if (o->op_private) { + SV *tmpsv = newSVpvn("", 0); + if (PL_opargs[o->op_type] & OA_TARGLEX) { + if (o->op_private & OPpTARGET_MY) + sv_catpv(tmpsv, ",TARGET_MY"); + } + else if (o->op_type == OP_LEAVESUB || + o->op_type == OP_LEAVE || + o->op_type == OP_LEAVESUBLV || + o->op_type == OP_LEAVEWRITE) { + if (o->op_private & OPpREFCOUNTED) + sv_catpv(tmpsv, ",REFCOUNTED"); + } + else if (o->op_type == OP_AASSIGN) { + if (o->op_private & OPpASSIGN_COMMON) + sv_catpv(tmpsv, ",COMMON"); + } + else if (o->op_type == OP_SASSIGN) { + if (o->op_private & OPpASSIGN_BACKWARDS) + sv_catpv(tmpsv, ",BACKWARDS"); + } + else if (o->op_type == OP_TRANS) { + if (o->op_private & OPpTRANS_SQUASH) + sv_catpv(tmpsv, ",SQUASH"); + if (o->op_private & OPpTRANS_DELETE) + sv_catpv(tmpsv, ",DELETE"); + if (o->op_private & OPpTRANS_COMPLEMENT) + sv_catpv(tmpsv, ",COMPLEMENT"); + if (o->op_private & OPpTRANS_IDENTICAL) + sv_catpv(tmpsv, ",IDENTICAL"); + if (o->op_private & OPpTRANS_GROWS) + sv_catpv(tmpsv, ",GROWS"); + } + else if (o->op_type == OP_REPEAT) { + if (o->op_private & OPpREPEAT_DOLIST) + sv_catpv(tmpsv, ",DOLIST"); + } + else if (o->op_type == OP_ENTERSUB || + o->op_type == OP_RV2SV || + o->op_type == OP_GVSV || + o->op_type == OP_RV2AV || + o->op_type == OP_RV2HV || + o->op_type == OP_RV2GV || + o->op_type == OP_AELEM || + o->op_type == OP_HELEM ) + { + if (o->op_type == OP_ENTERSUB) { + if (o->op_private & OPpENTERSUB_AMPER) + sv_catpv(tmpsv, ",AMPER"); + if (o->op_private & OPpENTERSUB_DB) + sv_catpv(tmpsv, ",DB"); + if (o->op_private & OPpENTERSUB_HASTARG) + sv_catpv(tmpsv, ",HASTARG"); + if (o->op_private & OPpENTERSUB_NOPAREN) + sv_catpv(tmpsv, ",NOPAREN"); + if (o->op_private & OPpENTERSUB_INARGS) + sv_catpv(tmpsv, ",INARGS"); + if (o->op_private & OPpENTERSUB_NOMOD) + sv_catpv(tmpsv, ",NOMOD"); + } + else { + switch (o->op_private & 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 (o->op_private & OPpMAYBE_LVSUB) + sv_catpv(tmpsv, ",MAYBE_LVSUB"); + } + if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) { + if (o->op_private & OPpLVAL_DEFER) + sv_catpv(tmpsv, ",LVAL_DEFER"); + } + else { + if (o->op_private & HINT_STRICT_REFS) + sv_catpv(tmpsv, ",STRICT_REFS"); + if (o->op_private & OPpOUR_INTRO) + sv_catpv(tmpsv, ",OUR_INTRO"); + } + } + else if (o->op_type == OP_CONST) { + if (o->op_private & OPpCONST_BARE) + sv_catpv(tmpsv, ",BARE"); + if (o->op_private & OPpCONST_STRICT) + sv_catpv(tmpsv, ",STRICT"); + if (o->op_private & OPpCONST_ARYBASE) + sv_catpv(tmpsv, ",ARYBASE"); + if (o->op_private & OPpCONST_WARNING) + sv_catpv(tmpsv, ",WARNING"); + if (o->op_private & OPpCONST_ENTERED) + sv_catpv(tmpsv, ",ENTERED"); + } + else if (o->op_type == OP_FLIP) { + if (o->op_private & OPpFLIP_LINENUM) + sv_catpv(tmpsv, ",LINENUM"); + } + else if (o->op_type == OP_FLOP) { + if (o->op_private & OPpFLIP_LINENUM) + sv_catpv(tmpsv, ",LINENUM"); + } + else if (o->op_type == OP_RV2CV) { + if (o->op_private & OPpLVAL_INTRO) + sv_catpv(tmpsv, ",INTRO"); + } + else if (o->op_type == OP_GV) { + if (o->op_private & OPpEARLY_CV) + sv_catpv(tmpsv, ",EARLY_CV"); + } + else if (o->op_type == OP_LIST) { + if (o->op_private & OPpLIST_GUESSED) + sv_catpv(tmpsv, ",GUESSED"); + } + else if (o->op_type == OP_DELETE) { + if (o->op_private & OPpSLICE) + sv_catpv(tmpsv, ",SLICE"); + } + else if (o->op_type == OP_EXISTS) { + if (o->op_private & OPpEXISTS_SUB) + sv_catpv(tmpsv, ",EXISTS_SUB"); + } + else if (o->op_type == OP_SORT) { + if (o->op_private & OPpSORT_NUMERIC) + sv_catpv(tmpsv, ",NUMERIC"); + if (o->op_private & OPpSORT_INTEGER) + sv_catpv(tmpsv, ",INTEGER"); + if (o->op_private & OPpSORT_REVERSE) + sv_catpv(tmpsv, ",REVERSE"); + } + else if (o->op_type == OP_THREADSV) { + if (o->op_private & OPpDONE_SVREF) + sv_catpv(tmpsv, ",SVREF"); + } + else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) { + if (o->op_private & OPpOPEN_IN_RAW) + sv_catpv(tmpsv, ",IN_RAW"); + if (o->op_private & OPpOPEN_IN_CRLF) + sv_catpv(tmpsv, ",IN_CRLF"); + if (o->op_private & OPpOPEN_OUT_RAW) + sv_catpv(tmpsv, ",OUT_RAW"); + if (o->op_private & OPpOPEN_OUT_CRLF) + sv_catpv(tmpsv, ",OUT_CRLF"); + } + else if (o->op_type == OP_EXIT) { + if (o->op_private & OPpEXIT_VMSISH) + sv_catpv(tmpsv, ",EXIT_VMSISH"); + if (o->op_private & OPpHUSH_VMSISH) + sv_catpv(tmpsv, ",HUSH_VMSISH"); + } + else if (o->op_type == OP_DIE) { + if (o->op_private & OPpHUSH_VMSISH) + sv_catpv(tmpsv, ",HUSH_VMSISH"); + } + else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) { + if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS) + sv_catpv(tmpsv, ",FT_ACCESS"); + if (o->op_private & OPpFT_STACKED) + sv_catpv(tmpsv, ",FT_STACKED"); + } + if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) + sv_catpv(tmpsv, ",INTRO"); + if (SvCUR(tmpsv)) + S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1); + SvREFCNT_dec(tmpsv); + } + + switch (o->op_type) { + 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 *tmpsv1 = newSV(0); + SV *tmpsv2 = newSV(0); + char *s; + STRLEN len; + SvUTF8_on(tmpsv1); + SvUTF8_on(tmpsv2); + ENTER; + SAVEFREESV(tmpsv1); + SAVEFREESV(tmpsv2); + gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch); + 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_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_SETSTATE: + case OP_NEXTSTATE: + case OP_DBSTATE: + if (CopLINE(cCOPo)) + S_xmldump_attr(aTHX_ level, file, "line=\"%"UVf"\"", + (UV)CopLINE(cCOPo)); + if (CopSTASHPV(cCOPo)) + S_xmldump_attr(aTHX_ level, file, "package=\"%s\"", + CopSTASHPV(cCOPo)); + if (cCOPo->cop_label) + S_xmldump_attr(aTHX_ level, file, "label=\"%s\"", + cCOPo->cop_label); + 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) { + SV *tmpsv = newSVpvn("", 0); + MADPROP* mp = o->op_madprop; + sv_utf8_upgrade(tmpsv); + if (!contents) { + contents = 1; + PerlIO_printf(file, ">\n"); + } + Perl_xmldump_indent(aTHX_ level, file, "\n"); + level++; + while (mp) { + char tmp = mp->mad_key; + sv_setpvn(tmpsv,"\"",1); + if (tmp) + sv_catxmlpvn(tmpsv, &tmp, 1, 0); + 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, (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(tmpsv); + } + + switch (o->op_type) { + 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) +{ + do_op_xmldump(0, PL_xmlfp, o); +} +#endif + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */