X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=2930a58ff7a6af3d982402dcb1a105c5c996720a;hb=e670e57a01f4348af67815ccc0b2b168b078d7bd;hp=ddeacf4da3c7907fd7c8bfdf9cc879cb6bf413d9;hpb=93524f2be2dba9389167a137d53a88545322b55e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/dump.c b/dump.c index ddeacf4..2930a58 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,6 +24,8 @@ #define PERL_IN_DUMP_C #include "perl.h" #include "regcomp.h" +#include "proto.h" + #define Sequence PL_op_sequence @@ -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)) @@ -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); } @@ -154,7 +160,7 @@ char * Perl_sv_peek(pTHX_ SV *sv) { dVAR; - SV *t = sv_newmortal(); + SV * const t = sv_newmortal(); int unref = 0; sv_setpvn(t, "", 0); @@ -299,7 +305,7 @@ Perl_sv_peek(pTHX_ SV *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_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); @@ -359,7 +365,7 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) op_dump(pm->op_pmreplroot); } if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) { - SV *tmpsv = newSVpvn("", 0); + SV *tmpsv = newSVpvs(""); if (pm->op_pmdynflags & PMdf_USED) sv_catpv(tmpsv, ",USED"); if (pm->op_pmdynflags & PMdf_TAINTED) @@ -402,22 +408,20 @@ 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 const OP *o) +S_sequence(pTHX_ register const OP *o) { dVAR; SV *op; const char *key; STRLEN len; - const OP *oldop = 0; + const OP *oldop = NULL; OP *l; if (!o) return; - op = newSVuv(PTR2UV(o)); - key = SvPV_const(op, len); - if (hv_exists(Sequence, key, len)) - return; + if (!Sequence) + Sequence = newHV(); for (; o; o = o->op_next) { op = newSVuv(PTR2UV(o)); @@ -458,7 +462,7 @@ sequence(pTHX_ register const OP *o) 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: @@ -466,13 +470,13 @@ sequence(pTHX_ register const OP *o) 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: @@ -481,7 +485,7 @@ sequence(pTHX_ register const OP *o) 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: @@ -496,7 +500,7 @@ sequence(pTHX_ register const OP *o) } STATIC UV -sequence_num(pTHX_ const OP *o) +S_sequence_num(pTHX_ const OP *o) { dVAR; SV *op, @@ -515,10 +519,10 @@ 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 @@ -528,7 +532,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const 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) { @@ -555,7 +559,7 @@ 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 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"); @@ -586,7 +590,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) 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"); @@ -802,17 +806,17 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const 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; @@ -824,7 +828,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const 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; @@ -941,7 +945,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 " 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"; @@ -984,7 +988,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 { int n; - const char *name = 0; + 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; @@ -1023,7 +1027,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 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); } @@ -1097,6 +1101,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; @@ -1190,7 +1195,7 @@ 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,"); @@ -1381,7 +1386,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) @@ -1438,9 +1444,18 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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); @@ -1449,7 +1464,7 @@ 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_const(keysv, len); @@ -1472,12 +1487,26 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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, " 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)); 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); + { + SV *constant = cv_const_sv((CV *)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)); @@ -1526,7 +1555,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)); @@ -1563,12 +1591,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"); @@ -1607,6 +1637,7 @@ Perl_runops_debug(pTHX) I32 Perl_debop(pTHX_ const OP *o) { + dVAR; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -1655,6 +1686,7 @@ Perl_debop(pTHX_ const 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; @@ -1671,6 +1703,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", @@ -1680,16 +1713,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;