diff options
| -rw-r--r-- | MANIFEST | 4 | ||||
| -rw-r--r-- | dump.c | 978 | ||||
| -rw-r--r-- | embed.h | 32 | ||||
| -rw-r--r-- | embedvar.h | 5 | ||||
| -rw-r--r-- | ext/Devel/Peek/Changes | 64 | ||||
| -rw-r--r-- | ext/Devel/Peek/Makefile.PL | 11 | ||||
| -rw-r--r-- | ext/Devel/Peek/Peek.pm | 430 | ||||
| -rw-r--r-- | ext/Devel/Peek/Peek.xs | 202 | ||||
| -rw-r--r-- | global.sym | 16 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | objXSUB.h | 36 | ||||
| -rw-r--r-- | perl.c | 4 | ||||
| -rw-r--r-- | perl.h | 3 | ||||
| -rw-r--r-- | proto.h | 17 | ||||
| -rw-r--r-- | sv.c | 420 | ||||
| -rw-r--r-- | sv.h | 4 | ||||
| -rw-r--r-- | thrdvar.h | 1 | ||||
| -rw-r--r-- | win32/GenCAPI.pl | 3 | ||||
| -rw-r--r-- | win32/Makefile | 13 | ||||
| -rw-r--r-- | win32/makefile.mk | 12 |
20 files changed, 1669 insertions, 587 deletions
@@ -196,6 +196,10 @@ ext/Data/Dumper/Dumper.pm Data pretty printer, module ext/Data/Dumper/Dumper.xs Data pretty printer, externals ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer ext/Data/Dumper/Todo Data pretty printer, futures +ext/Devel/Peek/Changes Data debugging tool, changelog +ext/Devel/Peek/Makefile.PL Data debugging tool, makefile writer +ext/Devel/Peek/Peek.pm Data debugging tool, module and pod +ext/Devel/Peek/Peek.xs Data debugging tool, externals ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro @@ -15,26 +15,35 @@ #include "EXTERN.h" #include "perl.h" -#ifndef PERL_OBJECT -static void dump(char *pat, ...); -#endif /* PERL_OBJECT */ +#ifndef DBL_DIG +#define DBL_DIG 15 /* A guess that works lots of places */ +#endif + +void +dump_indent(I32 level, PerlIO *file, const char* pat, ...) +{ + dTHR; + va_list args; + + va_start(args, pat); + PerlIO_printf(file, "%*s", level*PL_dumpindent, ""); + PerlIO_vprintf(file, pat, args); + va_end(args); +} void dump_all(void) { -#ifdef DEBUGGING dTHR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) - dump_op(PL_main_root); + op_dump(PL_main_root); dump_packsubs(PL_defstash); -#endif /* DEBUGGING */ } void dump_packsubs(HV *stash) { -#ifdef DEBUGGING dTHR; I32 i; HE *entry; @@ -56,78 +65,326 @@ dump_packsubs(HV *stash) dump_packsubs(hv); /* nested package */ } } -#endif /* DEBUGGING */ } void dump_sub(GV *gv) { -#ifdef DEBUGGING SV *sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - dump("\nSUB %s = ", SvPVX(sv)); + dump_indent(0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv)); if (CvXSUB(GvCV(gv))) - dump("(xsub 0x%x %d)\n", + dump_indent(0, Perl_debug_log, "(xsub 0x%x %d)\n", (long)CvXSUB(GvCV(gv)), CvXSUBANY(GvCV(gv)).any_i32); else if (CvROOT(GvCV(gv))) - dump_op(CvROOT(GvCV(gv))); + op_dump(CvROOT(GvCV(gv))); else - dump("<undef>\n"); -#endif /* DEBUGGING */ + dump_indent(0, Perl_debug_log, "<undef>\n"); } void dump_form(GV *gv) { -#ifdef DEBUGGING SV *sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - dump("\nFORMAT %s = ", SvPVX(sv)); + dump_indent(0, Perl_debug_log, "\nFORMAT %s = ", SvPVX(sv)); if (CvROOT(GvFORM(gv))) - dump_op(CvROOT(GvFORM(gv))); + op_dump(CvROOT(GvFORM(gv))); else - dump("<undef>\n"); -#endif /* DEBUGGING */ + dump_indent(0, Perl_debug_log, "<undef>\n"); } void dump_eval(void) { -#ifdef DEBUGGING - dump_op(PL_eval_root); -#endif /* DEBUGGING */ + op_dump(PL_eval_root); +} + +char * +pv_display(SV *sv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + int truncated = 0; + int nul_terminated = len > cur && pv[cur] == '\0'; + + sv_setpvn(sv, "\"", 1); + for (; cur--; pv++) { + if (pvlim && SvCUR(sv) >= pvlim) { + truncated++; + break; + } + if (isPRINT(*pv)) { + switch (*pv) { + case '\t': sv_catpvn(sv, "\\t", 2); break; + case '\n': sv_catpvn(sv, "\\n", 2); break; + case '\r': sv_catpvn(sv, "\\r", 2); break; + case '\f': sv_catpvn(sv, "\\f", 2); break; + case '"': sv_catpvn(sv, "\\\"", 2); break; + case '\\': sv_catpvn(sv, "\\\\", 2); break; + default: sv_catpvn(sv, pv, 1); break; + } + } + else { + if (cur && isDIGIT(*(pv+1))) + sv_catpvf(sv, "\\%03o", *pv); + else + sv_catpvf(sv, "\\%o", *pv); + } + } + sv_catpvn(sv, "\"", 1); + if (truncated) + sv_catpvn(sv, "...", 3); + if (nul_terminated) + sv_catpvn(sv, "\\0", 2); + + return SvPVX(sv); +} + +char * +sv_peek(SV *sv) +{ + SV *t = sv_newmortal(); + STRLEN prevlen; + int unref = 0; + + 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) { + if (sv == &PL_sv_undef) { + sv_catpv(t, "SV_UNDEF"); + 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"); + 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 { + sv_catpv(t, "SV_YES"); + 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; + } + sv_catpv(t, ":"); + } + else if (SvREFCNT(sv) == 0) { + sv_catpv(t, "("); + unref++; + } + if (SvROK(sv)) { + sv_catpv(t, "\\"); + if (SvCUR(t) + unref > 10) { + SvCUR(t) = unref + 3; + *SvEND(t) = '\0'; + sv_catpv(t, "..."); + goto finish; + } + sv = (SV*)SvRV(sv); + goto retry; + } + switch (SvTYPE(sv)) { + default: + sv_catpv(t, "FREED"); + goto finish; + + case SVt_NULL: + sv_catpv(t, "UNDEF"); + 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)) + sv_catpvf(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_catpv(t, "(null)"); + else { + SV *tmp = newSVpv("", 0); + sv_catpv(t, "("); + if (SvOOK(sv)) + sv_catpvf(t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); + sv_catpvf(t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127)); + SvREFCNT_dec(tmp); + } + } + else if (SvNOKp(sv)) { + SET_NUMERIC_STANDARD(); + sv_catpvf(t, "(%g)",SvNVX(sv)); + } + else if (SvIOKp(sv)) + sv_catpvf(t, "(%ld)",(long)SvIVX(sv)); + else + sv_catpv(t, "()"); + + finish: + if (unref) { + while (unref--) + sv_catpv(t, ")"); + } + return SvPV(t, PL_na); +} + +void +do_pmop_dump(I32 level, PerlIO *file, PMOP *pm) +{ + char ch; + + if (!pm) { + dump_indent(level, file, "{}\n"); + return; + } + dump_indent(level, file, "{\n"); + level++; + if (pm->op_pmflags & PMf_ONCE) + ch = '?'; + else + ch = '/'; + if (pm->op_pmregexp) + dump_indent(level, file, "PMf_PRE %c%s%c%s\n", + ch, pm->op_pmregexp->precomp, ch, + (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); + else + dump_indent(level, file, "PMf_PRE (RUNTIME)\n"); + if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) { + dump_indent(level, file, "PMf_REPL = "); + op_dump(pm->op_pmreplroot); + } + if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) { + SV *tmpsv = newSVpv("", 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->op_pmregexp && pm->op_pmregexp->check_substr + && !(pm->op_pmregexp->reganch & ROPT_NOSCAN)) + sv_catpv(tmpsv, ",SCANFIRST"); + if (pm->op_pmregexp && pm->op_pmregexp->check_substr + && pm->op_pmregexp->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"); + dump_indent(level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + SvREFCNT_dec(tmpsv); + } + + dump_indent(level-1, file, "}\n"); +} + +void +pmop_dump(PMOP *pm) +{ + do_pmop_dump(0, Perl_debug_log, pm); } void -dump_op(OP *o) +do_op_dump(I32 level, PerlIO *file, OP *o) { -#ifdef DEBUGGING - dump("{\n"); + dTHR; + dump_indent(level, file, "{\n"); + level++; if (o->op_seq) - PerlIO_printf(Perl_debug_log, "%-4d", o->op_seq); + PerlIO_printf(file, "%-4d", o->op_seq); else - PerlIO_printf(Perl_debug_log, " "); - dump("TYPE = %s ===> ", PL_op_name[o->op_type]); + PerlIO_printf(file, " "); + PerlIO_printf(file, "%*sTYPE = %s ===> ", PL_dumpindent*level-4, "", PL_op_name[o->op_type]); if (o->op_next) { if (o->op_seq) - PerlIO_printf(Perl_debug_log, "%d\n", o->op_next->op_seq); + PerlIO_printf(file, "%d\n", o->op_next->op_seq); else - PerlIO_printf(Perl_debug_log, "(%d)\n", o->op_next->op_seq); + PerlIO_printf(file, "(%d)\n", o->op_next->op_seq); } else - PerlIO_printf(Perl_debug_log, "DONE\n"); - PL_dumplvl++; + PerlIO_printf(file, "DONE\n"); if (o->op_targ) { if (o->op_type == OP_NULL) - dump(" (was %s)\n", PL_op_name[o->op_targ]); + dump_indent(level, file, " (was %s)\n", PL_op_name[o->op_targ]); else - dump("TARG = %d\n", o->op_targ); + dump_indent(level, file, "TARG = %d\n", o->op_targ); } #ifdef DUMPADDR - dump("ADDR = 0x%lx => 0x%lx\n",o, o->op_next); + dump_indent(level, file, "ADDR = 0x%lx => 0x%lx\n",o, o->op_next); #endif if (o->op_flags) { SV *tmpsv = newSVpv("", 0); @@ -157,7 +414,7 @@ dump_op(OP *o) sv_catpv(tmpsv, ",MOD"); if (o->op_flags & OPf_SPECIAL) sv_catpv(tmpsv, ",SPECIAL"); - dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + dump_indent(level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); SvREFCNT_dec(tmpsv); } if (o->op_private) { @@ -231,7 +488,7 @@ dump_op(OP *o) if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) sv_catpv(tmpsv, ",INTRO"); if (SvCUR(tmpsv)) - dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1); + dump_indent(level, file, "PRIVATE = (%s)\n", SvPVX(tmpsv) + 1); SvREFCNT_dec(tmpsv); } @@ -243,66 +500,66 @@ dump_op(OP *o) ENTER; SAVEFREESV(tmpsv); gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch); - dump("GV = %s\n", SvPV(tmpsv, PL_na)); + dump_indent(level, file, "GV = %s\n", SvPV(tmpsv, PL_na)); LEAVE; } else - dump("GV = NULL\n"); + dump_indent(level, file, "GV = NULL\n"); break; case OP_CONST: - dump("SV = %s\n", SvPEEK(cSVOPo->op_sv)); + dump_indent(level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv)); break; case OP_NEXTSTATE: case OP_DBSTATE: if (cCOPo->cop_line) - dump("LINE = %d\n",cCOPo->cop_line); + dump_indent(level, file, "LINE = %d\n",cCOPo->cop_line); if (cCOPo->cop_label) - dump("LABEL = \"%s\"\n",cCOPo->cop_label); + dump_indent(level, file, "LABEL = \"%s\"\n",cCOPo->cop_label); break; case OP_ENTERLOOP: - dump("REDO ===> "); + dump_indent(level, file, "REDO ===> "); if (cLOOPo->op_redoop) - PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq); + PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq); else - PerlIO_printf(Perl_debug_log, "DONE\n"); - dump("NEXT ===> "); + PerlIO_printf(file, "DONE\n"); + dump_indent(level, file, "NEXT ===> "); if (cLOOPo->op_nextop) - PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq); + PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq); else - PerlIO_printf(Perl_debug_log, "DONE\n"); - dump("LAST ===> "); + PerlIO_printf(file, "DONE\n"); + dump_indent(level, file, "LAST ===> "); if (cLOOPo->op_lastop) - PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq); + PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq); else - PerlIO_printf(Perl_debug_log, "DONE\n"); + PerlIO_printf(file, "DONE\n"); break; case OP_COND_EXPR: - dump("TRUE ===> "); + dump_indent(level, file, "TRUE ===> "); if (cCONDOPo->op_true) - PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq); + PerlIO_printf(file, "%d\n", cCONDOPo->op_true->op_seq); else - PerlIO_printf(Perl_debug_log, "DONE\n"); - dump("FALSE ===> "); + PerlIO_printf(file, "DONE\n"); + dump_indent(level, file, "FALSE ===> "); if (cCONDOPo->op_false) - PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq); + PerlIO_printf(file, "%d\n", cCONDOPo->op_false->op_seq); else - PerlIO_printf(Perl_debug_log, "DONE\n"); + PerlIO_printf(file, "DONE\n"); break; case OP_MAPWHILE: case OP_GREPWHILE: case OP_OR: case OP_AND: - dump("OTHER ===> "); + dump_indent(level, file, "OTHER ===> "); if (cLOGOPo->op_other) - PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq); + PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq); else - PerlIO_printf(Perl_debug_log, "DONE\n"); + PerlIO_printf(file, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: case OP_QR: case OP_SUBST: - dump_pm(cPMOPo); + do_pmop_dump(level, file, cPMOPo); break; default: break; @@ -310,17 +567,20 @@ dump_op(OP *o) if (o->op_flags & OPf_KIDS) { OP *kid; for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) - dump_op(kid); + do_op_dump(level, file, kid); } - PL_dumplvl--; - dump("}\n"); -#endif /* DEBUGGING */ + dump_indent(level-1, file, "}\n"); +} + +void +op_dump(OP *o) +{ + do_op_dump(0, Perl_debug_log, o); } void -dump_gv(GV *gv) +gv_dump(GV *gv) { -#ifdef DEBUGGING SV *sv; if (!gv) { @@ -328,95 +588,535 @@ dump_gv(GV *gv) return; } sv = sv_newmortal(); - PL_dumplvl++; PerlIO_printf(Perl_debug_log, "{\n"); gv_fullname3(sv, gv, Nullch); - dump("GV_NAME = %s", SvPVX(sv)); + dump_indent(1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv)); if (gv != GvEGV(gv)) { gv_efullname3(sv, GvEGV(gv), Nullch); - dump("-> %s", SvPVX(sv)); + dump_indent(1, Perl_debug_log, "-> %s", SvPVX(sv)); } - dump("\n"); - PL_dumplvl--; - dump("}\n"); -#endif /* DEBUGGING */ + PerlIO_putc(Perl_debug_log, '\n'); + dump_indent(0, Perl_debug_log, "}\n"); } void -dump_pm(PMOP *pm) +do_magic_dump(I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { -#ifdef DEBUGGING - char ch; + for (; mg; mg = mg->mg_moremagic) { + dump_indent(level, file, " MAGIC = 0x%lx\n", (long)mg); + if (mg->mg_virtual) { + MGVTBL *v = mg->mg_virtual; + char *s = 0; + if (v == &PL_vtbl_sv) s = "sv"; + else if (v == &PL_vtbl_env) s = "env"; + else if (v == &PL_vtbl_envelem) s = "envelem"; + else if (v == &PL_vtbl_sig) s = "sig"; + else if (v == &PL_vtbl_sigelem) s = "sigelem"; + else if (v == &PL_vtbl_pack) s = "pack"; + else if (v == &PL_vtbl_packelem) s = "packelem"; + 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"; + else if (v == &PL_vtbl_substr) s = "substr"; + else if (v == &PL_vtbl_vec) s = "vec"; + else if (v == &PL_vtbl_pos) s = "pos"; + else if (v == &PL_vtbl_bm) s = "bm"; + else if (v == &PL_vtbl_fm) s = "fm"; + else if (v == &PL_vtbl_uvar) s = "uvar"; + else if (v == &PL_vtbl_defelem) s = "defelem"; +#ifdef USE_LOCALE_COLLATE + else if (v == &PL_vtbl_collxfrm) s = "collxfrm"; +#endif +#ifdef OVERLOAD + else if (v == &PL_vtbl_amagic) s = "amagic"; + else if (v == &PL_vtbl_amagicelem) s = "amagicelem"; +#endif + if (s) + dump_indent(level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); + else + dump_indent(level, file, " MG_VIRTUAL = 0x%lx\n", (long)v); + } + else + dump_indent(level, file, " MG_VIRTUAL = 0\n"); - if (!pm) { - dump("{}\n"); - return; + if (mg->mg_private) + dump_indent(level, file, " MG_PRIVATE = %d\n", mg->mg_private); + + if (isPRINT(mg->mg_type)) + dump_indent(level, file, " MG_TYPE = '%c'\n", mg->mg_type); + else + dump_indent(level, file, " MG_TYPE = '\\%o'\n", mg->mg_type); + + if (mg->mg_flags) { + dump_indent(level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); + if (mg->mg_flags & MGf_TAINTEDDIR) + dump_indent(level, file, " TAINTEDDIR\n"); + if (mg->mg_flags & MGf_REFCOUNTED) + dump_indent(level, file, " REFCOUNTED\n"); + if (mg->mg_flags & MGf_GSKIP) + dump_indent(level, file, " GSKIP\n"); + if (mg->mg_flags & MGf_MINMATCH) + dump_indent(level, file, " MINMATCH\n"); + } + if (mg->mg_obj) { + dump_indent(level, file, " MG_OBJ = 0x%lx\n", (long)mg->mg_obj); + if (mg->mg_flags & MGf_REFCOUNTED) + do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ + } + if (mg->mg_len) + dump_indent(level, file, " MG_LEN = %d\n", mg->mg_len); + if (mg->mg_ptr) { + dump_indent(level, file, " MG_PTR = 0x%lx", (long)mg->mg_ptr); + if (mg->mg_len >= 0) { + SV *sv = newSVpv("", 0); + PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); + SvREFCNT_dec(sv); + } + else if (mg->mg_len == HEf_SVKEY) { + PerlIO_puts(file, " => HEf_SVKEY\n"); + do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ + continue; + } + else + PerlIO_puts(file, " ???? - please notify IZ"); + PerlIO_putc(file, '\n'); + } } - dump("{\n"); - PL_dumplvl++; - if (pm->op_pmflags & PMf_ONCE) - ch = '?'; +} + +void +magic_dump(MAGIC *mg) +{ + do_magic_dump(0, Perl_debug_log, mg, 0, 0, 0, 0); +} + +void +do_hv_dump(I32 level, PerlIO *file, char *name, HV *sv) +{ + dump_indent(level, file, "%s = 0x%lx", name, (long)sv); + if (sv && HvNAME(sv)) + PerlIO_printf(file, "\t\"%s\"\n", HvNAME(sv)); else - ch = '/'; - if (pm->op_pmregexp) - dump("PMf_PRE %c%s%c%s\n", - ch, pm->op_pmregexp->precomp, ch, - (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); + PerlIO_putc(file, '\n'); +} + +void +do_gv_dump(I32 level, PerlIO *file, char *name, GV *sv) +{ + dump_indent(level, file, "%s = 0x%lx", name, (long)sv); + if (sv && GvNAME(sv)) + PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv)); else - dump("PMf_PRE (RUNTIME)\n"); - if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) { - dump("PMf_REPL = "); - dump_op(pm->op_pmreplroot); + PerlIO_putc(file, '\n'); +} + +void +do_gvgv_dump(I32 level, PerlIO *file, char *name, GV *sv) +{ + dump_indent(level, file, "%s = 0x%lx", name, (long)sv); + if (sv && GvNAME(sv)) { + PerlIO_printf(file, "\t\""); + if (GvSTASH(sv) && HvNAME(GvSTASH(sv))) + PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv))); + PerlIO_printf(file, "%s\"\n", GvNAME(sv)); } - if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) { - SV *tmpsv = newSVpv("", 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->op_pmregexp && pm->op_pmregexp->check_substr - && !(pm->op_pmregexp->reganch & ROPT_NOSCAN)) - sv_catpv(tmpsv, ",SCANFIRST"); - if (pm->op_pmregexp && pm->op_pmregexp->check_substr - && pm->op_pmregexp->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"); - dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); - SvREFCNT_dec(tmpsv); + else + PerlIO_putc(file, '\n'); +} + +void +do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) +{ + dTHR; + SV *d = sv_newmortal(); + char *s; + U32 flags; + U32 type; + + if (!sv) { + dump_indent(level, file, "SV = 0\n"); + return; } + + flags = SvFLAGS(sv); + type = SvTYPE(sv); - PL_dumplvl--; - dump("}\n"); -#endif /* DEBUGGING */ -} + sv_setpvf(d, "(0x%lx) at 0x%lx\n%*s REFCNT = %ld\n%*s FLAGS = (", + (unsigned long)SvANY(sv), (unsigned long)sv, + PL_dumpindent*level, "", (long)SvREFCNT(sv), + PL_dumpindent*level, ""); + if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,"); + if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); + if (flags & SVs_PADMY) sv_catpv(d, "PADMY,"); + if (flags & SVs_TEMP) sv_catpv(d, "TEMP,"); + if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,"); + if (flags & SVs_GMG) sv_catpv(d, "GMG,"); + if (flags & SVs_SMG) sv_catpv(d, "SMG,"); + if (flags & SVs_RMG) sv_catpv(d, "RMG,"); -STATIC void -dump(char *pat,...) -{ -#ifdef DEBUGGING - I32 i; - va_list args; + if (flags & SVf_IOK) sv_catpv(d, "IOK,"); + if (flags & SVf_NOK) sv_catpv(d, "NOK,"); + if (flags & SVf_POK) sv_catpv(d, "POK,"); + if (flags & SVf_ROK) sv_catpv(d, "ROK,"); + if (flags & SVf_OOK) sv_catpv(d, "OOK,"); + if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); + if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); - va_start(args, pat); - for (i = PL_dumplvl*4; i; i--) - (void)PerlIO_putc(Perl_debug_log,' '); - PerlIO_vprintf(Perl_debug_log,pat,args); - va_end(args); -#endif /* DEBUGGING */ +#ifdef OVERLOAD + if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,"); +#endif /* 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,"); + + switch (type) { + case SVt_PVCV: + case SVt_PVFM: + if (CvANON(sv)) sv_catpv(d, "ANON,"); + if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); + if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); + if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); + if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); + break; + case SVt_PVHV: + if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); + if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); + break; + case SVt_PVGV: + if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); + if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); + if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); + if (GvIMPORTED(sv)) { + sv_catpv(d, "IMPORT"); + if (GvIMPORTED(sv) == GVf_IMPORTED) + sv_catpv(d, "ALL,"); + else { + sv_catpv(d, "("); + if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV"); + if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV"); + if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV"); + if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV"); + sv_catpv(d, " ),"); + } + } + case SVt_PVBM: + if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); + if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); + break; + } + + if (*(SvEND(d) - 1) == ',') + SvPVX(d)[--SvCUR(d)] = '\0'; + sv_catpv(d, ")"); + s = SvPVX(d); + + dump_indent(level, file, "SV = "); + switch (type) { + case SVt_NULL: + PerlIO_printf(file, "NULL%s\n", s); + return; + case SVt_IV: + PerlIO_printf(file, "IV%s\n", s); + break; + case SVt_NV: + PerlIO_printf(file, "NV%s\n", s); + break; + case SVt_RV: + PerlIO_printf(file, "RV%s\n", s); + break; + case SVt_PV: + PerlIO_printf(file, "PV%s\n", s); + break; + case SVt_PVIV: + PerlIO_printf(file, "PVIV%s\n", s); + break; + case SVt_PVNV: + PerlIO_printf(file, "PVNV%s\n", s); + break; + case SVt_PVBM: + PerlIO_printf(file, "PVBM%s\n", s); + break; + case SVt_PVMG: + PerlIO_printf(file, "PVMG%s\n", s); + break; + case SVt_PVLV: + PerlIO_printf(file, "PVLV%s\n", s); + break; + case SVt_PVAV: + PerlIO_printf(file, "PVAV%s\n", s); + break; + case SVt_PVHV: + PerlIO_printf(file, "PVHV%s\n", s); + break; + case SVt_PVCV: + PerlIO_printf(file, "PVCV%s\n", s); + break; + case SVt_PVGV: + PerlIO_printf(file, "PVGV%s\n", s); + break; + case SVt_PVFM: + PerlIO_printf(file, "PVFM%s\n", s); + break; + case SVt_PVIO: + PerlIO_printf(file, "PVIO%s\n", s); + break; + default: + PerlIO_printf(file, "UNKNOWN(0x%x) %s\n", type, s); + return; + } + if (type >= SVt_PVIV || type == SVt_IV) { + dump_indent(level, file, " IV = %ld", (long)SvIVX(sv)); + if (SvOOK(sv)) + PerlIO_printf(file, " (OFFSET)"); + PerlIO_putc(file, '\n'); + } + if (type >= SVt_PVNV || type == SVt_NV) { + SET_NUMERIC_STANDARD(); + dump_indent(level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); + } + if (SvROK(sv)) { + dump_indent(level, file, " RV = 0x%lx\n", (long)SvRV(sv)); + if (nest < maxnest) + do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); + return; + } + if (type < SVt_PV) + return; + if (type <= SVt_PVLV) { + if (SvPVX(sv)) { + dump_indent(level, file," PV = 0x%lx ", (long)SvPVX(sv)); + if (SvOOK(sv)) + PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); + PerlIO_printf(file, "%s\n", pv_display(d, SvPVX(sv), SvCUR(sv), SvLEN(sv), pvlim)); + dump_indent(level, file, " CUR = 0\n", (long)SvCUR(sv)); + dump_indent(level, file, " LEN = 0\n", (long)SvLEN(sv)); + } + else + dump_indent(level, file, " PV = 0\n"); + } + if (type >= SVt_PVMG) { + if (SvMAGIC(sv)) + do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim); + if (SvSTASH(sv)) + do_hv_dump(level, file, " STASH", SvSTASH(sv)); + } + switch (type) { + case SVt_PVLV: + dump_indent(level, file, " TYPE = %c\n", LvTYPE(sv)); + dump_indent(level, file, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); + dump_indent(level, file, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); + dump_indent(level, file, " TARG = 0x%lx\n", (long)LvTARG(sv)); + /* XXX level+1 ??? */ + do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim); + break; + case SVt_PVAV: + dump_indent(level, file, " ARRAY = 0x%lx", (long)AvARRAY(sv)); + if (AvARRAY(sv) != AvALLOC(sv)) { + PerlIO_printf(file, " (offset=%d)\n", (AvARRAY(sv) - AvALLOC(sv))); + dump_indent(level, file, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); + } + else + PerlIO_putc(file, '\n'); + dump_indent(level, file, " FILL = %ld\n", (long)AvFILLp(sv)); + dump_indent(level, file, " MAX = %ld\n", (long)AvMAX(sv)); + dump_indent(level, file, " ARYLEN = 0x%lx\n", (long)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"); + dump_indent(level, file, " FLAGS = (%s)\n", SvCUR(d) ? SvPVX(d) + 1 : ""); + if (nest < maxnest && av_len((AV*)sv) >= 0) { + int count; + for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) { + SV** elt = av_fetch((AV*)sv,count,0); + + dump_indent(level + 1, file, "Elt No. %ld\n", (long)count); + if (elt) + do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim); + } + } + break; + case SVt_PVHV: + dump_indent(level, file, " ARRAY = 0x%lx",(long)HvARRAY(sv)); + if (HvARRAY(sv) && HvKEYS(sv)) { + /* Show distribution of HEs in the ARRAY */ + int freq[200]; +#define FREQ_MAX (sizeof freq / sizeof freq[0] - 1) + int i; + int max = 0; + U32 pow2 = 2, keys = HvKEYS(sv); + double theoret, sum = 0; + + PerlIO_printf(file, " ("); + Zero(freq, FREQ_MAX + 1, int); + for (i = 0; i <= HvMAX(sv); i++) { + HE* h; int count = 0; + for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) + count++; + if (count > FREQ_MAX) + count = FREQ_MAX; + freq[count]++; + if (max < count) + max = count; + } + for (i = 0; i <= max; i++) { + if (freq[i]) { + PerlIO_printf(file, "%d%s:%d", i, + (i == FREQ_MAX) ? "+" : "", + freq[i]); + if (i != max) + PerlIO_printf(file, ", "); + } + } + PerlIO_putc(file, ')'); + /* Now calculate quality wrt theoretical value */ + for (i = max; i > 0; i--) { /* Precision: count down. */ + sum += freq[i] * i * i; + } + while (keys = keys >> 1) + pow2 = pow2 << 1; + /* Approximate by Poisson distribution */ + theoret = HvKEYS(sv); + theoret += theoret * theoret/pow2; + PerlIO_putc(file, '\n'); + dump_indent(level, file, " hash quality = %.1f%%", theoret/sum*100); + } + PerlIO_putc(file, '\n'); + dump_indent(level, file, " KEYS = %ld\n", (long)HvKEYS(sv)); + dump_indent(level, file, " FILL = %ld\n", (long)HvFILL(sv)); + dump_indent(level, file, " MAX = %ld\n", (long)HvMAX(sv)); + dump_indent(level, file, " RITER = %ld\n", (long)HvRITER(sv)); + dump_indent(level, file, " EITER = 0x%lx\n",(long) HvEITER(sv)); + if (HvPMROOT(sv)) + dump_indent(level, file, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); + if (HvNAME(sv)) + dump_indent(level, file, " NAME = \"%s\"\n", HvNAME(sv)); + if (nest < maxnest && !HvEITER(sv)) { /* Try to preserve iterator */ + HE *he; + HV *hv = (HV*)sv; + int count = maxnest - nest; + + hv_iterinit(hv); + while ((he = hv_iternext(hv)) && count--) { + SV *elt; + char *key; + I32 len; + U32 hash = HeHASH(he); + + key = hv_iterkey(he, &len); + elt = hv_iterval(hv, he); + dump_indent(level+1, file, "Elt %s HASH = 0x%lx\n", pv_display(d, key, len, 0, pvlim), hash); + do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); + } + hv_iterinit(hv); /* Return to status quo */ + } + break; + case SVt_PVCV: + if (SvPOK(sv)) + dump_indent(level, file, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na)); + /* FALL THROUGH */ + case SVt_PVFM: + do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); + if (CvSTART(sv)) + dump_indent(level, file, " START = 0x%lx ===> %d\n", (long)CvSTART(sv), CvSTART(sv)->op_seq); + dump_indent(level, file, " ROOT = 0x%lx\n", (long)CvROOT(sv)); + if (CvROOT(sv) && dumpops) + do_op_dump(level+1, file, CvROOT(sv)); + dump_indent (level, file, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); + dump_indent (level, file, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); + do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); + do_gv_dump (level, file, " FILEGV", CvFILEGV(sv)); + dump_indent (level, file, " DEPTH = %ld\n", (long)CvDEPTH(sv)); +#ifdef USE_THREADS + dump_indent (level, file, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv)); + dump_indent (level, file, " OWNER = 0x%lx\n", (long)CvOWNER(sv)); +#endif /* USE_THREADS */ + dump_indent (level, file, " FLAGS = 0x%lx\n", (unsigned long)CvFLAGS(sv)); + if (type == SVt_PVFM) + dump_indent(level, file, " LINES = %ld\n", (long)FmLINES(sv)); + dump_indent(level, file, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); + if (nest < maxnest && CvPADLIST(sv)) { + AV* padlist = CvPADLIST(sv); + AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE); + AV* pad = (AV*)*av_fetch(padlist, 1, FALSE); + SV** pname = AvARRAY(pad_name); + SV** ppad = AvARRAY(pad); + I32 ix; + + for (ix = 1; ix <= AvFILL(pad_name); ix++) { + if (SvPOK(pname[ix])) + dump_indent(level, /* %5d below is enough whitespace. */ + file, + "%5d. 0x%lx (%s\"%s\" %ld-%ld)\n", + ix, ppad[ix], + SvFAKE(pname[ix]) ? "FAKE " : "", + SvPVX(pname[ix]), + (long)I_32(SvNVX(pname[ix])), + (long)SvIVX(pname[ix])); + } + } + { + CV *outside = CvOUTSIDE(sv); + dump_indent(level, file, " OUTSIDE = 0x%lx (%s)\n", + (long)outside, + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == PL_main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + } + if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))) + do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim); + break; + case SVt_PVGV: + dump_indent(level, file, " NAME = \"%s\"\n", GvNAME(sv)); + dump_indent(level, file, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); + do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); + dump_indent(level, file, " GP = 0x%lx\n", (long)GvGP(sv)); + dump_indent(level, file, " SV = 0x%lx\n", (long)GvSV(sv)); + dump_indent(level, file, " REFCNT = %ld\n", (long)GvREFCNT(sv)); + dump_indent(level, file, " IO = 0x%lx\n", (long)GvIOp(sv)); + dump_indent(level, file, " FORM = 0x%lx\n", (long)GvFORM(sv)); + dump_indent(level, file, " AV = 0x%lx\n", (long)GvAV(sv)); + dump_indent(level, file, " HV = 0x%lx\n", (long)GvHV(sv)); + dump_indent(level, file, " CV = 0x%lx\n", (long)GvCV(sv)); + dump_indent(level, file, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); + dump_indent(level, file, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); + dump_indent(level, file, " LINE = %ld\n", (long)GvLINE(sv)); + dump_indent(level, file, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); + do_gv_dump (level, file, " FILEGV", GvFILEGV(sv)); + do_gv_dump (level, file, " EGV", GvEGV(sv)); + break; + case SVt_PVIO: + dump_indent(level, file, " IFP = 0x%lx\n", (long)IoIFP(sv)); + dump_indent(level, file, " OFP = 0x%lx\n", (long)IoOFP(sv)); + dump_indent(level, file, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); + dump_indent(level, file, " LINES = %ld\n", (long)IoLINES(sv)); + dump_indent(level, file, " PAGE = %ld\n", (long)IoPAGE(sv)); + dump_indent(level, file, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); + dump_indent(level, file, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); + dump_indent(level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); + do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); + dump_indent(level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); + do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); + dump_indent(level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); + do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); + dump_indent(level, file, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); + dump_indent(level, file, " TYPE = %c\n", IoTYPE(sv)); + dump_indent(level, file, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); + break; + } +} + +void +sv_dump(SV *sv) +{ + do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); } @@ -111,20 +111,27 @@ #define do_eof Perl_do_eof #define do_exec Perl_do_exec #define do_execfree Perl_do_execfree +#define do_gv_dump Perl_do_gv_dump +#define do_gvgv_dump Perl_do_gvgv_dump +#define do_hv_dump Perl_do_hv_dump #define do_ipcctl Perl_do_ipcctl #define do_ipcget Perl_do_ipcget #define do_join Perl_do_join #define do_kv Perl_do_kv +#define do_magic_dump Perl_do_magic_dump #define do_msgrcv Perl_do_msgrcv #define do_msgsnd Perl_do_msgsnd +#define do_op_dump Perl_do_op_dump #define do_open Perl_do_open #define do_pipe Perl_do_pipe +#define do_pmop_dump Perl_do_pmop_dump #define do_print Perl_do_print #define do_readline Perl_do_readline #define do_seek Perl_do_seek #define do_semop Perl_do_semop #define do_shmio Perl_do_shmio #define do_sprintf Perl_do_sprintf +#define do_sv_dump Perl_do_sv_dump #define do_sysseek Perl_do_sysseek #define do_tell Perl_do_tell #define do_trans Perl_do_trans @@ -139,11 +146,9 @@ #define dump_eval Perl_dump_eval #define dump_fds Perl_dump_fds #define dump_form Perl_dump_form -#define dump_gv Perl_dump_gv +#define dump_indent Perl_dump_indent #define dump_mstats Perl_dump_mstats -#define dump_op Perl_dump_op #define dump_packsubs Perl_dump_packsubs -#define dump_pm Perl_dump_pm #define dump_sub Perl_dump_sub #define fbm_compile Perl_fbm_compile #define fbm_instr Perl_fbm_instr @@ -175,6 +180,7 @@ #define gv_IOadd Perl_gv_IOadd #define gv_autoload4 Perl_gv_autoload4 #define gv_check Perl_gv_check +#define gv_dump Perl_gv_dump #define gv_efullname Perl_gv_efullname #define gv_efullname3 Perl_gv_efullname3 #define gv_fetchfile Perl_gv_fetchfile @@ -258,6 +264,7 @@ #define magic_clearenv Perl_magic_clearenv #define magic_clearpack Perl_magic_clearpack #define magic_clearsig Perl_magic_clearsig +#define magic_dump Perl_magic_dump #define magic_existspack Perl_magic_existspack #define magic_freeregexp Perl_magic_freeregexp #define magic_get Perl_magic_get @@ -393,6 +400,7 @@ #define oopsCV Perl_oopsCV #define oopsHV Perl_oopsHV #define op_const_sv Perl_op_const_sv +#define op_dump Perl_op_dump #define op_free Perl_op_free #define package Perl_package #define pad_alloc Perl_pad_alloc @@ -406,6 +414,7 @@ #define peep Perl_peep #define pidgone Perl_pidgone #define pmflag Perl_pmflag +#define pmop_dump Perl_pmop_dump #define pmruntime Perl_pmruntime #define pmtrans Perl_pmtrans #define pop_return Perl_pop_return @@ -760,6 +769,7 @@ #define prepend_elem Perl_prepend_elem #define push_return Perl_push_return #define push_scope Perl_push_scope +#define pv_display Perl_pv_display #define ref Perl_ref #define refkids Perl_refkids #define regdump Perl_regdump @@ -1107,14 +1117,20 @@ #define do_eof CPerlObj::Perl_do_eof #define do_exec CPerlObj::Perl_do_exec #define do_execfree CPerlObj::Perl_do_execfree +#define do_gv_dump CPerlObj::Perl_do_gv_dump +#define do_gvgv_dump CPerlObj::Perl_do_gvgv_dump +#define do_hv_dump CPerlObj::Perl_do_hv_dump #define do_ipcctl CPerlObj::Perl_do_ipcctl #define do_ipcget CPerlObj::Perl_do_ipcget #define do_join CPerlObj::Perl_do_join #define do_kv CPerlObj::Perl_do_kv +#define do_magic_dump CPerlObj::Perl_do_magic_dump #define do_msgrcv CPerlObj::Perl_do_msgrcv #define do_msgsnd CPerlObj::Perl_do_msgsnd +#define do_op_dump CPerlObj::Perl_do_op_dump #define do_open CPerlObj::Perl_do_open #define do_pipe CPerlObj::Perl_do_pipe +#define do_pmop_dump CPerlObj::Perl_do_pmop_dump #define do_print CPerlObj::Perl_do_print #define do_readline CPerlObj::Perl_do_readline #define do_report_used CPerlObj::Perl_do_report_used @@ -1122,6 +1138,7 @@ #define do_semop CPerlObj::Perl_do_semop #define do_shmio CPerlObj::Perl_do_shmio #define do_sprintf CPerlObj::Perl_do_sprintf +#define do_sv_dump CPerlObj::Perl_do_sv_dump #define do_sysseek CPerlObj::Perl_do_sysseek #define do_tell CPerlObj::Perl_do_tell #define do_trans CPerlObj::Perl_do_trans @@ -1158,11 +1175,9 @@ #define dump_eval CPerlObj::Perl_dump_eval #define dump_fds CPerlObj::Perl_dump_fds #define dump_form CPerlObj::Perl_dump_form -#define dump_gv CPerlObj::Perl_dump_gv +#define dump_indent CPerlObj::Perl_dump_indent #define dump_mstats CPerlObj::Perl_dump_mstats -#define dump_op CPerlObj::Perl_dump_op #define dump_packsubs CPerlObj::Perl_dump_packsubs -#define dump_pm CPerlObj::Perl_dump_pm #define dump_sub CPerlObj::Perl_dump_sub #define dumpuntil CPerlObj::Perl_dumpuntil #define emulate_eaccess CPerlObj::Perl_emulate_eaccess @@ -1205,6 +1220,7 @@ #define gv_IOadd CPerlObj::Perl_gv_IOadd #define gv_autoload4 CPerlObj::Perl_gv_autoload4 #define gv_check CPerlObj::Perl_gv_check +#define gv_dump CPerlObj::Perl_gv_dump #define gv_efullname CPerlObj::Perl_gv_efullname #define gv_efullname3 CPerlObj::Perl_gv_efullname3 #define gv_ename CPerlObj::Perl_gv_ename @@ -1309,6 +1325,7 @@ #define magic_clearenv CPerlObj::Perl_magic_clearenv #define magic_clearpack CPerlObj::Perl_magic_clearpack #define magic_clearsig CPerlObj::Perl_magic_clearsig +#define magic_dump CPerlObj::Perl_magic_dump #define magic_existspack CPerlObj::Perl_magic_existspack #define magic_freeregexp CPerlObj::Perl_magic_freeregexp #define magic_get CPerlObj::Perl_magic_get @@ -1473,6 +1490,7 @@ #define oopsCV CPerlObj::Perl_oopsCV #define oopsHV CPerlObj::Perl_oopsHV #define op_const_sv CPerlObj::Perl_op_const_sv +#define op_dump CPerlObj::Perl_op_dump #define op_free CPerlObj::Perl_op_free #define open_script CPerlObj::Perl_open_script #define package CPerlObj::Perl_package @@ -1512,6 +1530,7 @@ #define perl_set_numeric_standard CPerlObj::perl_set_numeric_standard #define pidgone CPerlObj::Perl_pidgone #define pmflag CPerlObj::Perl_pmflag +#define pmop_dump CPerlObj::Perl_pmop_dump #define pmruntime CPerlObj::Perl_pmruntime #define pmtrans CPerlObj::Perl_pmtrans #define pop_return CPerlObj::Perl_pop_return @@ -1866,6 +1885,7 @@ #define prepend_elem CPerlObj::Perl_prepend_elem #define push_return CPerlObj::Perl_push_return #define push_scope CPerlObj::Perl_push_scope +#define pv_display CPerlObj::Perl_pv_display #define qsortsv CPerlObj::Perl_qsortsv #define re_croak2 CPerlObj::Perl_re_croak2 #define ref CPerlObj::Perl_ref diff --git a/embedvar.h b/embedvar.h index 187a06a925..722561853f 100644 --- a/embedvar.h +++ b/embedvar.h @@ -30,6 +30,7 @@ #define PL_defstash (PL_curinterp->Tdefstash) #define PL_delaymagic (PL_curinterp->Tdelaymagic) #define PL_dirty (PL_curinterp->Tdirty) +#define PL_dumpindent (PL_curinterp->Tdumpindent) #define PL_extralen (PL_curinterp->Textralen) #define PL_firstgv (PL_curinterp->Tfirstgv) #define PL_formtarget (PL_curinterp->Tformtarget) @@ -168,7 +169,6 @@ #define PL_doextract (PL_curinterp->Idoextract) #define PL_doswitches (PL_curinterp->Idoswitches) #define PL_dowarn (PL_curinterp->Idowarn) -#define PL_dumplvl (PL_curinterp->Idumplvl) #define PL_e_script (PL_curinterp->Ie_script) #define PL_endav (PL_curinterp->Iendav) #define PL_envgv (PL_curinterp->Ienvgv) @@ -303,7 +303,6 @@ #define PL_Idoextract PL_doextract #define PL_Idoswitches PL_doswitches #define PL_Idowarn PL_dowarn -#define PL_Idumplvl PL_dumplvl #define PL_Ie_script PL_e_script #define PL_Iendav PL_endav #define PL_Ienvgv PL_envgv @@ -415,6 +414,7 @@ #define PL_Tdefstash PL_defstash #define PL_Tdelaymagic PL_delaymagic #define PL_Tdirty PL_dirty +#define PL_Tdumpindent PL_dumpindent #define PL_Textralen PL_extralen #define PL_Tfirstgv PL_firstgv #define PL_Tformtarget PL_formtarget @@ -541,6 +541,7 @@ #define PL_defstash (thr->Tdefstash) #define PL_delaymagic (thr->Tdelaymagic) #define PL_dirty (thr->Tdirty) +#define PL_dumpindent (thr->Tdumpindent) #define PL_extralen (thr->Textralen) #define PL_firstgv (thr->Tfirstgv) #define PL_formtarget (thr->Tformtarget) diff --git a/ext/Devel/Peek/Changes b/ext/Devel/Peek/Changes new file mode 100644 index 0000000000..e143f878cf --- /dev/null +++ b/ext/Devel/Peek/Changes @@ -0,0 +1,64 @@ +0.3: Some functions return SV * now. +0.4: Hashes dumped recursively. + Additional fields for CV added. +0.5: Prototypes for functions supported. + Strings are consostently in quotes now. + Name changed to Devel::Peek (former ExtUtils::Peek). +0.7: + New function mstat added. + Docs added (thanks to Dean Roehrich). + +0.8: + Exports Dump and mstat. + Docs list more details. + Arrays print addresses of SV. + CV: STASH renamed to COMP_STASH. The package of GV is printed now. + Updated for newer overloading implementation (but will not report + packages with overloading). +0.81: + Implements and exports DeadCode(). + Buglet in the definition of mstat for malloc-less perl corrected. +0.82: + New style PADless CV allowed. +0.83: + DumpArray added. + Compatible with PerlIO. + When calculating junk inside subs, divide by refcount. +0.84: + Indented output. +0.85: + By Gisle Aas: format SvPVX, print magic (but not unrefcounted mg_obj); + A lot of new fields stolen from sv_dump(); +0.86: + By Gisle Aas: + - Updated the documentation. + - Move string printer to it's own function: fprintpv() + - Use it to print PVs, HV keys, MG_PTR + - Don't print IV for hashes as KEY is the same field + - Tag GvSTASH as "GvSTASH" in order to not confuse it with + the other STASH field, e.g. Dump(bless \*foo, "bar") +0.87: + Extra indentation of SvRV. + AMAGIC removed. + Head of OOK data printed too. +0.88: + PADLIST and OUTSIDE of CVs itemized. + Prints the value of the hash of HV keys. + Changes by Gisle: do not print both if AvARRAY == AvALLOC; + print hash fill statistics. +0.89: + Changes by Gisle: optree dump. +0.90: + DumpWithOP, DumpProg exported. + Better indent for AV, HV elts. + Address of SV printed. + Corrected Zero code which was causing segfaults. +0.91: + Compiles, runs test under 5.005beta2. + Update DEBUGGING_MSTATS-less MSTATS. +0.92: + Should compile without MYMALLOC too. +0.94: + Had problems with HEf_SVKEY magic. +0.95: + Added "hash quality" output to estimate Perl's hash functions. diff --git a/ext/Devel/Peek/Makefile.PL b/ext/Devel/Peek/Makefile.PL new file mode 100644 index 0000000000..3563ef2e84 --- /dev/null +++ b/ext/Devel/Peek/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => "Devel::Peek", + VERSION_FROM => 'Peek.pm', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => ' ', +); diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm new file mode 100644 index 0000000000..026c97651a --- /dev/null +++ b/ext/Devel/Peek/Peek.pm @@ -0,0 +1,430 @@ +# Devel::Peek - A data debugging tool for the XS programmer +# The documentation is after the __END__ + +package Devel::Peek; + +$VERSION = $VERSION = 0.95; + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec); +%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); + +bootstrap Devel::Peek; + +sub DumpWithOP ($;$) { + local($Devel::Peek::dump_ops)=1; + my $depth = @_ > 1 ? $_[1] : 4 ; + Dump($_[0],$depth); +} + +1; +__END__ + +=head1 NAME + +Devel::Peek - A data debugging tool for the XS programmer + +=head1 SYNOPSIS + + use Devel::Peek; + Dump( $a ); + Dump( $a, 5 ); + DumpArray( 5, $a, $b, ... ); + mstat "Point 5"; + +=head1 DESCRIPTION + +Devel::Peek contains functions which allows raw Perl datatypes to be +manipulated from a Perl script. This is used by those who do XS programming +to check that the data they are sending from C to Perl looks as they think +it should look. The trick, then, is to know what the raw datatype is +supposed to look like when it gets to Perl. This document offers some tips +and hints to describe good and bad raw data. + +It is very possible that this document will fall far short of being useful +to the casual reader. The reader is expected to understand the material in +the first few sections of L<perlguts>. + +Devel::Peek supplies a C<Dump()> function which can dump a raw Perl +datatype, and C<mstat("marker")> function to report on memory usage +(if perl is compiled with corresponding option). The function +DeadCode() provides statistics on the data "frozen" into inactive +C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and +C<SvREFCNT_dec()> which can query, increment, and decrement reference +counts on SVs. This document will take a passive, and safe, approach +to data debugging and for that it will describe only the C<Dump()> +function. + +Function C<DumpArray()> allows dumping of multiple values (useful when you +need to analize returns of functions). + +The global variable $Devel::Peek::pv_limit can be set to limit the +number of character printed in various string values. Setting it to 0 +means no limit. + +=head1 EXAMPLES + +The following examples don't attempt to show everything as that would be a +monumental task, and, frankly, we don't want this manpage to be an internals +document for Perl. The examples do demonstrate some basics of the raw Perl +datatypes, and should suffice to get most determined people on their way. +There are no guidewires or safety nets, nor blazed trails, so be prepared to +travel alone from this point and on and, if at all possible, don't fall into +the quicksand (it's bad for business). + +Oh, one final bit of advice: take L<perlguts> with you. When you return we +expect to see it well-thumbed. + +=head2 A simple scalar string + +Let's begin by looking a simple scalar which is holding a string. + + use Devel::Peek 'Dump'; + $a = "hello"; + Dump $a; + +The output: + + SV = PVIV(0xbc288) + REFCNT = 1 + FLAGS = (POK,pPOK) + IV = 0 + PV = 0xb2048 "hello"\0 + CUR = 5 + LEN = 6 + +This says C<$a> is an SV, a scalar. The scalar is a PVIV, a string. +Its reference count is 1. It has the C<POK> flag set, meaning its +current PV field is valid. Because POK is set we look at the PV item +to see what is in the scalar. The \0 at the end indicate that this +PV is properly NUL-terminated. +If the FLAGS had been IOK we would look +at the IV item. CUR indicates the number of characters in the PV. +LEN indicates the number of bytes requested for the PV (one more than +CUR, in this case, because LEN includes an extra byte for the +end-of-string marker). + +=head2 A simple scalar number + +If the scalar contains a number the raw SV will be leaner. + + use Devel::Peek 'Dump'; + $a = 42; + Dump $a; + +The output: + + SV = IV(0xbc818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV, a scalar. The scalar is an IV, a number. Its +reference count is 1. It has the C<IOK> flag set, meaning it is currently +being evaluated as a number. Because IOK is set we look at the IV item to +see what is in the scalar. + +=head2 A simple scalar with an extra reference + +If the scalar from the previous example had an extra reference: + + use Devel::Peek 'Dump'; + $a = 42; + $b = \$a; + Dump $a; + +The output: + + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Notice that this example differs from the previous example only in its +reference count. Compare this to the next example, where we dump C<$b> +instead of C<$a>. + +=head2 A reference to a simple scalar + +This shows what a reference looks like when it references a simple scalar. + + use Devel::Peek 'Dump'; + $a = 42; + $b = \$a; + Dump $b; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xbab08 + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Starting from the top, this says C<$b> is an SV. The scalar is an RV, a +reference. It has the C<ROK> flag set, meaning it is a reference. Because +ROK is set we have an RV item rather than an IV or PV. Notice that Dump +follows the reference and shows us what C<$b> was referencing. We see the +same C<$a> that we found in the previous example. + +Note that the value of C<RV> coincides with the numbers we see when we +stringify $b. The addresses inside RV() and IV() are addresses of +C<X***> structure which holds the current state of an C<SV>. This +address may change during lifetime of an SV. + +=head2 A reference to an array + +This shows what a reference to an array looks like. + + use Devel::Peek 'Dump'; + $a = [42]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV and that it is an RV. That RV points to +another SV which is a PVAV, an array. The array has one element, +element zero, which is another SV. The field C<FILL> above indicates +the last element in the array, similar to C<$#$a>. + +If C<$a> pointed to an array of two elements then we would see the +following. + + use Devel::Peek 'Dump'; + $a = [42,24]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + Elt No. 1 0xb5680 + SV = IV(0xbe818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 24 + +Note that C<Dump> will not report I<all> the elements in the array, +only several first (depending on how deep it already went into the +report tree). + +=head2 A reference to a hash + +The following shows the raw form of a reference to a hash. + + use Devel::Peek 'Dump'; + $a = {hello=>42}; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVHV(0xbd448) + REFCNT = 1 + FLAGS = () + NV = 0 + ARRAY = 0xbd748 + KEYS = 1 + FILL = 1 + MAX = 7 + RITER = -1 + EITER = 0x0 + Elt "hello" => 0xbaaf0 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a +hash. Fields RITER and EITER are used by C<L<each>>. + +=head2 Dumping a large array or hash + +The C<Dump()> function, by default, dumps up to 4 elements from a +toplevel array or hash. This number can be increased by supplying a +second argument to the function. + + use Devel::Peek 'Dump'; + $a = [10,11,12,13,14]; + Dump $a; + +Notice that C<Dump()> prints only elements 10 through 13 in the above code. +The following code will print all of the elements. + + use Devel::Peek 'Dump'; + $a = [10,11,12,13,14]; + Dump $a, 5; + +=head2 A reference to an SV which holds a C pointer + +This is what you really need to know as an XS programmer, of course. When +an XSUB returns a pointer to a C structure that pointer is stored in an SV +and a reference to that SV is placed on the XSUB stack. So the output from +an XSUB which uses something like the T_PTROBJ map might look something like +this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (OBJECT,IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + STASH = 0xc1d10 "CookBookB::Opaque" + +This shows that we have an SV which is an RV. That RV points at another +SV. In this case that second SV is a PVMG, a blessed scalar. Because it is +blessed it has the C<OBJECT> flag set. Note that an SV which holds a C +pointer also has the C<IOK> flag set. The C<STASH> is set to the package +name which this SV was blessed into. + +The output from an XSUB which uses something like the T_PTRREF map, which +doesn't bless the object, might look something like this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + +=head2 A reference to a subroutine + +Looks like this: + + SV = RV(0x798ec) + REFCNT = 1 + FLAGS = (TEMP,ROK) + RV = 0x1d453c + SV = PVCV(0x1c768c) + REFCNT = 2 + FLAGS = () + IV = 0 + NV = 0 + COMP_STASH = 0x31068 "main" + START = 0xb20e0 + ROOT = 0xbece0 + XSUB = 0x0 + XSUBANY = 0 + GVGV::GV = 0x1d44e8 "MY" :: "top_targets" + FILEGV = 0x1fab74 "_<(eval 5)" + DEPTH = 0 + PADLIST = 0x1c9338 + +This shows that + +=over + +=item + +the subroutine is not an XSUB (since C<START> and C<ROOT> are +non-zero, and C<XSUB> is zero); + +=item + +that it was compiled in the package C<main>; + +=item + +under the name C<MY::top_targets>; + +=item + +inside a 5th eval in the program; + +=item + +it is not currently executed (see C<DEPTH>); + +=item + +it has no prototype (C<PROTOTYPE> field is missing). + +=over + +=head1 EXPORTS + +C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and +C<DumpProg> by default. Additionally available C<SvREFCNT>, +C<SvREFCNT_inc> and C<SvREFCNT_dec>. + +=head1 BUGS + +Readers have been known to skip important parts of L<perlguts>, causing much +frustration for all. + +=head1 AUTHOR + +Ilya Zakharevich ilya@math.ohio-state.edu + +Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Author of this software makes no claim whatsoever about suitability, +reliability, edability, editability or usability of this product, and +should not be kept liable for any damage resulting from the use of +it. If you can use it, you are in luck, if not, I should not be kept +responsible. Keep a handy copy of your backup tape at hand. + +=head1 SEE ALSO + +L<perlguts>, and L<perlguts>, again. + +=cut diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs new file mode 100644 index 0000000000..d193e312dd --- /dev/null +++ b/ext/Devel/Peek/Peek.xs @@ -0,0 +1,202 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef PURIFY +#define DeadCode() NULL +#else +SV * +DeadCode() +{ + SV* sva; + SV* sv, *dbg; + SV* ret = newRV_noinc((SV*)newAV()); + register SV* svend; + int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; + + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) == SVt_PVCV) { + CV *cv = (CV*)sv; + AV* padlist = CvPADLIST(cv), *argav; + SV** svp; + SV** pad; + int i = 0, j, levelm, totm = 0, levelref, totref = 0; + int levels, tots = 0, levela, tota = 0, levelas, totas = 0; + int dumpit = 0; + + if (CvXSUB(sv)) { + continue; /* XSUB */ + } + if (!CvGV(sv)) { + continue; /* file-level scope. */ + } + if (!CvROOT(cv)) { + /* PerlIO_printf(PerlIO_stderr(), " no root?!\n"); */ + continue; /* autoloading stub. */ + } + do_gvgv_dump(0, PerlIO_stderr(), "GVGV::GV", CvGV(sv)); + if (CvDEPTH(cv)) { + PerlIO_printf(PerlIO_stderr(), " busy\n"); + continue; + } + svp = AvARRAY(padlist); + while (++i <= AvFILL(padlist)) { /* Depth. */ + SV **args; + + pad = AvARRAY((AV*)svp[i]); + argav = (AV*)pad[0]; + if (!argav || (SV*)argav == &PL_sv_undef) { + PerlIO_printf(PerlIO_stderr(), " closure-template\n"); + continue; + } + args = AvARRAY(argav); + levelm = levels = levelref = levelas = 0; + levela = sizeof(SV*) * (AvMAX(argav) + 1); + if (AvREAL(argav)) { + for (j = 0; j < AvFILL(argav); j++) { + if (SvROK(args[j])) { + PerlIO_printf(PerlIO_stderr(), " ref in args!\n"); + levelref++; + } + /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ + else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { + levelas += SvLEN(args[j])/SvREFCNT(args[j]); + } + } + } + for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ + if (SvROK(pad[j])) { + levelref++; + do_sv_dump(0, PerlIO_stderr(), pad[j], 0, 4, 0, 0); + dumpit = 1; + } + /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ + else if (SvTYPE(pad[j]) >= SVt_PVAV) { + if (!SvPADMY(pad[j])) { + levelref++; + do_sv_dump(0, PerlIO_stderr(), pad[j], 0, 4, 0, 0); + dumpit = 1; + } + } + else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { + int db_len = SvLEN(pad[j]); + SV *db_sv = pad[j]; + levels++; + levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); + /* Dump(pad[j],4); */ + } + } + PerlIO_printf(PerlIO_stderr(), " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", + i, levelref, levelm, levels, levela, levelas); + totm += levelm; + tota += levela; + totas += levelas; + tots += levels; + totref += levelref; + if (dumpit) + do_sv_dump(0, PerlIO_stderr(), (SV*)cv, 0, 2, 0, 0); + } + if (AvFILL(padlist) > 1) { + PerlIO_printf(PerlIO_stderr(), " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", + totref, totm, tots, tota, totas); + } + tref += totref; + tm += totm; + ts += tots; + ta += tota; + tas += totas; + } + } + } + PerlIO_printf(PerlIO_stderr(), "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); + + return ret; +} +#endif /* !PURIFY */ + +#if defined(PERL_DEBUGGING_MSTATS) +# define mstat(str) dump_mstats(str) +#else +# define mstat(str) \ + PerlIO_printf(PerlIO_stderr(), "%s: perl not compiled with DEBUGGING_MSTATS\n",str); +#endif + +MODULE = Devel::Peek PACKAGE = Devel::Peek + +void +mstat(str="Devel::Peek::mstat: ") +char *str + +void +Dump(sv,lim=4) +SV * sv +I32 lim +PPCODE: +{ + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + do_sv_dump(0, PerlIO_stderr(), sv, 0, 4, dumpop && SvTRUE(dumpop), pv_lim); + PL_dumpindent = save_dumpindent; +} + +void +DumpArray(lim,...) +I32 lim +PPCODE: +{ + long i; + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + + for (i=1; i<items; i++) { + PerlIO_printf(PerlIO_stderr(), "Elt No. %ld 0x%lx\n", i - 1, ST(i)); + do_sv_dump(0, PerlIO_stderr(), ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + } + PL_dumpindent = save_dumpindent; +} + +void +DumpProg() +PPCODE: +{ + warn("dumpindent is %d", PL_dumpindent); + if (PL_main_root) + op_dump(PL_main_root); +} + +I32 +SvREFCNT(sv) +SV * sv + +# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. + +SV * +SvREFCNT_inc(sv) +SV * sv +PPCODE: +{ + RETVAL = SvREFCNT_inc(sv); + PUSHs(RETVAL); +} + +# PPCODE needed since by default it is void + +SV * +SvREFCNT_dec(sv) +SV * sv +PPCODE: +{ + SvREFCNT_dec(sv); + PUSHs(sv); +} + +SV * +DeadCode() diff --git a/global.sym b/global.sym index 38e6998514..b2a8f1a542 100644 --- a/global.sym +++ b/global.sym @@ -102,20 +102,27 @@ do_close do_eof do_exec do_execfree +do_hv_dump +do_gv_dump +do_gvgv_dump do_ipcctl do_ipcget do_join do_kv +do_magic_dump do_msgrcv do_msgsnd do_open +do_op_dump do_pipe +do_pmop_dump do_print do_readline do_seek do_semop do_shmio do_sprintf +do_sv_dump do_sysseek do_tell do_trans @@ -130,11 +137,9 @@ dump_all dump_eval dump_fds dump_form -dump_gv +dump_indent dump_mstats -dump_op dump_packsubs -dump_pm dump_sub fbm_compile fbm_instr @@ -166,6 +171,7 @@ gv_HVadd gv_IOadd gv_autoload4 gv_check +gv_dump gv_efullname gv_efullname3 gv_fetchfile @@ -249,6 +255,7 @@ magic_clear_all_env magic_clearenv magic_clearpack magic_clearsig +magic_dump magic_existspack magic_freeregexp magic_get @@ -384,6 +391,7 @@ oopsAV oopsCV oopsHV op_const_sv +op_dump op_free package pad_alloc @@ -397,10 +405,12 @@ pad_swipe peep pidgone pmflag +pmop_dump pmruntime pmtrans pop_return pop_scope +pv_display pregcomp pregexec pregfree diff --git a/intrpvar.h b/intrpvar.h index 1f6244d557..457ad75e0c 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -146,7 +146,6 @@ PERLVAR(Ioldname, char *) /* what to preserve mode on */ PERLVAR(IArgv, char **) /* stuff to free from do_aexec, vfork safe */ PERLVAR(ICmd, char *) /* stuff to free from do_aexec, vfork safe */ PERLVAR(Imystrk, SV *) /* temp key string for do_each() */ -PERLVAR(Idumplvl, I32) /* indentation level on syntax tree dump */ PERLVAR(Ioldlastpm, PMOP *) /* for saving regexp context in debugger */ PERLVAR(Igensym, I32) /* next symbol for getsym() to define */ PERLVAR(Ipreambled, bool) @@ -166,8 +166,8 @@ #define PL_doswitches pPerl->PL_doswitches #undef PL_dowarn #define PL_dowarn pPerl->PL_dowarn -#undef PL_dumplvl -#define PL_dumplvl pPerl->PL_dumplvl +#undef PL_dumpindent +#define PL_dumpindent pPerl->PL_dumpindent #undef PL_e_script #define PL_e_script pPerl->PL_e_script #undef PL_egid @@ -1021,6 +1021,12 @@ #define do_exec pPerl->Perl_do_exec #undef do_execfree #define do_execfree pPerl->Perl_do_execfree +#undef do_gv_dump +#define do_gv_dump pPerl->Perl_do_gv_dump +#undef do_gvgv_dump +#define do_gvgv_dump pPerl->Perl_do_gvgv_dump +#undef do_hv_dump +#define do_hv_dump pPerl->Perl_do_hv_dump #undef do_ipcctl #define do_ipcctl pPerl->Perl_do_ipcctl #undef do_ipcget @@ -1029,14 +1035,20 @@ #define do_join pPerl->Perl_do_join #undef do_kv #define do_kv pPerl->Perl_do_kv +#undef do_magic_dump +#define do_magic_dump pPerl->Perl_do_magic_dump #undef do_msgrcv #define do_msgrcv pPerl->Perl_do_msgrcv #undef do_msgsnd #define do_msgsnd pPerl->Perl_do_msgsnd +#undef do_op_dump +#define do_op_dump pPerl->Perl_do_op_dump #undef do_open #define do_open pPerl->Perl_do_open #undef do_pipe #define do_pipe pPerl->Perl_do_pipe +#undef do_pmop_dump +#define do_pmop_dump pPerl->Perl_do_pmop_dump #undef do_print #define do_print pPerl->Perl_do_print #undef do_readline @@ -1051,6 +1063,8 @@ #define do_shmio pPerl->Perl_do_shmio #undef do_sprintf #define do_sprintf pPerl->Perl_do_sprintf +#undef do_sv_dump +#define do_sv_dump pPerl->Perl_do_sv_dump #undef do_sysseek #define do_sysseek pPerl->Perl_do_sysseek #undef do_tell @@ -1123,16 +1137,12 @@ #define dump_fds pPerl->Perl_dump_fds #undef dump_form #define dump_form pPerl->Perl_dump_form -#undef dump_gv -#define dump_gv pPerl->Perl_dump_gv +#undef dump_indent +#define dump_indent pPerl->Perl_dump_indent #undef dump_mstats #define dump_mstats pPerl->Perl_dump_mstats -#undef dump_op -#define dump_op pPerl->Perl_dump_op #undef dump_packsubs #define dump_packsubs pPerl->Perl_dump_packsubs -#undef dump_pm -#define dump_pm pPerl->Perl_dump_pm #undef dump_sub #define dump_sub pPerl->Perl_dump_sub #undef dumpuntil @@ -1217,6 +1227,8 @@ #define gv_autoload4 pPerl->Perl_gv_autoload4 #undef gv_check #define gv_check pPerl->Perl_gv_check +#undef gv_dump +#define gv_dump pPerl->Perl_gv_dump #undef gv_efullname #define gv_efullname pPerl->Perl_gv_efullname #undef gv_efullname3 @@ -1425,6 +1437,8 @@ #define magic_clearpack pPerl->Perl_magic_clearpack #undef magic_clearsig #define magic_clearsig pPerl->Perl_magic_clearsig +#undef magic_dump +#define magic_dump pPerl->Perl_magic_dump #undef magic_existspack #define magic_existspack pPerl->Perl_magic_existspack #undef magic_freeregexp @@ -1753,6 +1767,8 @@ #define oopsHV pPerl->Perl_oopsHV #undef op_const_sv #define op_const_sv pPerl->Perl_op_const_sv +#undef op_dump +#define op_dump pPerl->Perl_op_dump #undef op_free #define op_free pPerl->Perl_op_free #undef open_script @@ -1831,6 +1847,8 @@ #define pidgone pPerl->Perl_pidgone #undef pmflag #define pmflag pPerl->Perl_pmflag +#undef pmop_dump +#define pmop_dump pPerl->Perl_pmop_dump #undef pmruntime #define pmruntime pPerl->Perl_pmruntime #undef pmtrans @@ -2539,6 +2557,8 @@ #define push_return pPerl->Perl_push_return #undef push_scope #define push_scope pPerl->Perl_push_scope +#undef pv_display +#define pv_display pPerl->Perl_pv_display #undef qsortsv #define qsortsv pPerl->Perl_qsortsv #undef re_croak2 @@ -1849,6 +1849,7 @@ init_interp(void) PL_curcopdb = NULL; \ PL_dbargs = 0; \ PL_dlmax = 128; \ + PL_dumpindent = 4; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ PL_maxscream = -1; \ @@ -1886,7 +1887,7 @@ init_interp(void) # undef PERLVAR # undef PERLVARI # undef PERLVARIC -# else +# else # define PERLVAR(var,type) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; @@ -2810,6 +2811,7 @@ init_main_thread() *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */ thr->oursv = PL_thrsv; PL_chopset = " \n-"; + PL_dumpindent = 4; MUTEX_LOCK(&PL_threads_mutex); PL_nthreads++; @@ -1657,10 +1657,11 @@ Gid_t getgid _((void)); Gid_t getegid _((void)); #endif -#ifdef DEBUGGING #ifndef Perl_debug_log #define Perl_debug_log PerlIO_stderr() #endif + +#ifdef DEBUGGING #undef YYDEBUG #define YYDEBUG 1 #define DEB(a) a @@ -137,12 +137,12 @@ VIRTUAL void dump_eval _((void)); VIRTUAL void dump_fds _((char* s)); #endif VIRTUAL void dump_form _((GV* gv)); -VIRTUAL void dump_gv _((GV* gv)); +VIRTUAL void gv_dump _((GV* gv)); #ifdef MYMALLOC VIRTUAL void dump_mstats _((char* s)); #endif -VIRTUAL void dump_op _((OP* arg)); -VIRTUAL void dump_pm _((PMOP* pm)); +VIRTUAL void op_dump _((OP* arg)); +VIRTUAL void pmop_dump _((PMOP* pm)); VIRTUAL void dump_packsubs _((HV* stash)); VIRTUAL void dump_sub _((GV* gv)); VIRTUAL void fbm_compile _((SV* sv, U32 flags)); @@ -949,3 +949,14 @@ VIRTUAL MGVTBL* get_vtbl _((int vtbl_id)); * compatablity with PERL_OBJECT */ +VIRTUAL char* pv_display _((SV *sv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)); +VIRTUAL void dump_indent _((I32 level, PerlIO *file, const char* pat, ...)); + +VIRTUAL void do_gv_dump _((I32 level, PerlIO *file, char *name, GV *sv)); +VIRTUAL void do_gvgv_dump _((I32 level, PerlIO *file, char *name, GV *sv)); +VIRTUAL void do_hv_dump _((I32 level, PerlIO *file, char *name, HV *sv)); +VIRTUAL void do_magic_dump _((I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)); +VIRTUAL void do_op_dump _((I32 level, PerlIO *file, OP *o)); +VIRTUAL void do_pmop_dump _((I32 level, PerlIO *file, PMOP *pm)); +VIRTUAL void do_sv_dump _((I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)); +VIRTUAL void magic_dump _((MAGIC *mg)); @@ -922,156 +922,6 @@ sv_upgrade(register SV *sv, U32 mt) return TRUE; } -char * -sv_peek(SV *sv) -{ -#ifdef DEBUGGING - SV *t = sv_newmortal(); - STRLEN prevlen; - int unref = 0; - - 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) { - if (sv == &PL_sv_undef) { - sv_catpv(t, "SV_UNDEF"); - 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"); - 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 { - sv_catpv(t, "SV_YES"); - 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; - } - sv_catpv(t, ":"); - } - else if (SvREFCNT(sv) == 0) { - sv_catpv(t, "("); - unref++; - } - if (SvROK(sv)) { - sv_catpv(t, "\\"); - if (SvCUR(t) + unref > 10) { - SvCUR(t) = unref + 3; - *SvEND(t) = '\0'; - sv_catpv(t, "..."); - goto finish; - } - sv = (SV*)SvRV(sv); - goto retry; - } - switch (SvTYPE(sv)) { - default: - sv_catpv(t, "FREED"); - goto finish; - - case SVt_NULL: - sv_catpv(t, "UNDEF"); - 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)) - sv_catpvf(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_catpv(t, "(null)"); - if (SvOOK(sv)) - sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv)); - else - sv_catpvf(t, "(\"%.127s\")",SvPVX(sv)); - } - else if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); - sv_catpvf(t, "(%g)",SvNVX(sv)); - } - else if (SvIOKp(sv)) - sv_catpvf(t, "(%ld)",(long)SvIVX(sv)); - else - sv_catpv(t, "()"); - - finish: - if (unref) { - while (unref--) - sv_catpv(t, ")"); - } - return SvPV(t, PL_na); -#else /* DEBUGGING */ - return ""; -#endif /* DEBUGGING */ -} - int sv_backoff(register SV *sv) { @@ -5017,273 +4867,3 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, SvCUR(sv) = p - SvPVX(sv); } } - -void -sv_dump(SV *sv) -{ -#ifdef DEBUGGING - SV *d = sv_newmortal(); - char *s; - U32 flags; - U32 type; - - if (!sv) { - PerlIO_printf(Perl_debug_log, "SV = 0\n"); - return; - } - - flags = SvFLAGS(sv); - type = SvTYPE(sv); - - sv_setpvf(d, "(0x%lx)\n REFCNT = %ld\n FLAGS = (", - (unsigned long)SvANY(sv), (long)SvREFCNT(sv)); - if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,"); - if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); - if (flags & SVs_PADMY) sv_catpv(d, "PADMY,"); - if (flags & SVs_TEMP) sv_catpv(d, "TEMP,"); - if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,"); - if (flags & SVs_GMG) sv_catpv(d, "GMG,"); - if (flags & SVs_SMG) sv_catpv(d, "SMG,"); - if (flags & SVs_RMG) sv_catpv(d, "RMG,"); - - if (flags & SVf_IOK) sv_catpv(d, "IOK,"); - if (flags & SVf_NOK) sv_catpv(d, "NOK,"); - if (flags & SVf_POK) sv_catpv(d, "POK,"); - if (flags & SVf_ROK) sv_catpv(d, "ROK,"); - if (flags & SVf_OOK) sv_catpv(d, "OOK,"); - if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); - if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); - -#ifdef OVERLOAD - if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,"); -#endif /* 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,"); - - switch (type) { - case SVt_PVCV: - case SVt_PVFM: - if (CvANON(sv)) sv_catpv(d, "ANON,"); - if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); - if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); - if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); - if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); - break; - case SVt_PVHV: - if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); - if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); - break; - case SVt_PVGV: - if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); - if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); - if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); - if (GvIMPORTED(sv)) { - sv_catpv(d, "IMPORT"); - if (GvIMPORTED(sv) == GVf_IMPORTED) - sv_catpv(d, "ALL,"); - else { - sv_catpv(d, "("); - if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV"); - if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV"); - if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV"); - if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV"); - sv_catpv(d, " ),"); - } - } - case SVt_PVBM: - if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); - if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); - break; - } - - if (*(SvEND(d) - 1) == ',') - SvPVX(d)[--SvCUR(d)] = '\0'; - sv_catpv(d, ")"); - s = SvPVX(d); - - PerlIO_printf(Perl_debug_log, "SV = "); - switch (type) { - case SVt_NULL: - PerlIO_printf(Perl_debug_log, "NULL%s\n", s); - return; - case SVt_IV: - PerlIO_printf(Perl_debug_log, "IV%s\n", s); - break; - case SVt_NV: - PerlIO_printf(Perl_debug_log, "NV%s\n", s); - break; - case SVt_RV: - PerlIO_printf(Perl_debug_log, "RV%s\n", s); - break; - case SVt_PV: - PerlIO_printf(Perl_debug_log, "PV%s\n", s); - break; - case SVt_PVIV: - PerlIO_printf(Perl_debug_log, "PVIV%s\n", s); - break; - case SVt_PVNV: - PerlIO_printf(Perl_debug_log, "PVNV%s\n", s); - break; - case SVt_PVBM: - PerlIO_printf(Perl_debug_log, "PVBM%s\n", s); - break; - case SVt_PVMG: - PerlIO_printf(Perl_debug_log, "PVMG%s\n", s); - break; - case SVt_PVLV: - PerlIO_printf(Perl_debug_log, "PVLV%s\n", s); - break; - case SVt_PVAV: - PerlIO_printf(Perl_debug_log, "PVAV%s\n", s); - break; - case SVt_PVHV: - PerlIO_printf(Perl_debug_log, "PVHV%s\n", s); - break; - case SVt_PVCV: - PerlIO_printf(Perl_debug_log, "PVCV%s\n", s); - break; - case SVt_PVGV: - PerlIO_printf(Perl_debug_log, "PVGV%s\n", s); - break; - case SVt_PVFM: - PerlIO_printf(Perl_debug_log, "PVFM%s\n", s); - break; - case SVt_PVIO: - PerlIO_printf(Perl_debug_log, "PVIO%s\n", s); - break; - default: - PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s); - return; - } - if (type >= SVt_PVIV || type == SVt_IV) - PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); - if (type >= SVt_PVNV || type == SVt_NV) { - SET_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); - } - if (SvROK(sv)) { - PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); - sv_dump(SvRV(sv)); - return; - } - if (type < SVt_PV) - return; - if (type <= SVt_PVLV) { - if (SvPVX(sv)) - PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", - (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv)); - else - PerlIO_printf(Perl_debug_log, " PV = 0\n"); - } - if (type >= SVt_PVMG) { - if (SvMAGIC(sv)) { - PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); - } - if (SvSTASH(sv)) - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv))); - } - switch (type) { - case SVt_PVLV: - PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv)); - PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); - PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); - PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv)); - sv_dump(LvTARG(sv)); - break; - case SVt_PVAV: - PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); - PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); - PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv)); - PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); - PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)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"); - PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n", - SvCUR(d) ? SvPVX(d) + 1 : ""); - break; - case SVt_PVHV: - PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); - PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv)); - PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv)); - PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv)); - PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv)); - PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv)); - if (HvPMROOT(sv)) - PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); - if (HvNAME(sv)) - PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); - break; - case SVt_PVCV: - if (SvPOK(sv)) - PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na)); - /* FALL THROUGH */ - case SVt_PVFM: - PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); - PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv)); - PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv)); - PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); - PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); - PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv)); - if (CvGV(sv) && GvNAME(CvGV(sv))) { - PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv))); - } else { - PerlIO_printf(Perl_debug_log, "\n"); - } - PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); - PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv)); - PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); - PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); -#ifdef USE_THREADS - PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv)); - PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv)); -#endif /* USE_THREADS */ - PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", - (unsigned long)CvFLAGS(sv)); - if (type == SVt_PVFM) - PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); - break; - case SVt_PVGV: - PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); - PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", - SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)"); - PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); - PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); - PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); - PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv)); - PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv)); - PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv)); - PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv)); - PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv)); - PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); - PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); - PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); - PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv)); - PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); - break; - case SVt_PVIO: - PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv)); - PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv)); - PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); - PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv)); - PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv)); - PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); - PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); - PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); - PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv)); - PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); - PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv)); - PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); - PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv)); - PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); - PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv)); - PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); - break; - } -#endif /* DEBUGGING */ -} @@ -650,7 +650,11 @@ struct xpvio { #define SvSetMagicSV_nosteal(dst,src) \ SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) +#ifdef DEBUGGING #define SvPEEK(sv) sv_peek(sv) +#else +#define SvPEEK(sv) "" +#endif #define SvIMMORTAL(sv) ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no) @@ -102,6 +102,7 @@ PERLVAR(Thv_fetch_ent_mh, HE) /* owned by hv_fetch_ent() */ PERLVAR(Tmodcount, I32) /* how much mod()ification in assignment? */ PERLVAR(Tlastgotoprobe, OP*) /* from pp_ctl.c */ +PERLVARI(Tdumpindent, I32, 4) /* # of blanks per dump indentation level */ /* sort stuff */ PERLVAR(Tsortcop, OP *) /* user defined sort routine */ diff --git a/win32/GenCAPI.pl b/win32/GenCAPI.pl index 5972c2a279..5e7868ddf7 100644 --- a/win32/GenCAPI.pl +++ b/win32/GenCAPI.pl @@ -416,7 +416,6 @@ secondgv sortstack signalstack mystrk -dumplvl oldlastpm gensym preambled @@ -499,6 +498,8 @@ nthreads_cond eval_cond cryptseen cshlen +watchaddr +watchok )]; sub readvars(\%$$) { diff --git a/win32/Makefile b/win32/Makefile index c4c537e321..be10a082a4 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -496,7 +496,7 @@ SETARGV_OBJ = setargv$(o) !ENDIF DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ - Data/Dumper + Data/Dumper Devel/Peek STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -513,6 +513,7 @@ B = $(EXTDIR)\B\B RE = $(EXTDIR)\re\re DUMPER = $(EXTDIR)\Data\Dumper\Dumper ERRNO = $(EXTDIR)\Errno\Errno +PEEK = $(EXTDIR)\Devel\Peek\Peek SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -524,6 +525,7 @@ ATTRS_DLL = $(AUTODIR)\attrs\attrs.dll THREAD_DLL = $(AUTODIR)\Thread\Thread.dll B_DLL = $(AUTODIR)\B\B.dll DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll +PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -539,6 +541,7 @@ EXTENSION_C = \ $(THREAD).c \ $(RE).c \ $(DUMPER).c \ + $(PEEK).c \ $(B).c EXTENSION_DLL = \ @@ -550,6 +553,7 @@ EXTENSION_DLL = \ $(POSIX_DLL) \ $(ATTRS_DLL) \ $(DUMPER_DLL) \ + $(PEEK_DLL) \ $(B_DLL) EXTENSION_PM = \ @@ -774,6 +778,12 @@ $(DUMPER_DLL): $(PERLEXE) $(DUMPER).xs $(MAKE) cd ..\..\..\win32 +$(PEEK_DLL): $(PERLEXE) $(PEEK).xs + cd $(EXTDIR)\Devel\$(*B) + ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\..\win32 + $(RE_DLL): $(PERLEXE) $(RE).xs cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl @@ -867,6 +877,7 @@ distclean: clean -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\Data\Dumper.pm + -del /f $(LIBDIR)\Devel\Peek.pm -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread -rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B diff --git a/win32/makefile.mk b/win32/makefile.mk index dce54612bd..360bd978e4 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -611,7 +611,7 @@ SETARGV_OBJ = setargv$(o) .ENDIF DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ - Data/Dumper + Data/Dumper Devel/Peek STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -628,6 +628,7 @@ B = $(EXTDIR)\B\B RE = $(EXTDIR)\re\re DUMPER = $(EXTDIR)\Data\Dumper\Dumper ERRNO = $(EXTDIR)\Errno\Errno +PEEK = $(EXTDIR)\Devel\Peek\Peek SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -639,6 +640,7 @@ ATTRS_DLL = $(AUTODIR)\attrs\attrs.dll THREAD_DLL = $(AUTODIR)\Thread\Thread.dll B_DLL = $(AUTODIR)\B\B.dll DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll +PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -654,6 +656,7 @@ EXTENSION_C = \ $(THREAD).c \ $(RE).c \ $(DUMPER).c \ + $(PEEK).c \ $(B).c EXTENSION_DLL = \ @@ -665,6 +668,7 @@ EXTENSION_DLL = \ $(POSIX_DLL) \ $(ATTRS_DLL) \ $(DUMPER_DLL) \ + $(PEEK_DLL) \ $(B_DLL) EXTENSION_PM = \ @@ -952,6 +956,11 @@ $(DUMPER_DLL): $(PERLEXE) $(DUMPER).xs ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Data\$(*B) && $(MAKE) +$(PEEK_DLL): $(PERLEXE) $(Peek).xs + cd $(EXTDIR)\Devel\$(*B) && \ + ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\Devel\$(*B) && $(MAKE) + $(RE_DLL): $(PERLEXE) $(RE).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl @@ -1031,6 +1040,7 @@ distclean: clean -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\Data\Dumper.pm + -del /f $(LIBDIR)\Devel\Peek.pm -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread -rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B |