X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/091ab6010f97a3f49489e8fb6c7cc430e9479bff..e4305a6302fd35f8f8c1a7e612369beaaea58a4a:/dump.c diff --git a/dump.c b/dump.c index ef07cc5..c820687 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, 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. @@ -12,11 +13,20 @@ * 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" +#define Sequence PL_op_sequence + void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) { @@ -43,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)) @@ -68,15 +78,15 @@ 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%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))); @@ -85,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 @@ -104,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); @@ -145,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; @@ -159,7 +168,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,32 +186,51 @@ 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)) && !(~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; } + 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) { - SvCUR(t) = unref + 3; + SvCUR_set(t, unref + 3); *SvEND(t) = '\0'; sv_catpv(t, "..."); goto finish; @@ -269,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), @@ -307,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; @@ -359,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); } @@ -372,24 +400,136 @@ 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 const OP *o) +{ + dVAR; + SV *op; + char *key; + STRLEN len; + const OP *oldop = 0; + OP *l; + + 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(++PL_op_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(++PL_op_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(++PL_op_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(++PL_op_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(++PL_op_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(++PL_op_seq), 0); + break; + } + oldop = o; + } +} + +STATIC UV +sequence_num(pTHX_ const OP *o) +{ + dVAR; + 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) +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++; - 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 +539,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)); @@ -442,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) { @@ -461,8 +602,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,10 +744,16 @@ 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)) - 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); } @@ -617,30 +762,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 +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", 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 +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", cLOGOPo->op_other->op_seq); + PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOGOPo->op_other)); else PerlIO_printf(file, "DONE\n"); break; @@ -704,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); } @@ -721,25 +873,27 @@ 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"); } -/* map magic types to the symbolic name +/* map magic types to the symbolic names * (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_overload, "overload(A)" }, { PERL_MAGIC_bm, "bm(B)" }, @@ -747,6 +901,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 +915,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(~)" }, @@ -775,14 +934,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"; @@ -810,6 +969,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 @@ -823,8 +983,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; @@ -840,13 +1000,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 +1021,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,27 +1036,40 @@ 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]); + } + } } } 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)) @@ -902,13 +1079,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)) - 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 @@ -919,10 +1097,9 @@ 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; - STRLEN n_a; if (!sv) { Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); @@ -938,7 +1115,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,11 +1135,13 @@ 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,"); - if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,"); + if (flags & SVp_SCREAM && type != SVt_PVHV) + sv_catpv(d, "SCREAM,"); switch (type) { case SVt_PVCV: @@ -976,12 +1155,18 @@ 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,"); + if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,"); 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,"); @@ -1014,15 +1199,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) && 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: @@ -1079,16 +1277,28 @@ 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 (SvIsUV(sv)) + if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV) + || type == SVt_IV) { + 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) { + 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 @@ -1102,19 +1312,17 @@ 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 (SvPVX(sv)) { - Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv))); + if (type <= SVt_PVLV && type != SVt_PVGV) { + 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"); @@ -1131,14 +1339,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)) { @@ -1150,12 +1350,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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 : ""); + 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++) { @@ -1180,7 +1379,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, " ("); Zero(freq, FREQ_MAX + 1, int); - for (i = 0; i <= HvMAX(sv); i++) { + for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { HE* h; int count = 0; for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) count++; @@ -1225,21 +1424,29 @@ 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; hv_iterinit(hv); - while ((he = hv_iternext(hv)) && count--) { + while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) + && count--) { SV *elt, *keysv; - char *keypv; + const char *keypv; STRLEN len; U32 hash = HeHASH(he); @@ -1249,6 +1456,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); } @@ -1257,12 +1466,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)); @@ -1271,37 +1480,16 @@ 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); + const CV *outside = CvOUTSIDE(sv); Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", PTR2UV(outside), (!outside ? "null" @@ -1313,7 +1501,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)); @@ -1373,10 +1570,11 @@ Perl_runops_debug(pTHX) { if (!PL_op) { if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN"); + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); return 0; } + DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); do { PERL_ASYNC_CHECK(); if (PL_debug) { @@ -1385,24 +1583,29 @@ 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); } } 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; - STRLEN n_a; - if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -1414,9 +1617,9 @@ 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(sv, n_a)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); SvREFCNT_dec(sv); } else @@ -1425,11 +1628,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; @@ -1437,6 +1642,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; @@ -1448,7 +1654,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)) @@ -1471,7 +1677,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; @@ -1493,3 +1699,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: + */