Suggested doc enhancement(?) to Exporter.pm

[p5sagit/p5-mst-13.2.git] / dump.c

diff --git a/dump.c b/dump.c
index b5e9fbf..290ee7a 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -143,28 +143,6 @@ Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 }
 
 char *
-Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
-{
-    int truncated = 0;
-    char *s, *e;
-
-    sv_setpvn(dsv, "", 0);
-    for (s = SvPVX(ssv), e = s + SvCUR(ssv); s < e; s += UTF8SKIP(s)) {
-        UV u;
-        if (pvlim && SvCUR(dsv) >= pvlim) {
-             truncated++;
-             break;
-        }
-        u = utf8_to_uvchr((U8*)s, 0);
-        Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
-    }
-    if (truncated)
-        sv_catpvn(dsv, "...", 3);
-    
-    return SvPVX(dsv);
-}
-
-char *
 Perl_sv_peek(pTHX_ SV *sv)
 {
     SV *t = sv_newmortal();
@@ -216,7 +194,7 @@ Perl_sv_peek(pTHX_ SV *sv)
        sv_catpv(t, "(");
        unref++;
     }
-    else if (DEBUG_R_TEST && SvREFCNT(sv) > 1) {
+    else if (DEBUG_R_TEST_ && SvREFCNT(sv) > 1) {
        Perl_sv_catpvf(aTHX_ t, "<%"UVuf">", (UV)SvREFCNT(sv));
     }
 
@@ -307,7 +285,7 @@ Perl_sv_peek(pTHX_ SV *sv)
     }
     else if (SvNOKp(sv)) {
        STORE_NUMERIC_LOCAL_SET_STANDARD();
-       Perl_sv_catpvf(aTHX_ t, "(%g)",SvNVX(sv));
+       Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
     }
     else if (SvIOKp(sv)) {
@@ -525,6 +503,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
                    sv_catpv(tmpsv, ",NOPAREN");
                if (o->op_private & OPpENTERSUB_INARGS)
                    sv_catpv(tmpsv, ",INARGS");
+               if (o->op_private & OPpENTERSUB_NOMOD)
+                   sv_catpv(tmpsv, ",NOMOD");
            }
            else {
                switch (o->op_private & OPpDEREF) {
@@ -571,7 +551,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        else if (o->op_type == OP_FLOP) {
            if (o->op_private & OPpFLIP_LINENUM)
                sv_catpv(tmpsv, ",LINENUM");
-       } else if (o->op_type == OP_RV2CV) {
+       }
+       else if (o->op_type == OP_RV2CV) {
            if (o->op_private & OPpLVAL_INTRO)
                sv_catpv(tmpsv, ",INTRO");
        }
@@ -1385,3 +1366,123 @@ Perl_sv_dump(pTHX_ SV *sv)
 {
     do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
 }
+
+int
+Perl_runops_debug(pTHX)
+{
+    if (!PL_op) {
+       if (ckWARN_d(WARN_DEBUGGING))
+           Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
+       return 0;
+    }
+
+    do {
+       PERL_ASYNC_CHECK();
+       if (PL_debug) {
+           if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
+               PerlIO_printf(Perl_debug_log,
+                             "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
+                             PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
+                             PTR2UV(*PL_watchaddr));
+           if (DEBUG_s_TEST_) debstack();
+           if (DEBUG_t_TEST_) debop(PL_op);
+           if (DEBUG_P_TEST_) debprof(PL_op);
+       }
+    } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+
+    TAINT_NOT;
+    return 0;
+}
+
+I32
+Perl_debop(pTHX_ OP *o)
+{
+    AV *padlist, *comppad;
+    CV *cv;
+    SV *sv;
+    STRLEN n_a;
+    Perl_deb(aTHX_ "%s", OP_NAME(o));
+    switch (o->op_type) {
+    case OP_CONST:
+       PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
+       break;
+    case OP_GVSV:
+    case OP_GV:
+       if (cGVOPo_gv) {
+           sv = NEWSV(0,0);
+           gv_fullname3(sv, cGVOPo_gv, Nullch);
+           PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a));
+           SvREFCNT_dec(sv);
+       }
+       else
+           PerlIO_printf(Perl_debug_log, "(NULL)");
+       break;
+    case OP_PADSV:
+    case OP_PADAV:
+    case OP_PADHV:
+       /* print the lexical's name */
+        cv = deb_curcv(cxstack_ix);
+        if (cv) {
+            padlist = CvPADLIST(cv);
+            comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
+            sv = *av_fetch(comppad, o->op_targ, FALSE);
+        } else
+            sv = Nullsv;
+        if (sv)
+           PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
+        else
+           PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
+        break;
+    default:
+       break;
+    }
+    PerlIO_printf(Perl_debug_log, "\n");
+    return 0;
+}
+
+STATIC CV*
+S_deb_curcv(pTHX_ I32 ix)
+{
+    PERL_CONTEXT *cx = &cxstack[ix];
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+        return cx->blk_sub.cv;
+    else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
+        return PL_compcv;
+    else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
+        return PL_main_cv;
+    else if (ix <= 0)
+        return Nullcv;
+    else
+        return deb_curcv(ix - 1);
+}
+
+void
+Perl_watch(pTHX_ char **addr)
+{
+    PL_watchaddr = addr;
+    PL_watchok = *addr;
+    PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
+       PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
+}
+
+STATIC void
+S_debprof(pTHX_ OP *o)
+{
+    if (!PL_profiledata)
+       Newz(000, PL_profiledata, MAXO, U32);
+    ++PL_profiledata[o->op_type];
+}
+
+void
+Perl_debprofdump(pTHX)
+{
+    unsigned i;
+    if (!PL_profiledata)
+       return;
+    for (i = 0; i < MAXO; i++) {
+       if (PL_profiledata[i])
+           PerlIO_printf(Perl_debug_log,
+                         "%5lu %s\n", (unsigned long)PL_profiledata[i],
+                                       PL_op_name[i]);
+    }
+}