/* dump.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 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, ...)
{
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);
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_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");
+ 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");
#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);
- 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;
+ 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_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;
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)));
- 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)));
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