This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add ext/Devel/Peek
authorJan Dubois <jand@activestate.com>
Mon, 23 Nov 1998 00:48:11 +0000 (01:48 +0100)
committerGurusamy Sarathy <gsar@cpan.org>
Fri, 27 Nov 1998 14:20:12 +0000 (14:20 +0000)
Message-ID: <36589ec9.49964585@smtp1.ibm.net>
Subject: [PATCH 5.005_53] Devel::Peek integration

p4raw-id: //depot/perl@2322

20 files changed:
MANIFEST
dump.c
embed.h
embedvar.h
ext/Devel/Peek/Changes [new file with mode: 0644]
ext/Devel/Peek/Makefile.PL [new file with mode: 0644]
ext/Devel/Peek/Peek.pm [new file with mode: 0644]
ext/Devel/Peek/Peek.xs [new file with mode: 0644]
global.sym
intrpvar.h
objXSUB.h
perl.c
perl.h
proto.h
sv.c
sv.h
thrdvar.h
win32/GenCAPI.pl
win32/Makefile
win32/makefile.mk

index 7ba415a..5e95356 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/dump.c b/dump.c
index 8b73a9a..85cdddb 100644 (file)
--- a/dump.c
+++ b/dump.c
 #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);
 }
diff --git a/embed.h b/embed.h
index 8644ec7..d6aca6d 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
index 187a06a..7225618 100644 (file)
@@ -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)
 #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)
diff --git a/ext/Devel/Peek/Changes b/ext/Devel/Peek/Changes
new file mode 100644 (file)
index 0000000..e143f87
--- /dev/null
@@ -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 (file)
index 0000000..3563ef2
--- /dev/null
@@ -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 (file)
index 0000000..026c976
--- /dev/null
@@ -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 (file)
index 0000000..d193e31
--- /dev/null
@@ -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()
index 38e6998..b2a8f1a 100644 (file)
@@ -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
index 1f6244d..457ad75 100644 (file)
@@ -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)
index 41d4b8e..a9820dd 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #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
diff --git a/perl.c b/perl.c
index bf86fef..7659b7c 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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++;
diff --git a/perl.h b/perl.h
index 7486c16..0f8a94c 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -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
diff --git a/proto.h b/proto.h
index a770485..b0c7f9b 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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));
diff --git a/sv.c b/sv.c
index e10cfe2..876ef07 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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 */
-}
diff --git a/sv.h b/sv.h
index 893948e..7884aeb 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -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)
 
index 51f68ea..335ebc4 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -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 */
index 5972c2a..5e7868d 100644 (file)
@@ -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(\%$$) {
index c4c537e..be10a08 100644 (file)
@@ -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
index dce5461..360bd97 100644 (file)
@@ -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