X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5411ce9fb8ad873e4a86f799ff781c1fac61d4c2..a3874608cd3bf4e33ccd66b8bb03b2aeda20af14:/dump.c diff --git a/dump.c b/dump.c index 049f948..caf2f8c 100644 --- a/dump.c +++ b/dump.c @@ -1,7 +1,7 @@ /* 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, 2005, 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. @@ -13,12 +13,19 @@ * 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; +#define Sequence PL_op_sequence void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) @@ -46,17 +53,17 @@ Perl_dump_all(pTHX) } void -Perl_dump_packsubs(pTHX_ HV *stash) +Perl_dump_packsubs(pTHX_ const HV *stash) { I32 i; - HE *entry; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { + const HE *entry; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - GV *gv = (GV*)HeVAL(entry); - HV *hv; + const GV *gv = (GV*)HeVAL(entry); + const HV *hv; if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) continue; if (GvCVu(gv)) @@ -71,12 +78,12 @@ Perl_dump_packsubs(pTHX_ HV *stash) } void -Perl_dump_sub(pTHX_ GV *gv) +Perl_dump_sub(pTHX_ const GV *gv) { SV *sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv)); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); if (CvXSUB(GvCV(gv))) Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", PTR2UV(CvXSUB(GvCV(gv))), @@ -88,12 +95,12 @@ Perl_dump_sub(pTHX_ GV *gv) } void -Perl_dump_form(pTHX_ GV *gv) +Perl_dump_form(pTHX_ const GV *gv) { SV *sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX(sv)); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); if (CvROOT(GvFORM(gv))) op_dump(CvROOT(GvFORM(gv))); else @@ -107,30 +114,28 @@ Perl_dump_eval(pTHX) } char * -Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { - int truncated = 0; - int nul_terminated = len > cur && pv[cur] == '\0'; + const bool nul_terminated = len > cur && pv[cur] == '\0'; + bool truncated = 0; sv_setpvn(dsv, "\"", 1); for (; cur--; pv++) { if (pvlim && SvCUR(dsv) >= pvlim) { - truncated++; + truncated = 1; 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); @@ -148,6 +153,7 @@ Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) char * Perl_sv_peek(pTHX_ SV *sv) { + dVAR; SV *t = sv_newmortal(); STRLEN n_a; int unref = 0; @@ -187,7 +193,7 @@ Perl_sv_peek(pTHX_ SV *sv) !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| SVp_POK|SVp_NOK)) && SvCUR(sv) == 1 && - SvPVX(sv) && *SvPVX(sv) == '1' && + SvPVX_const(sv) && *SvPVX_const(sv) == '1' && SvNVX(sv) == 1.0) goto finish; } @@ -224,7 +230,7 @@ Perl_sv_peek(pTHX_ SV *sv) if (SvROK(sv)) { sv_catpv(t, "\\"); if (SvCUR(t) + unref > 10) { - SvCUR(t) = unref + 3; + SvCUR_set(t, unref + 3); *SvEND(t) = '\0'; sv_catpv(t, "..."); goto finish; @@ -291,14 +297,14 @@ Perl_sv_peek(pTHX_ SV *sv) } if (SvPOKp(sv)) { - if (!SvPVX(sv)) + if (!SvPVX_const(sv)) sv_catpv(t, "(null)"); else { SV *tmp = newSVpvn("", 0); sv_catpv(t, "("); if (SvOOK(sv)) - 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)); + Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); + Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(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), @@ -329,7 +335,7 @@ Perl_sv_peek(pTHX_ SV *sv) } void -Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm) +Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) { char ch; @@ -381,7 +387,7 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm) sv_catpv(tmpsv, ",RETAINT"); if (pm->op_pmflags & PMf_EVAL) sv_catpv(tmpsv, ",EVAL"); - Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); SvREFCNT_dec(tmpsv); } @@ -397,28 +403,25 @@ Perl_pmop_dump(pTHX_ PMOP *pm) /* An op sequencer. We visit the ops in the order they're to execute. */ STATIC void -sequence(pTHX_ register OP *o) +sequence(pTHX_ register const OP *o) { + dVAR; SV *op; char *key; STRLEN len; - static UV seq; - OP *oldop = 0, - *l; - - if (!Sequence) - Sequence = newHV(); + const OP *oldop = 0; + OP *l; if (!o) return; - op = newSVuv((UV) o); + op = newSVuv(PTR2UV(o)); key = SvPV(op, len); if (hv_exists(Sequence, key, len)) return; for (; o; o = o->op_next) { - op = newSVuv((UV) o); + op = newSVuv(PTR2UV(o)); key = SvPV(op, len); if (hv_exists(Sequence, key, len)) break; @@ -426,7 +429,7 @@ sequence(pTHX_ register OP *o) switch (o->op_type) { case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } goto nothin; @@ -440,7 +443,7 @@ sequence(pTHX_ register OP *o) nothin: if (oldop && o->op_next) continue; - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; case OP_MAPWHILE: @@ -453,7 +456,7 @@ sequence(pTHX_ register OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cLOGOPo->op_other; l && l->op_type == OP_NULL; l = l->op_next) ; sequence(aTHX_ l); @@ -461,7 +464,7 @@ sequence(pTHX_ register OP *o) case OP_ENTERLOOP: case OP_ENTERITER: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cLOOPo->op_redoop; l && l->op_type == OP_NULL; l = l->op_next) ; sequence(aTHX_ l); @@ -476,7 +479,7 @@ sequence(pTHX_ register OP *o) case OP_QR: case OP_MATCH: case OP_SUBST: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cPMOPo->op_pmreplstart; l && l->op_type == OP_NULL; l = l->op_next) ; sequence(aTHX_ l); @@ -486,7 +489,7 @@ sequence(pTHX_ register OP *o) break; default: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } oldop = o; @@ -494,36 +497,39 @@ sequence(pTHX_ register OP *o) } STATIC UV -sequence_num(pTHX_ OP *o) +sequence_num(pTHX_ const OP *o) { + dVAR; SV *op, **seq; char *key; STRLEN len; if (!o) return 0; - op = newSVuv((UV) o); + 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) +Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) { + dVAR; UV seq; sequence(aTHX_ o); Perl_dump_indent(aTHX_ level, file, "{\n"); level++; seq = sequence_num(aTHX_ o); if (seq) - PerlIO_printf(file, "%-4d", 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) - PerlIO_printf(file, seq ? "%d\n" : "(%d)\n", sequence_num(aTHX_ 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) { @@ -577,7 +583,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) sv_catpv(tmpsv, ",MOD"); if (o->op_flags & OPf_SPECIAL) sv_catpv(tmpsv, ",SPECIAL"); - Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); SvREFCNT_dec(tmpsv); } if (o->op_private) { @@ -747,7 +753,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) sv_catpv(tmpsv, ",INTRO"); if (SvCUR(tmpsv)) - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX(tmpsv) + 1); + Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); SvREFCNT_dec(tmpsv); } @@ -758,17 +764,19 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) #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: @@ -795,17 +803,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", sequence_num(aTHX_ cLOOPo->op_redoop)); + 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", sequence_num(aTHX_ cLOOPo->op_nextop)); + 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", sequence_num(aTHX_ cLOOPo->op_lastop)); + PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_lastop)); else PerlIO_printf(file, "DONE\n"); break; @@ -817,7 +825,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", sequence_num(aTHX_ cLOGOPo->op_other)); + PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOGOPo->op_other)); else PerlIO_printf(file, "DONE\n"); break; @@ -848,7 +856,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } void -Perl_op_dump(pTHX_ OP *o) +Perl_op_dump(pTHX_ const OP *o) { do_op_dump(0, Perl_debug_log, o); } @@ -865,10 +873,10 @@ Perl_gv_dump(pTHX_ GV *gv) sv = sv_newmortal(); PerlIO_printf(Perl_debug_log, "{\n"); gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv)); + Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv)); if (gv != GvEGV(gv)) { gv_efullname3(sv, GvEGV(gv), Nullch); - Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX(sv)); + Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv)); } PerlIO_putc(Perl_debug_log, '\n'); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); @@ -879,12 +887,15 @@ Perl_gv_dump(pTHX_ GV *gv) * (with the PERL_MAGIC_ prefixed stripped) */ -static struct { char type; char *name; } magic_names[] = { +static const struct { const char type; const char *name; } magic_names[] = { { PERL_MAGIC_sv, "sv(\\0)" }, { PERL_MAGIC_arylen, "arylen(#)" }, + { PERL_MAGIC_rhash, "rhash(%)" }, { PERL_MAGIC_glob, "glob(*)" }, { PERL_MAGIC_pos, "pos(.)" }, + { PERL_MAGIC_symtab, "symtab(:)" }, { PERL_MAGIC_backref, "backref(<)" }, + { PERL_MAGIC_arylen_p, "arylen_p(@)" }, { PERL_MAGIC_overload, "overload(A)" }, { PERL_MAGIC_bm, "bm(B)" }, { PERL_MAGIC_regdata, "regdata(D)" }, @@ -924,14 +935,14 @@ static struct { char type; char *name; } magic_names[] = { }; void -Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) +Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { for (; mg; mg = mg->mg_moremagic) { Perl_dump_indent(aTHX_ level, file, " MAGIC = 0x%"UVxf"\n", PTR2UV(mg)); if (mg->mg_virtual) { - MGVTBL *v = mg->mg_virtual; - char *s = 0; + const MGVTBL * const v = mg->mg_virtual; + const char *s = 0; if (v == &PL_vtbl_sv) s = "sv"; else if (v == &PL_vtbl_env) s = "env"; else if (v == &PL_vtbl_envelem) s = "envelem"; @@ -973,8 +984,8 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne { int n; - char *name = 0; - for (n=0; magic_names[n].name; n++) { + const char *name = 0; + for (n = 0; magic_names[n].name; n++) { if (mg->mg_type == magic_names[n].type) { name = magic_names[n].name; break; @@ -1042,23 +1053,24 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne } void -Perl_magic_dump(pTHX_ MAGIC *mg) +Perl_magic_dump(pTHX_ const MAGIC *mg) { do_magic_dump(0, Perl_debug_log, mg, 0, 0, 0, 0); } void -Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, char *name, HV *sv) +Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) { + const char *hvname; Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); - if (sv && HvNAME(sv)) - PerlIO_printf(file, "\t\"%s\"\n", HvNAME(sv)); + if (sv && (hvname = HvNAME_get(sv))) + PerlIO_printf(file, "\t\"%s\"\n", hvname); else PerlIO_putc(file, '\n'); } void -Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) +Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) { Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) @@ -1068,13 +1080,14 @@ Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) } void -Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) +Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) { Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) { + const char *hvname; PerlIO_printf(file, "\t\""); - if (GvSTASH(sv) && HvNAME(GvSTASH(sv))) - PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv))); + if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv)))) + PerlIO_printf(file, "%s\" :: \"", hvname); PerlIO_printf(file, "%s\"\n", GvNAME(sv)); } else @@ -1085,7 +1098,7 @@ void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { SV *d; - char *s; + const char *s; U32 flags; U32 type; @@ -1128,7 +1141,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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 (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,"); + if (flags & SVp_SCREAM && type != SVt_PVHV) + sv_catpv(d, "SCREAM,"); switch (type) { case SVt_PVCV: @@ -1151,6 +1165,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,"); if (HvREHASH(sv)) sv_catpv(d, "REHASH,"); + if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,"); break; case SVt_PVGV: case SVt_PVLV: if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); @@ -1185,15 +1200,28 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (flags & SVpad_TYPED) sv_catpv(d, "TYPED,"); break; + case SVt_PVAV: + break; } - if ((SvPOK(sv) || SvPOKp(sv)) && SvUTF8(sv)) + /* SVphv_SHAREKEYS is also 0x20000000 */ + if ((type != SVt_PVHV) && SvUTF8(sv)) sv_catpv(d, "UTF8"); - if (*(SvEND(d) - 1) == ',') - SvPVX(d)[--SvCUR(d)] = '\0'; + if (*(SvEND(d) - 1) == ',') { + SvCUR_set(d, SvCUR(d) - 1); + SvPVX(d)[SvCUR(d)] = '\0'; + } sv_catpv(d, ")"); - s = SvPVX(d); - + s = SvPVX_const(d); + +#ifdef DEBUG_LEAKING_SCALARS + Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n", + sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", + sv->sv_debug_line, + sv->sv_debug_inpad ? "for" : "by", + sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", + sv->sv_debug_cloned ? " (cloned)" : ""); +#endif Perl_dump_indent(aTHX_ level, file, "SV = "); switch (type) { case SVt_NULL: @@ -1250,7 +1278,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SvREFCNT_dec(d); return; } - if (type >= SVt_PVIV || type == SVt_IV) { + if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV) + || type == SVt_IV) { if (SvIsUV(sv) #ifdef PERL_COPY_ON_WRITE || SvIsCOW(sv) @@ -1269,7 +1298,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo #endif PerlIO_putc(file, '\n'); } - if (type >= SVt_PVNV || type == SVt_NV) { + if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV) + || type == SVt_NV) { STORE_NUMERIC_LOCAL_SET_STANDARD(); /* %Vg doesn't work? --jhi */ #ifdef USE_LONG_DOUBLE @@ -1289,11 +1319,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo return; } if (type <= SVt_PVLV && type != SVt_PVGV) { - if (SvPVX(sv)) { - Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv))); + if (SvPVX_const(sv)) { + Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv))); if (SvOOK(sv)) - 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)); + PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); + PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim)); if (SvUTF8(sv)) /* the 8? \x{....} */ PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ)); PerlIO_printf(file, "\n"); @@ -1320,13 +1350,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_putc(file, '\n'); Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv)); Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv)); - Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", PTR2UV(AvARYLEN(sv))); - flags = AvFLAGS(sv); - sv_setpv(d, ""); - if (flags & AVf_REAL) sv_catpv(d, ",REAL"); - if (flags & AVf_REIFY) sv_catpv(d, ",REIFY"); - if (flags & AVf_REUSED) sv_catpv(d, ",REUSED"); - Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", SvCUR(d) ? SvPVX(d) + 1 : ""); + Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); + sv_setpvn(d, "", 0); + if (AvREAL(sv)) sv_catpv(d, ",REAL"); + if (AvREIFY(sv)) sv_catpv(d, ",REIFY"); + Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", + SvCUR(d) ? SvPVX_const(d) + 1 : ""); if (nest < maxnest && av_len((AV*)sv) >= 0) { int count; for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) { @@ -1396,13 +1425,20 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv)); Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv)); Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); - Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER(sv)); - Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER(sv))); - if (HvPMROOT(sv)) - Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(HvPMROOT(sv))); - if (HvNAME(sv)) - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", HvNAME(sv)); - if (nest < maxnest && !HvEITER(sv)) { /* Try to preserve iterator */ + Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv)); + Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv))); + { + MAGIC *mg = mg_find(sv, PERL_MAGIC_symtab); + if (mg && mg->mg_obj) { + Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj)); + } + } + { + const char *hvname = HvNAME_get(sv); + if (hvname) + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); + } + if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ HE *he; HV *hv = (HV*)sv; int count = maxnest - nest; @@ -1411,7 +1447,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) && count--) { SV *elt, *keysv; - char *keypv; + const char *keypv; STRLEN len; U32 hash = HeHASH(he); @@ -1454,7 +1490,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo do_dump_pad(level+1, file, CvPADLIST(sv), 0); } { - CV *outside = CvOUTSIDE(sv); + const CV *outside = CvOUTSIDE(sv); Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", PTR2UV(outside), (!outside ? "null" @@ -1539,6 +1575,7 @@ Perl_runops_debug(pTHX) return 0; } + DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); do { PERL_ASYNC_CHECK(); if (PL_debug) { @@ -1561,18 +1598,15 @@ Perl_runops_debug(pTHX) 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; } I32 -Perl_debop(pTHX_ OP *o) +Perl_debop(pTHX_ const OP *o) { - AV *padlist, *comppad; - CV *cv; - SV *sv; - if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -1584,7 +1618,7 @@ Perl_debop(pTHX_ OP *o) case OP_GVSV: case OP_GV: if (cGVOPo_gv) { - sv = NEWSV(0,0); + SV *sv = NEWSV(0,0); gv_fullname3(sv, cGVOPo_gv, Nullch); PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); SvREFCNT_dec(sv); @@ -1595,11 +1629,13 @@ Perl_debop(pTHX_ OP *o) case OP_PADSV: case OP_PADAV: case OP_PADHV: + { /* print the lexical's name */ - cv = deb_curcv(cxstack_ix); + CV *cv = deb_curcv(cxstack_ix); + SV *sv; if (cv) { - padlist = CvPADLIST(cv); - comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); + AV *padlist = CvPADLIST(cv); + AV *comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); sv = *av_fetch(comppad, o->op_targ, FALSE); } else sv = Nullsv; @@ -1607,6 +1643,7 @@ Perl_debop(pTHX_ OP *o) PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); else PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ); + } break; default: break; @@ -1618,7 +1655,7 @@ Perl_debop(pTHX_ OP *o) STATIC CV* S_deb_curcv(pTHX_ I32 ix) { - PERL_CONTEXT *cx = &cxstack[ix]; + const 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)) @@ -1641,7 +1678,7 @@ Perl_watch(pTHX_ char **addr) } STATIC void -S_debprof(pTHX_ OP *o) +S_debprof(pTHX_ const OP *o) { if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return; @@ -1663,3 +1700,13 @@ Perl_debprofdump(pTHX) PL_op_name[i]); } } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */