/* dump.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
}
char *
-Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim)
-{
- int truncated = 0;
- char *s, *e;
-
- sv_setpvn(dsv, "\"", 1);
- 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{%x}", u);
- }
- sv_catpvn(dsv, "\"", 1);
- if (truncated)
- sv_catpvn(dsv, "...", 3);
-
- return SvPVX(dsv);
-}
-
-char *
Perl_sv_peek(pTHX_ SV *sv)
{
SV *t = sv_newmortal();
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));
}
Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127));
if (SvUTF8(sv))
- Perl_sv_catpvf(aTHX_ t, " [UTF8 %s]",
- sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv)));
+ Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
+ sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
+ UNI_DISPLAY_QQ));
SvREFCNT_dec(tmp);
}
}
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)) {
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) {
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");
}
}
else if (o->op_type == OP_EXIT) {
if (o->op_private & OPpEXIT_VMSISH)
- sv_catpv(tmpsv, ",EXIST_VMSISH");
+ sv_catpv(tmpsv, ",EXIT_VMSISH");
+ if (o->op_private & OPpHUSH_VMSISH)
+ sv_catpv(tmpsv, ",HUSH_VMSISH");
+ }
+ else if (o->op_type == OP_DIE) {
+ if (o->op_private & OPpHUSH_VMSISH)
+ sv_catpv(tmpsv, ",HUSH_VMSISH");
}
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
PerlIO_printf(file, "%s", pv_display(d, SvPVX(sv), SvCUR(sv), SvLEN(sv), pvlim));
if (SvUTF8(sv)) /* the 8? \x{....} */
- PerlIO_printf(file, " [UTF8 %s]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv)));
+ PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
PerlIO_printf(file, "\n");
Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
elt = hv_iterval(hv, he);
Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
if (SvUTF8(keysv))
- PerlIO_printf(file, "[UTF8 %s] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv)));
+ PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
}
{
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]);
+ }
+}
https://perl5.git.perl.org / perl5.git / blobdiff