In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e18c4116c82b2027a1e5d4e6b9a7214d60779053?hp=f4c617746504f38fcb281a2b1c1da9426d8eab01>
- Log ----------------------------------------------------------------- commit e18c4116c82b2027a1e5d4e6b9a7214d60779053 Author: David Mitchell <[email protected]> Date: Mon Jan 23 16:12:38 2017 +0000 dump.c: handle GV being really a ref to a CV RT #129285 These days a 'GV' can actually just be a ref to a CV when the only thing that would be stored in the glob is a CV. Update S_do_op_dump_bar() to handle this. Formerly it would trigger an assert on a non-threaded build. In fact, incorporate the fixed logic into a static function, S_gv_display(), that is shared by both S_do_op_dump_bar() and Perl_debop(); so both perl -Dx and perl -Dt get the benefit. Also for the -Dx case, make it display the raw address of the GV too. M dump.c M ext/Devel-Peek/t/Peek.t commit bf1c7d4ad82bf8cd8059466e31fadb0318adffe3 Author: David Mitchell <[email protected]> Date: Mon Jan 23 15:14:43 2017 +0000 reindent OP_AELEMFAST block in S_do_op_dump_bar() after previous commit removed an enclosing 'if' block. Whitespace-only change M dump.c commit 8217cd28dfa0c41f67d60dfda19d36280c922c01 Author: David Mitchell <[email protected]> Date: Mon Jan 23 15:10:12 2017 +0000 op_dump(): no OPf_SPECIAL on AELEMFAST,GVSV,GV between 5.14 and 5.16 pp_aelemfast changed from using OPf_SPECIAL to using op type to distinguish between a lexical or glob arg, but op_dump() hadn't been updated to reflect this. Also, GVSV and GV never used the OPf_SPECIAL flag, so testing for it with those ops was wrong (but currently harmless). M dump.c commit 6f3289f02701c220917a04baadb76473ebe3c89a Author: David Mitchell <[email protected]> Date: Mon Jan 23 14:58:29 2017 +0000 fix some more bizarre indention in dump.c (whitespace-only change) Not mentioning any names to protect the guilty, but about 3 years ago some code was committed to dump.c that had just bizarre indentation; for example, this if (foo) bar being more like if (foo) bar (and this is nothing to do with tab expansion). This commit fixes up the most glaring issues. M dump.c ----------------------------------------------------------------------- Summary of changes: dump.c | 106 +++++++++++++++++++++++++----------------------- ext/Devel-Peek/t/Peek.t | 4 +- 2 files changed, 58 insertions(+), 52 deletions(-) diff --git a/dump.c b/dump.c index fb07b12c1a..ce63f351e8 100644 --- a/dump.c +++ b/dump.c @@ -205,16 +205,16 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, chsize = 1; break; default: - if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) { + if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) { chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf, esc, u); - } - else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) ) - chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, + } + else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize))) + chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, "%c%03o", esc, c); - else - chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, + else + chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, "%c%o", esc, c); } } else { @@ -731,6 +731,37 @@ Perl_dump_eval(pTHX) } +/* returns a temp SV displaying the name of a GV. Handles the case where + * a GV is in fact a ref to a CV */ + +static SV * +S_gv_display(pTHX_ GV *gv) +{ + SV * const name = newSV(0); + if (gv) { + SV * const raw = newSVpvs_flags("", SVs_TEMP); + STRLEN len; + const char * rawpv; + + if (isGV_with_GP(gv)) + gv_fullname3(raw, gv, NULL); + else { + assert(SvROK(gv)); + assert(SvTYPE(SvRV(gv)) == SVt_PVCV); + Perl_sv_catpvf(aTHX_ raw, "cv ref: %s", + SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0))); + } + rawpv = SvPV_const(raw, len); + generic_pv_escape(name, rawpv, len, SvUTF8(raw)); + } + else + sv_catpvs(name, "(NULL)"); + + return name; +} + + + /* forward decl */ static void S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o); @@ -1073,20 +1104,9 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) S_opdump_indent(aTHX_ o, level, bar, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else - if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */ - if (cSVOPo->op_sv) { - STRLEN len; - const char * name; - SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); - SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP); - gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL); - name = SvPV_const(tmpsv, len); - S_opdump_indent(aTHX_ o, level, bar, file, "GV = %s\n", - generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv))); - } - else - S_opdump_indent(aTHX_ o, level, bar, file, "GV = NULL\n"); - } + S_opdump_indent(aTHX_ o, level, bar, file, + "GV = %" SVf " (0x%" UVxf ")\n", + SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv)); #endif break; @@ -1451,7 +1471,7 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) const char *hvname; HV * const stash = GvSTASH(sv); PerlIO_printf(file, "\t"); - /* TODO might have an extra \" here */ + /* TODO might have an extra \" here */ if (stash && (hvname = HvNAME_get(stash))) { PerlIO_printf(file, "\"%s\" :: \"", generic_pv_escape(tmp, hvname, @@ -1947,8 +1967,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo { const char * const hvname = HvNAME_get(sv); if (hvname) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", generic_pv_escape( tmpsv, hvname, HvNAMELEN(sv), HvNAMEUTF8(sv))); } @@ -1974,7 +1994,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo + (count < 0 ? -count : count); while (hekp < endp) { if (*hekp) { - SV *tmp = newSVpvs_flags("", SVs_TEMP); + SV *tmp = newSVpvs_flags("", SVs_TEMP); Perl_sv_catpvf(aTHX_ names, ", \"%s\"", generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp))); } else { @@ -2084,14 +2104,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo case SVt_PVCV: if (CvAUTOLOAD(sv)) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - STRLEN len; + STRLEN len; const char *const name = SvPV_const(sv, len); Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); } if (SvPOK(sv)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - const char *const proto = CvPROTO(sv); + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + const char *const proto = CvPROTO(sv); Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), SvUTF8(sv))); @@ -2186,13 +2206,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (isREGEXP(sv)) goto dumpregexp; if (!isGV_with_GP(sv)) break; - { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", - generic_pv_escape(tmpsv, GvNAME(sv), - GvNAMELEN(sv), - GvNAMEUTF8(sv))); - } + { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", + generic_pv_escape(tmpsv, GvNAME(sv), + GvNAMELEN(sv), + GvNAMEUTF8(sv))); + } Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); @@ -2667,22 +2687,8 @@ Perl_debop(pTHX_ const OP *o) break; case OP_GVSV: case OP_GV: - if (cGVOPo_gv && isGV(cGVOPo_gv)) { - SV * const sv = newSV(0); - gv_fullname3(sv, cGVOPo_gv, NULL); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); - SvREFCNT_dec_NN(sv); - } - else if (cGVOPo_gv) { - SV * const sv = newSV(0); - assert(SvROK(cGVOPo_gv)); - assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV); - PerlIO_printf(Perl_debug_log, "(cv ref: %s)", - SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0))); - SvREFCNT_dec_NN(sv); - } - else - PerlIO_printf(Perl_debug_log, "(NULL)"); + PerlIO_printf(Perl_debug_log, "(%" SVf ")", + SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); break; case OP_PADSV: diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index fa25b48f51..2b1ed5d562 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1490,7 +1490,7 @@ dumpindent is 4 at -e line 1. GV_OR_PADIX EODUMP - $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e; + $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e; $e =~ s/SVOP/PADOP/g if $threads; my $out = t::runperl switches => ['-Ilib'], @@ -1498,7 +1498,7 @@ EODUMP stderr=>1; $out =~ s/ *SEQ = .*\n//; $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g; - $out =~ s/0x[0-9a-f]{2,}\) ===/0xNNN) ===/g; + $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g; is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning"; } done_testing(); -- Perl5 Master Repository
