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
#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;
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);
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) {
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);
}
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;
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) {
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);
}
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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)
#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)
#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
#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
#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)
--- /dev/null
+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.
--- /dev/null
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => "Devel::Peek",
+ VERSION_FROM => 'Peek.pm',
+ 'dist' => {
+ COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz',
+ DIST_DEFAULT => 'all tardist',
+ },
+ MAN3PODS => ' ',
+);
--- /dev/null
+# 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
--- /dev/null
+#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()
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
dump_eval
dump_fds
dump_form
-dump_gv
+dump_indent
dump_mstats
-dump_op
dump_packsubs
-dump_pm
dump_sub
fbm_compile
fbm_instr
gv_IOadd
gv_autoload4
gv_check
+gv_dump
gv_efullname
gv_efullname3
gv_fetchfile
magic_clearenv
magic_clearpack
magic_clearsig
+magic_dump
magic_existspack
magic_freeregexp
magic_get
oopsCV
oopsHV
op_const_sv
+op_dump
op_free
package
pad_alloc
peep
pidgone
pmflag
+pmop_dump
pmruntime
pmtrans
pop_return
pop_scope
+pv_display
pregcomp
pregexec
pregfree
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)
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
PL_curcopdb = NULL; \
PL_dbargs = 0; \
PL_dlmax = 128; \
+ PL_dumpindent = 4; \
PL_laststatval = -1; \
PL_laststype = OP_STAT; \
PL_maxscream = -1; \
# 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;
*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++;
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
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));
* 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));
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)
{
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 */
-}
#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)
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 */
sortstack
signalstack
mystrk
-dumplvl
oldlastpm
gensym
preambled
eval_cond
cryptseen
cshlen
+watchaddr
+watchok
)];
sub readvars(\%$$) {
!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
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
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
$(THREAD).c \
$(RE).c \
$(DUMPER).c \
+ $(PEEK).c \
$(B).c
EXTENSION_DLL = \
$(POSIX_DLL) \
$(ATTRS_DLL) \
$(DUMPER_DLL) \
+ $(PEEK_DLL) \
$(B_DLL)
EXTENSION_PM = \
$(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
-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
.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
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
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
$(THREAD).c \
$(RE).c \
$(DUMPER).c \
+ $(PEEK).c \
$(B).c
EXTENSION_DLL = \
$(POSIX_DLL) \
$(ATTRS_DLL) \
$(DUMPER_DLL) \
+ $(PEEK_DLL) \
$(B_DLL)
EXTENSION_PM = \
..\..\..\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
-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
projects / p5sagit/p5-mst-13.2.git / commitdiff