X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=650c1ab53a6c0f51c9d3dd146913ca8ea5a842e3;hb=06dc7ac6fa597f9446b4a27a32d667bbcbde0453;hp=bf885904fb3788b23ff7a7886baceb32d1860d22;hpb=b5b10606725dc42adb2909e77c05473776295195;p=p5sagit%2Fp5-mst-13.2.git diff --git a/dump.c b/dump.c index bf88590..650c1ab 100644 --- a/dump.c +++ b/dump.c @@ -420,6 +420,11 @@ S_sequence(pTHX_ register const OP *o) if (!o) return; +#ifdef PERL_MAD + if (o->op_next == 0) + return; +#endif + if (!Sequence) Sequence = newHV(); @@ -437,6 +442,10 @@ S_sequence(pTHX_ register const OP *o) } goto nothin; case OP_NULL: +#ifdef PERL_MAD + if (o == o->op_next) + return; +#endif if (oldop && o->op_next) continue; break; @@ -760,6 +769,49 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) SvREFCNT_dec(tmpsv); } +#ifdef PERL_MAD + if (PL_madskills && o->op_madprop) { + SV *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: case OP_GVSV: @@ -772,6 +824,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) SV *tmpsv = newSV(0); ENTER; SAVEFREESV(tmpsv); +#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)); @@ -894,7 +951,6 @@ static const struct { const char type; const char *name; } magic_names[] = { { PERL_MAGIC_sv, "sv(\\0)" }, { PERL_MAGIC_arylen, "arylen(#)" }, { PERL_MAGIC_rhash, "rhash(%)" }, - { PERL_MAGIC_glob, "glob(*)" }, { PERL_MAGIC_pos, "pos(.)" }, { PERL_MAGIC_symtab, "symtab(:)" }, { PERL_MAGIC_backref, "backref(<)" }, @@ -956,7 +1012,6 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 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"; @@ -1178,7 +1233,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) @@ -1202,8 +1258,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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; @@ -1283,8 +1338,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SvREFCNT_dec(d); return; } - if (type == SVt_IV || (type >= SVt_PVIV && type != SVt_PVAV - && type != SVt_PVHV && type != SVt_PVCV)) { + 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_OLD_COPY_ON_WRITE || SvIsCOW(sv) @@ -1304,7 +1360,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_putc(file, '\n'); } if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && type != SVt_PVFM) + && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)) || type == SVt_NV) { STORE_NUMERIC_LOCAL_SET_STANDARD(); /* %Vg doesn't work? --jhi */ @@ -1324,7 +1380,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SvREFCNT_dec(d); return; } - if (type <= SVt_PVLV) { + 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)) @@ -1552,6 +1608,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; @@ -1658,6 +1716,11 @@ Perl_debop(pTHX_ const OP *o) case OP_GV: if (cGVOPo_gv) { 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); @@ -1744,6 +1807,914 @@ 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; + 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 *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_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