/* dump.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 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.
* it has not been hard for me to read your mind and memory.'"
*/
+/* This file contains utility routines to dump the contents of SV and OP
+ * structures, as used by command-line options like -Dt and -Dx, and
+ * by Devel::Peek.
+ *
+ * It also holds the debugging version of the runops function.
+ */
+
#include "EXTERN.h"
#define PERL_IN_DUMP_C
#include "perl.h"
#include "regcomp.h"
+static HV *Sequence;
+
void
Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
SV *sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
- Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %"SVf" = ", sv);
+ 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%"UVxf" %d)\n",
PTR2UV(CvXSUB(GvCV(gv))),
SV *sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
- Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %"SVf" = ", sv);
+ Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX(sv));
if (CvROOT(GvFORM(gv)))
op_dump(CvROOT(GvFORM(gv)));
else
truncated++;
break;
}
- if (isPRINT(*pv)) {
- switch (*pv) {
- case '\t': sv_catpvn(dsv, "\\t", 2); break;
- case '\n': sv_catpvn(dsv, "\\n", 2); break;
- case '\r': sv_catpvn(dsv, "\\r", 2); break;
- case '\f': sv_catpvn(dsv, "\\f", 2); break;
- case '"': sv_catpvn(dsv, "\\\"", 2); break;
- case '\\': sv_catpvn(dsv, "\\\\", 2); break;
- default: sv_catpvn(dsv, pv, 1); break;
- }
- }
- else {
- if (cur && isDIGIT(*(pv+1)))
+ switch (*pv) {
+ case '\t': sv_catpvn(dsv, "\\t", 2); break;
+ case '\n': sv_catpvn(dsv, "\\n", 2); break;
+ case '\r': sv_catpvn(dsv, "\\r", 2); break;
+ case '\f': sv_catpvn(dsv, "\\f", 2); break;
+ case '"': sv_catpvn(dsv, "\\\"", 2); break;
+ case '\\': sv_catpvn(dsv, "\\\\", 2); break;
+ default:
+ if (isPRINT(*pv))
+ sv_catpvn(dsv, pv, 1);
+ else if (cur && isDIGIT(*(pv+1)))
Perl_sv_catpvf(aTHX_ dsv, "\\%03o", (U8)*pv);
else
Perl_sv_catpvf(aTHX_ dsv, "\\%o", (U8)*pv);
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) {
do_pmop_dump(0, Perl_debug_log, pm);
}
+/* An op sequencer. We visit the ops in the order they're to execute. */
+
+STATIC void
+sequence(pTHX_ register OP *o)
+{
+ SV *op;
+ char *key;
+ STRLEN len;
+ static UV seq;
+ OP *oldop = 0,
+ *l;
+
+ if (!Sequence)
+ Sequence = newHV();
+
+ if (!o)
+ return;
+
+ op = newSVuv(PTR2UV(o));
+ key = SvPV(op, len);
+ if (hv_exists(Sequence, key, len))
+ return;
+
+ for (; o; o = o->op_next) {
+ op = newSVuv(PTR2UV(o));
+ key = SvPV(op, len);
+ if (hv_exists(Sequence, key, len))
+ break;
+
+ switch (o->op_type) {
+ case OP_STUB:
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
+ hv_store(Sequence, key, len, newSVuv(++seq), 0);
+ break;
+ }
+ goto nothin;
+ case OP_NULL:
+ if (oldop && o->op_next)
+ continue;
+ break;
+ case OP_SCALAR:
+ case OP_LINESEQ:
+ case OP_SCOPE:
+ nothin:
+ if (oldop && o->op_next)
+ continue;
+ hv_store(Sequence, key, len, newSVuv(++seq), 0);
+ break;
+
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
+ case OP_AND:
+ case OP_OR:
+ case OP_DOR:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
+ case OP_DORASSIGN:
+ case OP_COND_EXPR:
+ case OP_RANGE:
+ hv_store(Sequence, key, len, newSVuv(++seq), 0);
+ for (l = cLOGOPo->op_other; l && l->op_type == OP_NULL; l = l->op_next)
+ ;
+ sequence(aTHX_ l);
+ break;
+
+ case OP_ENTERLOOP:
+ case OP_ENTERITER:
+ hv_store(Sequence, key, len, newSVuv(++seq), 0);
+ for (l = cLOOPo->op_redoop; l && l->op_type == OP_NULL; l = l->op_next)
+ ;
+ sequence(aTHX_ l);
+ for (l = cLOOPo->op_nextop; l && l->op_type == OP_NULL; l = l->op_next)
+ ;
+ sequence(aTHX_ l);
+ for (l = cLOOPo->op_lastop; l && l->op_type == OP_NULL; l = l->op_next)
+ ;
+ sequence(aTHX_ l);
+ break;
+
+ case OP_QR:
+ case OP_MATCH:
+ case OP_SUBST:
+ hv_store(Sequence, key, len, newSVuv(++seq), 0);
+ for (l = cPMOPo->op_pmreplstart; l && l->op_type == OP_NULL; l = l->op_next)
+ ;
+ sequence(aTHX_ l);
+ break;
+
+ case OP_HELEM:
+ break;
+
+ default:
+ hv_store(Sequence, key, len, newSVuv(++seq), 0);
+ break;
+ }
+ oldop = o;
+ }
+}
+
+STATIC UV
+sequence_num(pTHX_ OP *o)
+{
+ SV *op,
+ **seq;
+ char *key;
+ STRLEN len;
+ if (!o) return 0;
+ op = newSVuv(PTR2UV(o));
+ key = SvPV(op, len);
+ seq = hv_fetch(Sequence, key, len, 0);
+ return seq ? SvUV(*seq): 0;
+}
+
void
Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
{
+ UV seq;
+ sequence(aTHX_ o);
Perl_dump_indent(aTHX_ level, file, "{\n");
level++;
- if (o->op_seq)
- PerlIO_printf(file, "%-4d", o->op_seq);
+ seq = sequence_num(aTHX_ o);
+ if (seq)
+ PerlIO_printf(file, "%-4"UVf, seq);
else
PerlIO_printf(file, " ");
PerlIO_printf(file,
"%*sTYPE = %s ===> ",
(int)(PL_dumpindent*level-4), "", OP_NAME(o));
- if (o->op_next) {
- if (o->op_seq)
- PerlIO_printf(file, "%d\n", o->op_next->op_seq);
- else
- PerlIO_printf(file, "(%d)\n", o->op_next->op_seq);
- }
+ if (o->op_next)
+ PerlIO_printf(file, seq ? "%"UVf"\n" : "(%"UVf")\n",
+ sequence_num(aTHX_ o->op_next));
else
PerlIO_printf(file, "DONE\n");
if (o->op_targ) {
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));
if (o->op_private & OPpHUSH_VMSISH)
sv_catpv(tmpsv, ",HUSH_VMSISH");
}
+ else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
+ if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
+ sv_catpv(tmpsv, ",FT_ACCESS");
+ if (o->op_private & OPpFT_STACKED)
+ sv_catpv(tmpsv, ",FT_STACKED");
+ }
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
if (SvCUR(tmpsv))
#ifdef USE_ITHREADS
Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
#else
- if (cSVOPo->op_sv) {
- SV *tmpsv = NEWSV(0,0);
- ENTER;
- SAVEFREESV(tmpsv);
- gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch);
- Perl_dump_indent(aTHX_ level, file, "GV = %"SVf"\n", tmpsv);
- LEAVE;
+ if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
+ if (cSVOPo->op_sv) {
+ SV *tmpsv = NEWSV(0,0);
+ STRLEN n_a;
+ ENTER;
+ SAVEFREESV(tmpsv);
+ gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch);
+ Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a));
+ LEAVE;
+ }
+ else
+ Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
}
- else
- Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
#endif
break;
case OP_CONST:
case OP_METHOD_NAMED:
+#ifndef USE_ITHREADS
+ /* with ITHREADS, consts are stored in the pad, and the right pad
+ * may not be active here, so skip */
Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
+#endif
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));
case OP_ENTERLOOP:
Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
if (cLOOPo->op_redoop)
- PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq);
+ PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_redoop));
else
PerlIO_printf(file, "DONE\n");
Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
if (cLOOPo->op_nextop)
- PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq);
+ PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_nextop));
else
PerlIO_printf(file, "DONE\n");
Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
if (cLOOPo->op_lastop)
- PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq);
+ PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_lastop));
else
PerlIO_printf(file, "DONE\n");
break;
case OP_AND:
Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
if (cLOGOPo->op_other)
- PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq);
+ PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOGOPo->op_other));
else
PerlIO_printf(file, "DONE\n");
break;
sv = sv_newmortal();
PerlIO_printf(Perl_debug_log, "{\n");
gv_fullname3(sv, gv, Nullch);
- Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %"SVf"", sv);
+ Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv));
if (gv != GvEGV(gv)) {
gv_efullname3(sv, GvEGV(gv), Nullch);
- Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %"SVf"", sv);
+ Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX(sv));
}
PerlIO_putc(Perl_debug_log, '\n');
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
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));
}
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 (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:
+ case SVt_PVGV: case SVt_PVLV:
if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
SvREFCNT_dec(d);
return;
}
- if (type <= SVt_PVLV) {
+ if (type <= SVt_PVLV && type != SVt_PVGV) {
if (SvPVX(sv)) {
Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv)));
if (SvOOK(sv))
do_hv_dump(level, file, " STASH", SvSTASH(sv));
}
switch (type) {
- case SVt_PVLV:
- Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(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);
- break;
case SVt_PVAV:
Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
if (AvARRAY(sv) != AvALLOC(sv)) {
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);
}
case SVt_PVFM:
do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
if (CvSTART(sv))
- Perl_dump_indent(aTHX_ level, file, " START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)CvSTART(sv)->op_seq);
+ Perl_dump_indent(aTHX_ level, file, " START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)sequence_num(aTHX_ CvSTART(sv)));
Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv)));
if (CvROOT(sv) && dumpops)
do_op_dump(level+1, file, CvROOT(sv));
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:
+ case SVt_PVGV: case SVt_PVLV:
+ if (type == SVt_PVLV) {
+ Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(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)));
+ if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
+ do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
+ dumpops, pvlim);
+ }
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
return 0;
}
+ DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
do {
PERL_ASYNC_CHECK();
if (PL_debug) {
if (DEBUG_P_TEST_) debprof(PL_op);
}
} while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+ DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
TAINT_NOT;
return 0;
https://perl5.git.perl.org / perl5.git / blobdiff