X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=2a3439aca8e714cdd95caa3199e28514500662bd;hb=b69c7e13638df93b8184f0ab25c064bbde4b32e0;hp=50304302324abf6021f5ff1c60a4790e803fc8a6;hpb=e9569a7a55e6b33419f56b3697245a199938eb42;p=p5sagit%2Fp5-mst-13.2.git diff --git a/dump.c b/dump.c index 5030430..2a3439a 100644 --- a/dump.c +++ b/dump.c @@ -219,8 +219,10 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, const char * const end = pv + count; /* end of string */ octbuf[0] = esc; - if (!flags & PERL_PV_ESCAPE_NOCLEAR) + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) { + /* This won't alter the UTF-8 flag */ sv_setpvn(dsv, "", 0); + } if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; @@ -279,6 +281,12 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { + /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range + 128-255 can be appended raw to the dsv. If dsv happens to be + UTF-8 then we need catpvf to upgrade them for us. + Or add a new API call sv_catpvc(). Think about that name, and + how to keep it clear that it's unlike the s of catpvs, which is + really an array octets, not a string. */ Perl_sv_catpvf( aTHX_ dsv, "%c", c); wrote++; } @@ -296,21 +304,21 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, |const U32 flags Converts a string into something presentable, handling escaping via -pv_escape() and supporting quoting and elipses. +pv_escape() and supporting quoting and ellipses. If the PERL_PV_PRETTY_QUOTE flag is set then the result will be double quoted with any double quotes in the string escaped. Otherwise if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in angle brackets. -If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in -string were output then an elipses C<...> will be appended to the +If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in +string were output then an ellipsis C<...> will be appended to the string. Note that this happens AFTER it has been quoted. If start_color is non-null then it will be inserted after the opening quote (if there is one) but before the escaped text. If end_color is non-null then it will be inserted after the escaped text but before -any quotes or elipses. +any quotes or ellipses. Returns a pointer to the prettified text as held by dsv. @@ -325,12 +333,15 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { + /* This won't alter the UTF-8 flag */ + sv_setpvn(dsv, "", 0); + } + if ( dq == '"' ) - sv_setpvn(dsv, "\"", 1); + sv_catpvn(dsv, "\"", 1); else if ( flags & PERL_PV_PRETTY_LTGT ) - sv_setpvn(dsv, "<", 1); - else - sv_setpvn(dsv, "", 0); + sv_catpvn(dsv, "<", 1); if ( start_color != NULL ) Perl_sv_catpv( aTHX_ dsv, start_color); @@ -345,7 +356,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, else if ( flags & PERL_PV_PRETTY_LTGT ) sv_catpvn( dsv, ">", 1); - if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) ) + if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) sv_catpvn( dsv, "...", 3 ); return SvPVX(dsv); @@ -631,7 +642,7 @@ S_sequence(pTHX_ register const OP *o) 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); + (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } goto nothin; @@ -649,7 +660,7 @@ S_sequence(pTHX_ register const OP *o) nothin: if (oldop && o->op_next) continue; - hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); + (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; case OP_MAPWHILE: @@ -662,20 +673,20 @@ S_sequence(pTHX_ register const OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); + (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); sequence_tail(cLOGOPo->op_other); break; case OP_ENTERLOOP: case OP_ENTERITER: - hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); + (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); sequence_tail(cLOOPo->op_redoop); sequence_tail(cLOOPo->op_nextop); sequence_tail(cLOOPo->op_lastop); break; case OP_SUBST: - hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); + (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart); break; @@ -685,7 +696,7 @@ S_sequence(pTHX_ register const OP *o) break; default: - hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); + (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } oldop = o; @@ -1276,7 +1287,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 SV * const dsv = sv_newmortal(); const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen, 60, NULL, NULL, - ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELIPSES | + ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0)) ); Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); @@ -1865,7 +1876,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest, dumpops, pvlim); } - Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv)); if (isPRINT(IoTYPE(sv))) Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); else @@ -1880,7 +1890,10 @@ void Perl_sv_dump(pTHX_ SV *sv) { dVAR; - do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); + if (SvROK(sv)) + do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); + else + do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); } int @@ -2102,7 +2115,7 @@ Perl_xmldump_sub(pTHX_ const GV *gv) { SV * const sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); + gv_fullname3(sv, gv, NULL); Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv)); if (CvXSUB(GvCV(gv))) Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n", @@ -2119,7 +2132,7 @@ Perl_xmldump_form(pTHX_ const GV *gv) { SV * const sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); + gv_fullname3(sv, gv, NULL); Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv)); if (CvROOT(GvFORM(gv))) op_xmldump(CvROOT(GvFORM(gv))); @@ -2224,16 +2237,16 @@ Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c); break; case '<': - Perl_sv_catpvf(aTHX_ dsv, "<"); + sv_catpvs(dsv, "<"); break; case '>': - Perl_sv_catpvf(aTHX_ dsv, ">"); + sv_catpvs(dsv, ">"); break; case '&': - Perl_sv_catpvf(aTHX_ dsv, "&"); + sv_catpvs(dsv, "&"); break; case '"': - Perl_sv_catpvf(aTHX_ dsv, """); + sv_catpvs(dsv, """); break; default: if (c < 0xD800) { @@ -2241,7 +2254,8 @@ Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c); } else { - Perl_sv_catpvf(aTHX_ dsv, "%c", c); + const char string = (char) c; + sv_catpvn(dsv, &string, 1); } break; } @@ -2437,10 +2451,9 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) Perl_xmldump_indent(aTHX_ level, file, "precomp; - SV * const tmpsv = newSVpvn("",0); + const regexp *const r = PM_GETRE(pm); + SV * const tmpsv = newSVpvn(r->precomp,r->prelen); SvUTF8_on(tmpsv); - sv_catxmlpvn(tmpsv, s, strlen(s), 1); Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n", SvPVX(tmpsv)); SvREFCNT_dec(tmpsv); @@ -2734,7 +2747,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) ENTER; SAVEFREESV(tmpsv1); SAVEFREESV(tmpsv2); - gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch); + gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL); s = SvPV(tmpsv1,len); sv_catxmlpvn(tmpsv2, s, len, 1); S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));