X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dc6240c9d6df97879ecb94e74011463d8dbdc837..ee3222e312cbf5cc89df7b3cb3bd2ab5bb4e6507:/dump.c diff --git a/dump.c b/dump.c index 2e0bc01..3e1b011 100644 --- a/dump.c +++ b/dump.c @@ -94,43 +94,43 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, /* =for apidoc pv_escape -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 +Escapes at most the first C chars of C and puts the results into +C such that the size of the escaped string will not exceed C chars 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 +escaped will be returned in the C parameter if it is not null. +When the C 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 +If flags contains C then any double quotes in the string will also be escaped. Normally the SV will be cleared before the escaped string is prepared, -but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur. +but when C is set this will not occur. -If PERL_PV_ESCAPE_UNI is set then the input string is treated as UTF-8 -if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned +If C is set then the input string is treated as UTF-8 +if C is set then the input string is scanned using C to determine if it is UTF-8. -If PERL_PV_ESCAPE_ALL is set then all input chars will be output -using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only +If C is set then all input chars will be output +using C<\x01F1> style escapes, otherwise if C is set, only non-ASCII chars will be escaped using this style; otherwise, only chars above 255 will be so escaped; other non printable chars will use octal or common escaped patterns like C<\n>. -Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH +Otherwise, if C then all chars below 255 will be treated as printable and will be output as literals. -If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the +If C is set then only the first char of the string will be escaped, regardless of max. If the output is to be in hex, then it will be returned as a plain hex sequence. Thus the output will either be a single char, an octal escape sequence, a special escape like C<\n> or a hex value. -If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and -not a '\\'. This is because regexes very often contain backslashed -sequences, whereas '%' is not a particularly common character in patterns. +If C is set then the escape char used will be a C<"%"> and +not a C<"\\">. This is because regexes very often contain backslashed +sequences, whereas C<"%"> is not a particularly common character in patterns. -Returns a pointer to the escaped text as held by dsv. +Returns a pointer to the escaped text as held by C. =cut */ @@ -156,7 +156,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) { /* This won't alter the UTF-8 flag */ - sv_setpvs(dsv, ""); + SvPVCLEAR(dsv); } if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) @@ -249,23 +249,23 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, =for apidoc pv_pretty Converts a string into something presentable, handling escaping via -pv_escape() and supporting quoting and ellipses. +C and supporting quoting and ellipses. -If the PERL_PV_PRETTY_QUOTE flag is set then the result will be +If the C 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 +if the C flag is set then the result be wrapped in angle brackets. -If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in +If the C 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 +If C is non-null then it will be inserted after the opening +quote (if there is one) but before the escaped text. If C is non-null then it will be inserted after the escaped text but before any quotes or ellipses. -Returns a pointer to the prettified text as held by dsv. +Returns a pointer to the prettified text as held by C. =cut */ @@ -285,7 +285,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { /* This won't alter the UTF-8 flag */ - sv_setpvs(dsv, ""); + SvPVCLEAR(dsv); } orig_cur= SvCUR(dsv); @@ -358,7 +358,7 @@ Perl_sv_peek(pTHX_ SV *sv) int unref = 0; U32 type; - sv_setpvs(t, ""); + SvPVCLEAR(t); retry: if (!sv) { sv_catpv(t, "VOID"); @@ -421,11 +421,14 @@ Perl_sv_peek(pTHX_ SV *sv) 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 (is_tmp || SvREFCNT(sv) > 1) { + Perl_sv_catpvf(aTHX_ t, "<"); + if (SvREFCNT(sv) > 1) + Perl_sv_catpvf(aTHX_ t, "%"UVuf, (UV)SvREFCNT(sv)); + if (is_tmp) + Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t"); + Perl_sv_catpvf(aTHX_ t, ">"); + } } if (SvROK(sv)) { @@ -477,9 +480,9 @@ Perl_sv_peek(pTHX_ SV *sv) } } else if (SvNOKp(sv)) { - STORE_NUMERIC_LOCAL_SET_STANDARD(); + STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); + RESTORE_LC_NUMERIC_UNDERLYING(); } else if (SvIOKp(sv)) { if (SvIsUV(sv)) @@ -670,10 +673,17 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); else Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n"); - if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) { - Perl_dump_indent(aTHX_ level, file, "PMf_REPL = "); - op_dump(pm->op_pmreplrootu.op_pmreplroot); + + if (pm->op_type == OP_SPLIT) + Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%"UVxf"\n", + PTR2UV(pm->op_pmreplrootu.op_pmtargetgv)); + else { + if (pm->op_pmreplrootu.op_pmreplroot) { + Perl_dump_indent(aTHX_ level, file, "PMf_REPL = "); + op_dump(pm->op_pmreplrootu.op_pmreplroot); + } } + if (pm->op_code_list) { if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n"); @@ -844,7 +854,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); - if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB"); + if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB"); Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); } @@ -968,6 +978,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) for (i=0; i < count; i++) Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n", i, items[i].uv); + break; } case OP_CONST: @@ -1042,7 +1053,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) else PerlIO_printf(file, "DONE\n"); break; - case OP_PUSHRE: + case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: @@ -1106,7 +1117,7 @@ Perl_gv_dump(pTHX_ GV *gv) Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", generic_pv_escape( tmp, name, len, SvUTF8(sv) )); } - PerlIO_putc(Perl_debug_log, '\n'); + (void)PerlIO_putc(Perl_debug_log, '\n'); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); } @@ -1116,7 +1127,7 @@ Perl_gv_dump(pTHX_ GV *gv) */ static const struct { const char type; const char *name; } magic_names[] = { -#include "mg_names.c" +#include "mg_names.inc" /* this null string terminates the list */ { 0, NULL }, }; @@ -1227,7 +1238,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 " ???? - " __FILE__ " does not know how to handle this MG_LEN" ); - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); } if (mg->mg_type == PERL_MAGIC_utf8) { const STRLEN * const cache = (STRLEN *) mg->mg_ptr; @@ -1270,7 +1281,7 @@ Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) HvNAMELEN(sv), HvNAMEUTF8(sv))); } else - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); } void @@ -1285,7 +1296,7 @@ Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) )); } else - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); } void @@ -1309,7 +1320,7 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv))); } else - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); } const struct flag_to_name first_sv_flags_names[] = { @@ -1415,7 +1426,6 @@ const struct flag_to_name regexp_core_intflags_names[] = { {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"}, {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"}, {PREGf_NOSCAN, "NOSCAN,"}, - {PREGf_CANY_SEEN, "CANY_SEEN,"}, {PREGf_GPOS_SEEN, "GPOS_SEEN,"}, {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"}, {PREGf_ANCH_MBOL, "ANCH_MBOL,"}, @@ -1423,6 +1433,16 @@ const struct flag_to_name regexp_core_intflags_names[] = { {PREGf_ANCH_GPOS, "ANCH_GPOS,"}, }; +/* Perl_do_sv_dump(): + * + * level: amount to indent the output + * sv: the object to dump + * nest: the current level of recursion + * maxnest: the maximum allowed level of recursion + * dumpops: if true, also dump the ops associated with a CV + * pvlim: limit on the length of any strings that are output + * */ + void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { @@ -1555,29 +1575,20 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) || (type == SVt_IV && !SvROK(sv))) { if (SvIsUV(sv) -#ifdef PERL_OLD_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)); -#ifdef PERL_OLD_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'); + (void)PerlIO_putc(file, '\n'); } if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) || type == SVt_NV) { - STORE_NUMERIC_LOCAL_SET_STANDARD(); + STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); + RESTORE_LC_NUMERIC_UNDERLYING(); } if (SvROK(sv)) { @@ -1630,7 +1641,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (!re) Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv)); -#ifdef PERL_NEW_COPY_ON_WRITE +#ifdef PERL_COPY_ON_WRITE if (SvIsCOW(sv) && SvLEN(sv)) Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", CowREFCNT(sv)); @@ -1661,24 +1672,26 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv))); } else - PerlIO_putc(file, '\n'); + (void)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", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); - sv_setpvs(d, ""); + SvPVCLEAR(d); 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_tindex(MUTABLE_AV(sv)) >= 0) { + if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { SSize_t count; - for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) { - SV** const elt = av_fetch(MUTABLE_AV(sv),count,0); - + SV **svp = AvARRAY(MUTABLE_AV(sv)); + for (count = 0; + count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest; + count++, svp++) + { + SV* const elt = *svp; Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count); - if (elt) - do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim); + do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); } } break; @@ -1722,7 +1735,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, ", "); } } - PerlIO_putc(file, ')'); + (void)PerlIO_putc(file, ')'); /* The "quality" of a hash is defined as the total number of comparisons needed to access every element once, relative to the expected number needed for a random hash. @@ -1741,10 +1754,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo pow2 = pow2 << 1; theoret = usedkeys; theoret += theoret * (theoret-1)/pow2; - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100); } - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys); { STRLEN count = 0; @@ -1760,15 +1773,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } while (++ents <= last); } - if (SvOOK(sv)) { - struct xpvhv_aux *const aux = HvAUX(sv); - Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf - " (cached = %"UVuf")\n", - (UV)count, (UV)aux->xhv_fill_lazy); - } else { - Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n", - (UV)count); - } + Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n", + (UV)count); } Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); if (SvOOK(sv)) { @@ -1780,7 +1786,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv)); } #endif - PerlIO_putc(file, '\n'); + (void)PerlIO_putc(file, '\n'); } { MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); @@ -1817,7 +1823,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names + (count < 0 ? -count : count); while (hekp < endp) { - if (HEK_LEN(*hekp)) { + if (*hekp) { 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))); @@ -1940,7 +1946,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); if (!CvISXSUB(sv)) { if (CvSTART(sv)) { - Perl_dump_indent(aTHX_ level, file, + if (CvSLABBED(sv)) + Perl_dump_indent(aTHX_ level, file, + " SLAB = 0x%"UVxf"\n", + PTR2UV(CvSTART(sv))); + else + Perl_dump_indent(aTHX_ level, file, " START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)sequence_num(CvSTART(sv))); @@ -2042,7 +2053,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf " (%s)\n", (UV)GvGPFLAGS(sv), - GvALIASED_SV(sv) ? "ALIASED_SV" : ""); + ""); Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv)); Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); do_gv_dump (level, file, " EGV", GvEGV(sv)); @@ -2211,6 +2222,8 @@ Perl_runops_debug(pTHX) ++PL_op_exec_cnt[PL_op->op_type]; #endif if (PL_debug) { + ENTER; + SAVETMPS; if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) PerlIO_printf(Perl_debug_log, "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n", @@ -2228,9 +2241,11 @@ Perl_runops_debug(pTHX) if (DEBUG_t_TEST_) debop(PL_op); if (DEBUG_P_TEST_) debprof(PL_op); + FREETMPS; + LEAVE; } - OP_ENTRY_PROBE(OP_NAME(PL_op)); + PERL_DTRACE_PROBE_OP(PL_op); } while ((PL_op = PL_op->op_ppaddr(aTHX))); DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); PERL_ASYNC_CHECK(); @@ -2242,7 +2257,7 @@ Perl_runops_debug(pTHX) /* print the names of the n lexical vars starting at pad offset off */ -void +STATIC void S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren) { PADNAME *sv; @@ -2318,7 +2333,7 @@ S_append_gv_name(pTHX_ GV *gv, SV *out) } sv = newSV(0); gv_fullname4(sv, gv, NULL, FALSE); - Perl_sv_catpvf(aTHX_ out, "%c%-p", '$', sv); + Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv)); SvREFCNT_dec_NN(sv); } @@ -2516,6 +2531,7 @@ Perl_debop(pTHX_ const OP *o) case OP_PADSV: case OP_PADAV: case OP_PADHV: + case OP_ARGELEM: S_deb_padvar(aTHX_ o->op_targ, 1, 1); break; @@ -2525,8 +2541,8 @@ Perl_debop(pTHX_ const OP *o) break; case OP_MULTIDEREF: - PerlIO_printf(Perl_debug_log, "(%-p)", - multideref_stringify(o, deb_curcv(cxstack_ix))); + PerlIO_printf(Perl_debug_log, "(%"SVf")", + SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix)))); break; default: @@ -2599,11 +2615,5 @@ Perl_debprofdump(pTHX) /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */