X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eb160463266f58ba83ae9bb9ae8bbdc8f0c3027b..be92ff21b1b31bf647f96c308fe1a246f1974bde:/dump.c diff --git a/dump.c b/dump.c index 969fac5..abfddd0 100644 --- a/dump.c +++ b/dump.c @@ -1,6 +1,7 @@ /* dump.c * - * Copyright (c) 1991-2002, 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. @@ -17,6 +18,8 @@ #include "perl.h" #include "regcomp.h" +static HV *Sequence; + void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) { @@ -75,8 +78,8 @@ Perl_dump_sub(pTHX_ GV *gv) 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))); @@ -115,19 +118,17 @@ Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) 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); @@ -159,7 +160,7 @@ Perl_sv_peek(pTHX_ SV *sv) 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| @@ -177,7 +178,7 @@ Perl_sv_peek(pTHX_ SV *sv) 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)) && @@ -188,17 +189,36 @@ Perl_sv_peek(pTHX_ SV *sv) 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, ""); } - if (SvROK(sv)) { sv_catpv(t, "\\"); if (SvCUR(t) + unref > 10) { @@ -372,24 +392,137 @@ Perl_pmop_dump(pTHX_ PMOP *pm) 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) { @@ -399,7 +532,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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)); @@ -461,8 +595,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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) @@ -605,6 +737,12 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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)) @@ -617,30 +755,37 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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); - 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: - Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv)); +#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)); @@ -651,17 +796,17 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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; @@ -673,7 +818,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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; @@ -731,7 +876,7 @@ Perl_gv_dump(pTHX_ GV *gv) } -/* map magic types to the symbolic name +/* map magic types to the symbolic names * (with the PERL_MAGIC_ prefixed stripped) */ @@ -747,6 +892,7 @@ static struct { char type; char *name; } magic_names[] = { { 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)" }, @@ -760,13 +906,17 @@ static struct { char type; char *name; } magic_names[] = { { 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(~)" }, @@ -810,6 +960,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne 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 @@ -840,13 +991,15 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne 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) { @@ -859,9 +1012,11 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne 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"); @@ -872,6 +1027,18 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne 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]); + } + } } } @@ -907,7 +1074,7 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) 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)); } @@ -922,7 +1089,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo char *s; U32 flags; U32 type; - STRLEN n_a; if (!sv) { Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); @@ -938,7 +1104,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (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,"); @@ -958,7 +1124,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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,"); @@ -976,13 +1143,17 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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: + 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,"); @@ -1016,7 +1187,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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) == ',') @@ -1081,12 +1252,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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) { @@ -1103,14 +1284,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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); 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)) @@ -1132,14 +1311,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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)) { @@ -1251,6 +1422,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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); } @@ -1259,12 +1432,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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)); 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)); @@ -1273,34 +1446,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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); @@ -1315,7 +1467,16 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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)); @@ -1387,7 +1548,16 @@ Perl_runops_debug(pTHX) "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n", PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), PTR2UV(*PL_watchaddr)); - if (DEBUG_s_TEST_) debstack(); + 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); } @@ -1403,7 +1573,6 @@ Perl_debop(pTHX_ OP *o) AV *padlist, *comppad; CV *cv; SV *sv; - STRLEN n_a; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -1418,7 +1587,7 @@ Perl_debop(pTHX_ OP *o) if (cGVOPo_gv) { sv = NEWSV(0,0); gv_fullname3(sv, cGVOPo_gv, Nullch); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); SvREFCNT_dec(sv); } else