/* dump.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
gv_fullname3(sv, gv, Nullch);
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv));
if (CvXSUB(GvCV(gv)))
- Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%lx %d)\n",
- (long)CvXSUB(GvCV(gv)),
+ Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
+ PTR2UV(CvXSUB(GvCV(gv))),
(int)CvXSUBANY(GvCV(gv)).any_i32);
else if (CvROOT(GvCV(gv)))
op_dump(CvROOT(GvCV(gv)));
}
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, "WILD");
goto finish;
}
- else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes) {
+ else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
if (sv == &PL_sv_undef) {
sv_catpv(t, "SV_UNDEF");
if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
SvNVX(sv) == 0.0)
goto finish;
}
- else {
+ else if (sv == &PL_sv_yes) {
sv_catpv(t, "SV_YES");
if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
SvNVX(sv) == 1.0)
goto finish;
}
+ else {
+ sv_catpv(t, "SV_PLACEHOLDER");
+ if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
+ SVs_GMG|SVs_SMG|SVs_RMG)) &&
+ SvREADONLY(sv))
+ goto finish;
+ }
sv_catpv(t, ":");
}
else if (SvREFCNT(sv) == 0) {
sv_catpv(t, "(");
unref++;
}
- else if (DEBUG_R_TEST && SvREFCNT(sv) > 1) {
- Perl_sv_catpvf(aTHX_ t, "<%"UVuf">", (UV)SvREFCNT(sv));
+ else if (DEBUG_R_TEST_) {
+ int is_tmp = 0;
+ I32 ix;
+ /* is this SV on the tmps stack? */
+ for (ix=PL_tmps_ix; ix>=0; ix--) {
+ if (PL_tmps_stack[ix] == sv) {
+ is_tmp = 1;
+ break;
+ }
+ }
+ if (SvREFCNT(sv) > 1)
+ Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
+ is_tmp ? "T" : "");
+ else if (is_tmp)
+ sv_catpv(t, "<T>");
}
-
if (SvROK(sv)) {
sv_catpv(t, "\\");
if (SvCUR(t) + unref > 10) {
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)) {
if (o->op_targ == OP_NEXTSTATE)
{
if (CopLINE(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",CopLINE(cCOPo));
+ Perl_dump_indent(aTHX_ level, file, "LINE = %"UVf"\n",
+ (UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo))
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
CopSTASHPV(cCOPo));
else if (o->op_type == OP_AASSIGN) {
if (o->op_private & OPpASSIGN_COMMON)
sv_catpv(tmpsv, ",COMMON");
- if (o->op_private & OPpASSIGN_HASH)
- sv_catpv(tmpsv, ",HASH");
}
else if (o->op_type == OP_SASSIGN) {
if (o->op_private & OPpASSIGN_BACKWARDS)
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");
+ }
+ else if (OP_IS_FILETEST_ACCESS(o)) {
+ if (o->op_private & OPpFT_ACCESS)
+ sv_catpv(tmpsv, ",FT_ACCESS");
}
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
case OP_GVSV:
case OP_GV:
#ifdef USE_ITHREADS
- Perl_dump_indent(aTHX_ level, file, "PADIX = %d\n", cPADOPo->op_padix);
+ Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
#else
if (cSVOPo->op_sv) {
SV *tmpsv = NEWSV(0,0);
break;
case OP_CONST:
case OP_METHOD_NAMED:
- Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv));
+ Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
break;
case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
if (CopLINE(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",CopLINE(cCOPo));
+ Perl_dump_indent(aTHX_ level, file, "LINE = %"UVf"\n",
+ (UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo))
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
CopSTASHPV(cCOPo));
}
-/* map magic types to the symbolic name
+/* map magic types to the symbolic names
* (with the PERL_MAGIC_ prefixed stripped)
*/
{ PERL_MAGIC_env, "env(E)" },
{ PERL_MAGIC_isa, "isa(I)" },
{ PERL_MAGIC_dbfile, "dbfile(L)" },
+ { PERL_MAGIC_shared, "shared(N)" },
{ PERL_MAGIC_tied, "tied(P)" },
{ PERL_MAGIC_sig, "sig(S)" },
{ PERL_MAGIC_uvar, "uvar(U)" },
{ PERL_MAGIC_nkeys, "nkeys(k)" },
{ PERL_MAGIC_dbline, "dbline(l)" },
{ PERL_MAGIC_mutex, "mutex(m)" },
+ { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
{ PERL_MAGIC_collxfrm, "collxfrm(o)" },
{ PERL_MAGIC_tiedelem, "tiedelem(p)" },
{ PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
{ PERL_MAGIC_qr, "qr(r)" },
{ PERL_MAGIC_sigelem, "sigelem(s)" },
{ PERL_MAGIC_taint, "taint(t)" },
+ { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
{ PERL_MAGIC_vec, "vec(v)" },
+ { PERL_MAGIC_vstring, "vstring(V)" },
+ { PERL_MAGIC_utf8, "utf8(w)" },
{ PERL_MAGIC_substr, "substr(x)" },
{ PERL_MAGIC_defelem, "defelem(y)" },
{ PERL_MAGIC_ext, "ext(~)" },
else if (v == &PL_vtbl_amagic) s = "amagic";
else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
else if (v == &PL_vtbl_backref) s = "backref";
+ else if (v == &PL_vtbl_utf8) s = "utf8";
if (s)
Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
else
if (mg->mg_flags) {
Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
- if (mg->mg_flags & MGf_TAINTEDDIR)
+ if (mg->mg_type == PERL_MAGIC_envelem &&
+ mg->mg_flags & MGf_TAINTEDDIR)
Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
if (mg->mg_flags & MGf_REFCOUNTED)
Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
if (mg->mg_flags & MGf_GSKIP)
Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
- if (mg->mg_flags & MGf_MINMATCH)
+ if (mg->mg_type == PERL_MAGIC_regex_global &&
+ mg->mg_flags & MGf_MINMATCH)
Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
}
if (mg->mg_obj) {
if (mg->mg_ptr) {
Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
if (mg->mg_len >= 0) {
- SV *sv = newSVpvn("", 0);
- PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
- SvREFCNT_dec(sv);
+ if (mg->mg_type != PERL_MAGIC_utf8) {
+ SV *sv = newSVpvn("", 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");
PerlIO_puts(file, " ???? - please notify IZ");
PerlIO_putc(file, '\n');
}
+ if (mg->mg_type == PERL_MAGIC_utf8) {
+ STRLEN *cache = (STRLEN *) mg->mg_ptr;
+ if (cache) {
+ IV i;
+ for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
+ Perl_dump_indent(aTHX_ level, file,
+ " %2"IVdf": %"UVuf" -> %"UVuf"\n",
+ i,
+ (UV)cache[i * 2],
+ (UV)cache[i * 2 + 1]);
+ }
+ }
}
}
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv)) {
PerlIO_printf(file, "\t\"");
- if (GvSTASH(sv))
+ if (GvSTASH(sv) && HvNAME(GvSTASH(sv)))
PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv)));
PerlIO_printf(file, "%s\"\n", GvNAME(sv));
}
char *s;
U32 flags;
U32 type;
- STRLEN n_a;
if (!sv) {
Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
(int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
(int)(PL_dumpindent*level), "");
- if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,");
+ if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
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 & SVf_FAKE) sv_catpv(d, "FAKE,");
if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
- if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
+ if (flags & SVf_AMAGIC && type != SVt_PVHV)
+ sv_catpv(d, "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 (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
+ if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
+ if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
+ if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
+ if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
+ if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
break;
case SVt_PVGV:
if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
sv_catpv(d, "TYPED,");
break;
}
- if (SvPOK(sv) && SvUTF8(sv))
+ if ((SvPOK(sv) || SvPOKp(sv)) && SvUTF8(sv))
sv_catpv(d, "UTF8");
if (*(SvEND(d) - 1) == ',')
return;
}
if (type >= SVt_PVIV || type == SVt_IV) {
- if (SvIsUV(sv))
+ if (SvIsUV(sv)
+#ifdef PERL_COPY_ON_WRITE
+ || SvIsCOW(sv)
+#endif
+ )
Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
else
Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
if (SvOOK(sv))
PerlIO_printf(file, " (OFFSET)");
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW_shared_hash(sv))
+ PerlIO_printf(file, " (HASH)");
+ else if (SvIsCOW_normal(sv))
+ PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
+#endif
PerlIO_putc(file, '\n');
}
if (type >= SVt_PVNV || type == SVt_NV) {
Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
if (nest < maxnest)
do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
- SvREFCNT_dec(d);
- return;
}
if (type < SVt_PV) {
SvREFCNT_dec(d);
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, " %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));
Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
- /* XXX level+1 ??? */
- do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim);
+ if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
+ do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
+ dumpops, pvlim);
break;
case SVt_PVAV:
Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
PerlIO_printf(file, " (");
Zero(freq, FREQ_MAX + 1, int);
- for (i = 0; i <= HvMAX(sv); i++) {
+ for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
HE* h; int count = 0;
for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
count++;
int count = maxnest - nest;
hv_iterinit(hv);
- while ((he = hv_iternext(hv)) && count--) {
- SV *elt;
- char *key;
- I32 len;
+ while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
+ && count--) {
+ SV *elt, *keysv;
+ char *keypv;
+ STRLEN len;
U32 hash = HeHASH(he);
- key = hv_iterkey(he, &len);
+ keysv = hv_iterkeysv(he);
+ keypv = SvPV(keysv, len);
elt = hv_iterval(hv, he);
- Perl_dump_indent(aTHX_ level+1, file, "Elt %s HASH = 0x%"UVxf"\n", pv_display(d, key, len, 0, pvlim), (UV)hash);
+ 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), UNI_DISPLAY_QQ));
+ if (HeKREHASH(he))
+ PerlIO_printf(file, "[REHASH] ");
+ PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)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))
- Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV(sv,n_a));
+ Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV_nolen(sv));
/* FALL THROUGH */
case SVt_PVFM:
do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
-#ifdef USE_5005THREADS
- Perl_dump_indent(aTHX_ level, file, " MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv)));
- Perl_dump_indent(aTHX_ level, file, " OWNER = 0x%"UVxf"\n", PTR2UV(CvOWNER(sv)));
-#endif /* USE_5005THREADS */
Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
+ Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
if (type == SVt_PVFM)
Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(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]))
- Perl_dump_indent(aTHX_ level,
- /* %5d below is enough whitespace. */
- file,
- "%5d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
- (int)ix, PTR2UV(ppad[ix]),
- SvFAKE(pname[ix]) ? "FAKE " : "",
- SvPVX(pname[ix]),
- (IV)SvNVX(pname[ix]),
- (IV)SvIVX(pname[ix]));
- }
+ if (nest < maxnest) {
+ do_dump_pad(level+1, file, CvPADLIST(sv), 0);
}
{
CV *outside = CvOUTSIDE(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_ packWARN(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_) {
+ if (DEBUG_v_TEST_) {
+ PerlIO_printf(Perl_debug_log, "\n");
+ deb_stack_all();
+ }
+ else
+ 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;
+
+ if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+ return 0;
+
+ 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_nolen(sv));
+ 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 (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+ return;
+ 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