X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/145bf8eec5be8c17bd592ec8d28efb239bdafa93..636dfd4a89e23adad94a82ddc63188837eea8a48:/dump.c diff --git a/dump.c b/dump.c index 16ac581..2654402 100644 --- a/dump.c +++ b/dump.c @@ -96,7 +96,10 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, Escapes at most the first "count" chars of pv and puts the results into dsv such that the size of the escaped string will not exceed "max" chars -and will not contain any incomplete escape sequences. +and will not contain any incomplete escape sequences. The number of bytes +escaped will be returned in the STRLEN *escaped parameter if it is not null. +When the dsv parameter is null no escaping actually occurs, but the number +of bytes that would be escaped were it not null will be calculated. If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string will also be escaped. @@ -151,7 +154,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, PERL_ARGS_ASSERT_PV_ESCAPE; - if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) { + if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) { /* This won't alter the UTF-8 flag */ sv_setpvs(dsv, ""); } @@ -221,7 +224,8 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, if ( max && (wrote + chsize > max) ) { break; } else if (chsize > 1) { - sv_catpvn(dsv, octbuf, chsize); + if (dsv) + sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes @@ -230,7 +234,8 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, 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 of octets, not a string. */ - Perl_sv_catpvf( aTHX_ dsv, "%c", c); + if (dsv) + Perl_sv_catpvf( aTHX_ dsv, "%c", c); wrote++; } if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) @@ -238,7 +243,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, } if (escaped != NULL) *escaped= pv - str; - return SvPVX(dsv); + return dsv ? SvPVX(dsv) : NULL; } /* =for apidoc pv_pretty @@ -270,36 +275,51 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags ) { - const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" : + (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL); STRLEN escaped; + STRLEN max_adjust= 0; + STRLEN orig_cur; PERL_ARGS_ASSERT_PV_PRETTY; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { - /* This won't alter the UTF-8 flag */ - sv_setpvs(dsv, ""); + /* This won't alter the UTF-8 flag */ + sv_setpvs(dsv, ""); } + orig_cur= SvCUR(dsv); - if ( dq == '"' ) - sv_catpvs(dsv, "\""); - else if ( flags & PERL_PV_PRETTY_LTGT ) - sv_catpvs(dsv, "<"); + if ( quotes ) + Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]); if ( start_color != NULL ) sv_catpv(dsv, start_color); - - pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR ); - + + if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { + if (quotes) + max_adjust += 2; + assert(max > max_adjust); + pv_escape( NULL, str, count, max - max_adjust, &escaped, flags ); + if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) + max_adjust += 3; + assert(max > max_adjust); + } + + pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR ); + if ( end_color != NULL ) sv_catpv(dsv, end_color); - if ( dq == '"' ) - sv_catpvs( dsv, "\""); - else if ( flags & PERL_PV_PRETTY_LTGT ) - sv_catpvs(dsv, ">"); + if ( quotes ) + Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]); if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) sv_catpvs(dsv, "..."); + + if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { + while( SvCUR(dsv) - orig_cur < max ) + sv_catpvs(dsv," "); + } return SvPVX(dsv); } @@ -642,8 +662,8 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) else ch = '/'; if (PM_GETRE(pm)) - Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n", - ch, RX_PRECOMP(PM_GETRE(pm)), ch, + Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n", + ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch, (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); else Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n"); @@ -792,30 +812,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) if (o->op_targ) { if (optype == OP_NULL) { Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]); - if (o->op_targ == OP_NEXTSTATE) { - if (CopLINE(cCOPo)) - Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n", - (UV)CopLINE(cCOPo)); - if (CopSTASHPV(cCOPo)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - HV *stash = CopSTASH(cCOPo); - const char * const hvname = HvNAME_get(stash); - - Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", - generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash))); - } - if (CopLABEL(cCOPo)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - STRLEN label_len; - U32 label_flags; - const char *label = CopLABEL_len_flags(cCOPo, - &label_len, - &label_flags); - Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", - generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8))); - } - - } } else Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ); @@ -962,9 +958,13 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) #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)); + Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o))); #endif break; + case OP_NULL: + if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) + break; + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: if (CopLINE(cCOPo)) @@ -989,6 +989,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) generic_pv_escape( tmpsv, label, label_len, (label_flags & SVf_UTF8))); } + Perl_dump_indent(aTHX_ level, file, "SEQ = %d\n", + cCOPo->cop_seq); break; case OP_ENTERLOOP: Perl_dump_indent(aTHX_ level, file, "REDO ===> "); @@ -1363,6 +1365,7 @@ const struct flag_to_name regexp_extflags_names[] = { {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"}, {RXf_PMf_FOLD, "PMf_FOLD,"}, {RXf_PMf_EXTENDED, "PMf_EXTENDED,"}, + {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"}, {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"}, {RXf_IS_ANCHORED, "IS_ANCHORED,"}, {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"}, @@ -1980,10 +1983,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); 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)); - Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); - if (nest < maxnest) { - do_dump_pad(level+1, file, CvPADLIST(sv), 0); + if (!CvISXSUB(sv)) { + Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); + if (nest < maxnest) { + do_dump_pad(level+1, file, CvPADLIST(sv), 0); + } } + else + Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); { const CV * const outside = CvOUTSIDE(sv); Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",