#include "perl.h"
#include "regcomp.h"
+static HV *Sequence;
+
void
Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
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((UV) o);
+ key = SvPV(op, len);
+ if (hv_exists(Sequence, key, len))
+ return;
+
+ for (; o; o = o->op_next) {
+ op = newSVuv((UV) 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((UV) 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, "%-4d", 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 ? "%d\n" : "(%d)\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 (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");
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, "%d\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, "%d\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, "%d\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, "%d\n", sequence_num(aTHX_ cLOGOPo->op_other));
else
PerlIO_printf(file, "DONE\n");
break;
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)));
- 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));