3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
24 =head1 Display and Dump functions
28 #define PERL_IN_DUMP_C
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
97 Escapes at most the first C<count> chars of C<pv> and puts the results into
98 C<dsv> such that the size of the escaped string will not exceed C<max> chars
99 and will not contain any incomplete escape sequences. The number of bytes
100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101 When the C<dsv> parameter is null no escaping actually occurs, but the number
102 of bytes that would be escaped were it not null will be calculated.
104 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
105 will also be escaped.
107 Normally the SV will be cleared before the escaped string is prepared,
108 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111 if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
112 using C<is_utf8_string()> to determine if it is UTF-8.
114 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
116 non-ASCII chars will be escaped using this style; otherwise, only chars above
117 255 will be so escaped; other non printable chars will use octal or
118 common escaped patterns like C<\n>.
119 Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
120 then all chars below 255 will be treated as printable and
121 will be output as literals.
123 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
124 string will be escaped, regardless of max. If the output is to be in hex,
125 then it will be returned as a plain hex
126 sequence. Thus the output will either be a single char,
127 an octal escape sequence, a special escape like C<\n> or a hex value.
129 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130 not a C<"\\">. This is because regexes very often contain backslashed
131 sequences, whereas C<"%"> is not a particularly common character in patterns.
133 Returns a pointer to the escaped text as held by C<dsv>.
137 #define PV_ESCAPE_OCTBUFSIZE 32
140 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
141 const STRLEN count, const STRLEN max,
142 STRLEN * const escaped, const U32 flags )
144 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
145 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
146 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
147 STRLEN wrote = 0; /* chars written so far */
148 STRLEN chsize = 0; /* size of data to be written */
149 STRLEN readsize = 1; /* size of data just read */
150 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
151 const char *pv = str;
152 const char * const end = pv + count; /* end of string */
155 PERL_ARGS_ASSERT_PV_ESCAPE;
157 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
158 /* This won't alter the UTF-8 flag */
162 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
165 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
166 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
167 const U8 c = (U8)u & 0xFF;
170 || (flags & PERL_PV_ESCAPE_ALL)
171 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
173 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
174 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
177 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
178 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
180 : "%cx{%02"UVxf"}", esc, u);
182 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
185 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
189 case '\\' : /* FALLTHROUGH */
190 case '%' : if ( c == esc ) {
196 case '\v' : octbuf[1] = 'v'; break;
197 case '\t' : octbuf[1] = 't'; break;
198 case '\r' : octbuf[1] = 'r'; break;
199 case '\n' : octbuf[1] = 'n'; break;
200 case '\f' : octbuf[1] = 'f'; break;
208 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
210 isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
213 else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
217 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
224 if ( max && (wrote + chsize > max) ) {
226 } else if (chsize > 1) {
228 sv_catpvn(dsv, octbuf, chsize);
231 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
232 can be appended raw to the dsv. If dsv happens to be
233 UTF-8 then we need catpvf to upgrade them for us.
234 Or add a new API call sv_catpvc(). Think about that name, and
235 how to keep it clear that it's unlike the s of catpvs, which is
236 really an array of octets, not a string. */
238 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
241 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
246 return dsv ? SvPVX(dsv) : NULL;
249 =for apidoc pv_pretty
251 Converts a string into something presentable, handling escaping via
252 C<pv_escape()> and supporting quoting and ellipses.
254 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
255 double quoted with any double quotes in the string escaped. Otherwise
256 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
259 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
260 string were output then an ellipsis C<...> will be appended to the
261 string. Note that this happens AFTER it has been quoted.
263 If C<start_color> is non-null then it will be inserted after the opening
264 quote (if there is one) but before the escaped text. If C<end_color>
265 is non-null then it will be inserted after the escaped text but before
266 any quotes or ellipses.
268 Returns a pointer to the prettified text as held by C<dsv>.
274 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
275 const STRLEN max, char const * const start_color, char const * const end_color,
278 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
279 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
281 STRLEN max_adjust= 0;
284 PERL_ARGS_ASSERT_PV_PRETTY;
286 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
287 /* This won't alter the UTF-8 flag */
290 orig_cur= SvCUR(dsv);
293 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
295 if ( start_color != NULL )
296 sv_catpv(dsv, start_color);
298 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
301 assert(max > max_adjust);
302 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
303 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
305 assert(max > max_adjust);
308 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
310 if ( end_color != NULL )
311 sv_catpv(dsv, end_color);
314 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
316 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
317 sv_catpvs(dsv, "...");
319 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
320 while( SvCUR(dsv) - orig_cur < max )
328 =for apidoc pv_display
332 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
334 except that an additional "\0" will be appended to the string when
335 len > cur and pv[cur] is "\0".
337 Note that the final string may be up to 7 chars longer than pvlim.
343 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
345 PERL_ARGS_ASSERT_PV_DISPLAY;
347 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
348 if (len > cur && pv[cur] == '\0')
349 sv_catpvs( dsv, "\\0");
354 Perl_sv_peek(pTHX_ SV *sv)
357 SV * const t = sv_newmortal();
367 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
368 /* detect data corruption under memory poisoning */
372 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
373 if (sv == &PL_sv_undef) {
374 sv_catpv(t, "SV_UNDEF");
375 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
376 SVs_GMG|SVs_SMG|SVs_RMG)) &&
380 else if (sv == &PL_sv_no) {
381 sv_catpv(t, "SV_NO");
382 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
383 SVs_GMG|SVs_SMG|SVs_RMG)) &&
384 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
390 else if (sv == &PL_sv_yes) {
391 sv_catpv(t, "SV_YES");
392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
393 SVs_GMG|SVs_SMG|SVs_RMG)) &&
394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
397 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
402 sv_catpv(t, "SV_PLACEHOLDER");
403 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
404 SVs_GMG|SVs_SMG|SVs_RMG)) &&
410 else if (SvREFCNT(sv) == 0) {
414 else if (DEBUG_R_TEST_) {
417 /* is this SV on the tmps stack? */
418 for (ix=PL_tmps_ix; ix>=0; ix--) {
419 if (PL_tmps_stack[ix] == sv) {
424 if (SvREFCNT(sv) > 1)
425 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
433 if (SvCUR(t) + unref > 10) {
434 SvCUR_set(t, unref + 3);
443 if (type == SVt_PVCV) {
444 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
446 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
447 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
450 } else if (type < SVt_LAST) {
451 sv_catpv(t, svshorttypenames[type]);
453 if (type == SVt_NULL)
456 sv_catpv(t, "FREED");
461 if (!SvPVX_const(sv))
462 sv_catpv(t, "(null)");
464 SV * const tmp = newSVpvs("");
468 SvOOK_offset(sv, delta);
469 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
471 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
473 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
474 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
476 SvREFCNT_dec_NN(tmp);
479 else if (SvNOKp(sv)) {
480 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
481 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
482 RESTORE_LC_NUMERIC_UNDERLYING();
484 else if (SvIOKp(sv)) {
486 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
488 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
496 if (TAINTING_get && sv && SvTAINTED(sv))
497 sv_catpv(t, " [tainted]");
498 return SvPV_nolen(t);
502 =head1 Debugging Utilities
506 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
509 PERL_ARGS_ASSERT_DUMP_INDENT;
511 dump_vindent(level, file, pat, &args);
516 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
518 PERL_ARGS_ASSERT_DUMP_VINDENT;
519 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
520 PerlIO_vprintf(file, pat, *args);
526 Dumps the entire optree of the current program starting at C<PL_main_root> to
527 C<STDERR>. Also dumps the optrees for all visible subroutines in
536 dump_all_perl(FALSE);
540 Perl_dump_all_perl(pTHX_ bool justperl)
542 PerlIO_setlinebuf(Perl_debug_log);
544 op_dump(PL_main_root);
545 dump_packsubs_perl(PL_defstash, justperl);
549 =for apidoc dump_packsubs
551 Dumps the optrees for all visible subroutines in C<stash>.
557 Perl_dump_packsubs(pTHX_ const HV *stash)
559 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
560 dump_packsubs_perl(stash, FALSE);
564 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
568 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
572 for (i = 0; i <= (I32) HvMAX(stash); i++) {
574 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
575 GV * gv = (GV *)HeVAL(entry);
576 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
577 /* unfake a fake GV */
578 (void)CvGV(SvRV(gv));
579 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
582 dump_sub_perl(gv, justperl);
585 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
586 const HV * const hv = GvHV(gv);
587 if (hv && (hv != PL_defstash))
588 dump_packsubs_perl(hv, justperl); /* nested package */
595 Perl_dump_sub(pTHX_ const GV *gv)
597 PERL_ARGS_ASSERT_DUMP_SUB;
598 dump_sub_perl(gv, FALSE);
602 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
605 SV * const sv = newSVpvs_flags("", SVs_TEMP);
609 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
611 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
614 tmpsv = newSVpvs_flags("", SVs_TEMP);
615 gv_fullname3(sv, gv, NULL);
616 name = SvPV_const(sv, len);
617 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
618 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
619 if (CvISXSUB(GvCV(gv)))
620 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
621 PTR2UV(CvXSUB(GvCV(gv))),
622 (int)CvXSUBANY(GvCV(gv)).any_i32);
623 else if (CvROOT(GvCV(gv)))
624 op_dump(CvROOT(GvCV(gv)));
626 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
630 Perl_dump_form(pTHX_ const GV *gv)
632 SV * const sv = sv_newmortal();
634 PERL_ARGS_ASSERT_DUMP_FORM;
636 gv_fullname3(sv, gv, NULL);
637 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
638 if (CvROOT(GvFORM(gv)))
639 op_dump(CvROOT(GvFORM(gv)));
641 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
647 op_dump(PL_eval_root);
651 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
655 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
658 Perl_dump_indent(aTHX_ level, file, "{}\n");
661 Perl_dump_indent(aTHX_ level, file, "{\n");
663 if (pm->op_pmflags & PMf_ONCE)
668 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
669 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
670 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
672 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
673 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
674 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
675 op_dump(pm->op_pmreplrootu.op_pmreplroot);
677 if (pm->op_code_list) {
678 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
679 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
680 do_op_dump(level, file, pm->op_code_list);
683 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
684 PTR2UV(pm->op_code_list));
686 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
687 SV * const tmpsv = pm_description(pm);
688 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
689 SvREFCNT_dec_NN(tmpsv);
692 Perl_dump_indent(aTHX_ level-1, file, "}\n");
695 const struct flag_to_name pmflags_flags_names[] = {
696 {PMf_CONST, ",CONST"},
698 {PMf_GLOBAL, ",GLOBAL"},
699 {PMf_CONTINUE, ",CONTINUE"},
700 {PMf_RETAINT, ",RETAINT"},
702 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
703 {PMf_HAS_CV, ",HAS_CV"},
704 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
705 {PMf_IS_QR, ",IS_QR"}
709 S_pm_description(pTHX_ const PMOP *pm)
711 SV * const desc = newSVpvs("");
712 const REGEXP * const regex = PM_GETRE(pm);
713 const U32 pmflags = pm->op_pmflags;
715 PERL_ARGS_ASSERT_PM_DESCRIPTION;
717 if (pmflags & PMf_ONCE)
718 sv_catpv(desc, ",ONCE");
720 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
721 sv_catpv(desc, ":USED");
723 if (pmflags & PMf_USED)
724 sv_catpv(desc, ":USED");
728 if (RX_ISTAINTED(regex))
729 sv_catpv(desc, ",TAINTED");
730 if (RX_CHECK_SUBSTR(regex)) {
731 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
732 sv_catpv(desc, ",SCANFIRST");
733 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
734 sv_catpv(desc, ",ALL");
736 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
737 sv_catpv(desc, ",SKIPWHITE");
740 append_flags(desc, pmflags, pmflags_flags_names);
745 Perl_pmop_dump(pTHX_ PMOP *pm)
747 do_pmop_dump(0, Perl_debug_log, pm);
750 /* Return a unique integer to represent the address of op o.
751 * If it already exists in PL_op_sequence, just return it;
753 * *** Note that this isn't thread-safe */
756 S_sequence_num(pTHX_ const OP *o)
765 op = newSVuv(PTR2UV(o));
767 key = SvPV_const(op, len);
769 PL_op_sequence = newHV();
770 seq = hv_fetch(PL_op_sequence, key, len, 0);
773 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
781 const struct flag_to_name op_flags_names[] = {
783 {OPf_PARENS, ",PARENS"},
786 {OPf_STACKED, ",STACKED"},
787 {OPf_SPECIAL, ",SPECIAL"}
792 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
795 const OPCODE optype = o->op_type;
797 PERL_ARGS_ASSERT_DO_OP_DUMP;
799 Perl_dump_indent(aTHX_ level, file, "{\n");
801 seq = sequence_num(o);
803 PerlIO_printf(file, "%-4"UVuf, seq);
805 PerlIO_printf(file, "????");
807 "%*sTYPE = %s ===> ",
808 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
811 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
812 sequence_num(o->op_next));
814 PerlIO_printf(file, "NULL\n");
816 if (optype == OP_NULL) {
817 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
820 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
823 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
826 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
827 SV * const tmpsv = newSVpvs("");
828 switch (o->op_flags & OPf_WANT) {
830 sv_catpv(tmpsv, ",VOID");
832 case OPf_WANT_SCALAR:
833 sv_catpv(tmpsv, ",SCALAR");
836 sv_catpv(tmpsv, ",LIST");
839 sv_catpv(tmpsv, ",UNKNOWN");
842 append_flags(tmpsv, o->op_flags, op_flags_names);
843 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
844 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
845 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
846 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
847 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
848 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
849 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
853 U16 oppriv = o->op_private;
854 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
859 tmpsv = newSVpvs("");
860 for (; !stop; op_ix++) {
861 U16 entry = PL_op_private_bitdefs[op_ix];
862 U16 bit = (entry >> 2) & 7;
869 I16 const *p = &PL_op_private_bitfields[ix];
870 U16 bitmin = (U16) *p++;
877 for (i = bitmin; i<= bit; i++)
880 val = (oppriv & mask);
883 && PL_op_private_labels[label] == '-'
884 && PL_op_private_labels[label+1] == '\0'
886 /* display as raw number */
899 if (val == 0 && enum_label == -1)
900 /* don't display anonymous zero values */
903 sv_catpv(tmpsv, ",");
905 sv_catpv(tmpsv, &PL_op_private_labels[label]);
906 sv_catpv(tmpsv, "=");
908 if (enum_label == -1)
909 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)val);
911 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
916 if ( oppriv & (1<<bit)
917 && !(PL_op_private_labels[ix] == '-'
918 && PL_op_private_labels[ix+1] == '\0'))
921 sv_catpv(tmpsv, ",");
922 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
927 sv_catpv(tmpsv, ",");
928 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
931 if (tmpsv && SvCUR(tmpsv)) {
932 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
934 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
943 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
945 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
949 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
950 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
951 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
952 name = SvPV_const(tmpsv, len);
953 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
954 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
957 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
964 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
965 UV i, count = items[-1].uv;
967 Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
968 for (i=0; i < count; i++)
969 Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
976 case OP_METHOD_NAMED:
977 case OP_METHOD_SUPER:
978 case OP_METHOD_REDIR:
979 case OP_METHOD_REDIR_SUPER:
981 /* with ITHREADS, consts are stored in the pad, and the right pad
982 * may not be active here, so skip */
983 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
987 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
993 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
995 if (CopSTASHPV(cCOPo)) {
996 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
997 HV *stash = CopSTASH(cCOPo);
998 const char * const hvname = HvNAME_get(stash);
1000 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1001 generic_pv_escape(tmpsv, hvname,
1002 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1004 if (CopLABEL(cCOPo)) {
1005 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1008 const char *label = CopLABEL_len_flags(cCOPo,
1009 &label_len, &label_flags);
1010 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1011 generic_pv_escape( tmpsv, label, label_len,
1012 (label_flags & SVf_UTF8)));
1014 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1015 (unsigned int)cCOPo->cop_seq);
1018 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1019 if (cLOOPo->op_redoop)
1020 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1022 PerlIO_printf(file, "DONE\n");
1023 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1024 if (cLOOPo->op_nextop)
1025 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1027 PerlIO_printf(file, "DONE\n");
1028 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1029 if (cLOOPo->op_lastop)
1030 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1032 PerlIO_printf(file, "DONE\n");
1040 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1041 if (cLOGOPo->op_other)
1042 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1044 PerlIO_printf(file, "DONE\n");
1050 do_pmop_dump(level, file, cPMOPo);
1058 if (o->op_private & OPpREFCOUNTED)
1059 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1064 if (o->op_flags & OPf_KIDS) {
1066 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1067 do_op_dump(level, file, kid);
1069 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1075 Dumps the optree starting at OP C<o> to C<STDERR>.
1081 Perl_op_dump(pTHX_ const OP *o)
1083 PERL_ARGS_ASSERT_OP_DUMP;
1084 do_op_dump(0, Perl_debug_log, o);
1088 Perl_gv_dump(pTHX_ GV *gv)
1092 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1095 PerlIO_printf(Perl_debug_log, "{}\n");
1098 sv = sv_newmortal();
1099 PerlIO_printf(Perl_debug_log, "{\n");
1100 gv_fullname3(sv, gv, NULL);
1101 name = SvPV_const(sv, len);
1102 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1103 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1104 if (gv != GvEGV(gv)) {
1105 gv_efullname3(sv, GvEGV(gv), NULL);
1106 name = SvPV_const(sv, len);
1107 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1108 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1110 (void)PerlIO_putc(Perl_debug_log, '\n');
1111 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1115 /* map magic types to the symbolic names
1116 * (with the PERL_MAGIC_ prefixed stripped)
1119 static const struct { const char type; const char *name; } magic_names[] = {
1120 #include "mg_names.inc"
1121 /* this null string terminates the list */
1126 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1128 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1130 for (; mg; mg = mg->mg_moremagic) {
1131 Perl_dump_indent(aTHX_ level, file,
1132 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1133 if (mg->mg_virtual) {
1134 const MGVTBL * const v = mg->mg_virtual;
1135 if (v >= PL_magic_vtables
1136 && v < PL_magic_vtables + magic_vtable_max) {
1137 const U32 i = v - PL_magic_vtables;
1138 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1141 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1144 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1147 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1151 const char *name = NULL;
1152 for (n = 0; magic_names[n].name; n++) {
1153 if (mg->mg_type == magic_names[n].type) {
1154 name = magic_names[n].name;
1159 Perl_dump_indent(aTHX_ level, file,
1160 " MG_TYPE = PERL_MAGIC_%s\n", name);
1162 Perl_dump_indent(aTHX_ level, file,
1163 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1167 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1168 if (mg->mg_type == PERL_MAGIC_envelem &&
1169 mg->mg_flags & MGf_TAINTEDDIR)
1170 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1171 if (mg->mg_type == PERL_MAGIC_regex_global &&
1172 mg->mg_flags & MGf_MINMATCH)
1173 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1174 if (mg->mg_flags & MGf_REFCOUNTED)
1175 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1176 if (mg->mg_flags & MGf_GSKIP)
1177 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1178 if (mg->mg_flags & MGf_COPY)
1179 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1180 if (mg->mg_flags & MGf_DUP)
1181 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1182 if (mg->mg_flags & MGf_LOCAL)
1183 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1184 if (mg->mg_type == PERL_MAGIC_regex_global &&
1185 mg->mg_flags & MGf_BYTES)
1186 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1189 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1190 PTR2UV(mg->mg_obj));
1191 if (mg->mg_type == PERL_MAGIC_qr) {
1192 REGEXP* const re = (REGEXP *)mg->mg_obj;
1193 SV * const dsv = sv_newmortal();
1194 const char * const s
1195 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1197 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1198 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1200 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1201 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1204 if (mg->mg_flags & MGf_REFCOUNTED)
1205 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1208 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1210 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1211 if (mg->mg_len >= 0) {
1212 if (mg->mg_type != PERL_MAGIC_utf8) {
1213 SV * const sv = newSVpvs("");
1214 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1215 SvREFCNT_dec_NN(sv);
1218 else if (mg->mg_len == HEf_SVKEY) {
1219 PerlIO_puts(file, " => HEf_SVKEY\n");
1220 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1221 maxnest, dumpops, pvlim); /* MG is already +1 */
1224 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1229 " does not know how to handle this MG_LEN"
1231 (void)PerlIO_putc(file, '\n');
1233 if (mg->mg_type == PERL_MAGIC_utf8) {
1234 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1237 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1238 Perl_dump_indent(aTHX_ level, file,
1239 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1242 (UV)cache[i * 2 + 1]);
1249 Perl_magic_dump(pTHX_ const MAGIC *mg)
1251 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1255 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1259 PERL_ARGS_ASSERT_DO_HV_DUMP;
1261 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1262 if (sv && (hvname = HvNAME_get(sv)))
1264 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1265 name which quite legally could contain insane things like tabs, newlines, nulls or
1266 other scary crap - this should produce sane results - except maybe for unicode package
1267 names - but we will wait for someone to file a bug on that - demerphq */
1268 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1269 PerlIO_printf(file, "\t\"%s\"\n",
1270 generic_pv_escape( tmpsv, hvname,
1271 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1274 (void)PerlIO_putc(file, '\n');
1278 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1280 PERL_ARGS_ASSERT_DO_GV_DUMP;
1282 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1283 if (sv && GvNAME(sv)) {
1284 SV * const tmpsv = newSVpvs("");
1285 PerlIO_printf(file, "\t\"%s\"\n",
1286 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1289 (void)PerlIO_putc(file, '\n');
1293 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1295 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1297 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1298 if (sv && GvNAME(sv)) {
1299 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1301 HV * const stash = GvSTASH(sv);
1302 PerlIO_printf(file, "\t");
1303 /* TODO might have an extra \" here */
1304 if (stash && (hvname = HvNAME_get(stash))) {
1305 PerlIO_printf(file, "\"%s\" :: \"",
1306 generic_pv_escape(tmp, hvname,
1307 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1309 PerlIO_printf(file, "%s\"\n",
1310 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1313 (void)PerlIO_putc(file, '\n');
1316 const struct flag_to_name first_sv_flags_names[] = {
1317 {SVs_TEMP, "TEMP,"},
1318 {SVs_OBJECT, "OBJECT,"},
1327 const struct flag_to_name second_sv_flags_names[] = {
1329 {SVf_FAKE, "FAKE,"},
1330 {SVf_READONLY, "READONLY,"},
1331 {SVf_PROTECT, "PROTECT,"},
1332 {SVf_BREAK, "BREAK,"},
1338 const struct flag_to_name cv_flags_names[] = {
1339 {CVf_ANON, "ANON,"},
1340 {CVf_UNIQUE, "UNIQUE,"},
1341 {CVf_CLONE, "CLONE,"},
1342 {CVf_CLONED, "CLONED,"},
1343 {CVf_CONST, "CONST,"},
1344 {CVf_NODEBUG, "NODEBUG,"},
1345 {CVf_LVALUE, "LVALUE,"},
1346 {CVf_METHOD, "METHOD,"},
1347 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1348 {CVf_CVGV_RC, "CVGV_RC,"},
1349 {CVf_DYNFILE, "DYNFILE,"},
1350 {CVf_AUTOLOAD, "AUTOLOAD,"},
1351 {CVf_HASEVAL, "HASEVAL,"},
1352 {CVf_SLABBED, "SLABBED,"},
1353 {CVf_NAMED, "NAMED,"},
1354 {CVf_LEXICAL, "LEXICAL,"},
1355 {CVf_ISXSUB, "ISXSUB,"}
1358 const struct flag_to_name hv_flags_names[] = {
1359 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1360 {SVphv_LAZYDEL, "LAZYDEL,"},
1361 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1362 {SVf_AMAGIC, "OVERLOAD,"},
1363 {SVphv_CLONEABLE, "CLONEABLE,"}
1366 const struct flag_to_name gp_flags_names[] = {
1367 {GVf_INTRO, "INTRO,"},
1368 {GVf_MULTI, "MULTI,"},
1369 {GVf_ASSUMECV, "ASSUMECV,"},
1372 const struct flag_to_name gp_flags_imported_names[] = {
1373 {GVf_IMPORTED_SV, " SV"},
1374 {GVf_IMPORTED_AV, " AV"},
1375 {GVf_IMPORTED_HV, " HV"},
1376 {GVf_IMPORTED_CV, " CV"},
1379 /* NOTE: this structure is mostly duplicative of one generated by
1380 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1381 * the two. - Yves */
1382 const struct flag_to_name regexp_extflags_names[] = {
1383 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1384 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1385 {RXf_PMf_FOLD, "PMf_FOLD,"},
1386 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1387 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1388 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1389 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1390 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1391 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1392 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1393 {RXf_CHECK_ALL, "CHECK_ALL,"},
1394 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1395 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1396 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1397 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1398 {RXf_SPLIT, "SPLIT,"},
1399 {RXf_COPY_DONE, "COPY_DONE,"},
1400 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1401 {RXf_TAINTED, "TAINTED,"},
1402 {RXf_START_ONLY, "START_ONLY,"},
1403 {RXf_SKIPWHITE, "SKIPWHITE,"},
1404 {RXf_WHITE, "WHITE,"},
1405 {RXf_NULL, "NULL,"},
1408 /* NOTE: this structure is mostly duplicative of one generated by
1409 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1410 * the two. - Yves */
1411 const struct flag_to_name regexp_core_intflags_names[] = {
1412 {PREGf_SKIP, "SKIP,"},
1413 {PREGf_IMPLICIT, "IMPLICIT,"},
1414 {PREGf_NAUGHTY, "NAUGHTY,"},
1415 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1416 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1417 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1418 {PREGf_NOSCAN, "NOSCAN,"},
1419 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1420 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1421 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1422 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1423 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1426 /* Perl_do_sv_dump():
1428 * level: amount to indent the output
1429 * sv: the object to dump
1430 * nest: the current level of recursion
1431 * maxnest: the maximum allowed level of recursion
1432 * dumpops: if true, also dump the ops associated with a CV
1433 * pvlim: limit on the length of any strings that are output
1437 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1444 PERL_ARGS_ASSERT_DO_SV_DUMP;
1447 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1451 flags = SvFLAGS(sv);
1454 /* process general SV flags */
1456 d = Perl_newSVpvf(aTHX_
1457 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1458 PTR2UV(SvANY(sv)), PTR2UV(sv),
1459 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1460 (int)(PL_dumpindent*level), "");
1462 if ((flags & SVs_PADSTALE))
1463 sv_catpv(d, "PADSTALE,");
1464 if ((flags & SVs_PADTMP))
1465 sv_catpv(d, "PADTMP,");
1466 append_flags(d, flags, first_sv_flags_names);
1467 if (flags & SVf_ROK) {
1468 sv_catpv(d, "ROK,");
1469 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1471 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1472 append_flags(d, flags, second_sv_flags_names);
1473 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1474 && type != SVt_PVAV) {
1475 if (SvPCS_IMPORTED(sv))
1476 sv_catpv(d, "PCS_IMPORTED,");
1478 sv_catpv(d, "SCREAM,");
1481 /* process type-specific SV flags */
1486 append_flags(d, CvFLAGS(sv), cv_flags_names);
1489 append_flags(d, flags, hv_flags_names);
1493 if (isGV_with_GP(sv)) {
1494 append_flags(d, GvFLAGS(sv), gp_flags_names);
1496 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1497 sv_catpv(d, "IMPORT");
1498 if (GvIMPORTED(sv) == GVf_IMPORTED)
1499 sv_catpv(d, "ALL,");
1502 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1509 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1510 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1513 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1514 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1520 /* SVphv_SHAREKEYS is also 0x20000000 */
1521 if ((type != SVt_PVHV) && SvUTF8(sv))
1522 sv_catpv(d, "UTF8");
1524 if (*(SvEND(d) - 1) == ',') {
1525 SvCUR_set(d, SvCUR(d) - 1);
1526 SvPVX(d)[SvCUR(d)] = '\0';
1531 /* dump initial SV details */
1533 #ifdef DEBUG_LEAKING_SCALARS
1534 Perl_dump_indent(aTHX_ level, file,
1535 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1536 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1538 sv->sv_debug_inpad ? "for" : "by",
1539 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1540 PTR2UV(sv->sv_debug_parent),
1544 Perl_dump_indent(aTHX_ level, file, "SV = ");
1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551 if (type == SVt_NULL) {
1556 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1561 /* Dump general SV fields */
1563 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1564 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1565 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1566 || (type == SVt_IV && !SvROK(sv))) {
1569 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1571 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1572 (void)PerlIO_putc(file, '\n');
1575 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1576 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1577 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1578 || type == SVt_NV) {
1579 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1580 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1581 RESTORE_LC_NUMERIC_UNDERLYING();
1585 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1587 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1590 if (type < SVt_PV) {
1595 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1596 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1597 const bool re = isREGEXP(sv);
1598 const char * const ptr =
1599 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1603 SvOOK_offset(sv, delta);
1604 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1609 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1611 PerlIO_printf(file, "( %s . ) ",
1612 pv_display(d, ptr - delta, delta, 0,
1615 if (type == SVt_INVLIST) {
1616 PerlIO_printf(file, "\n");
1617 /* 4 blanks indents 2 beyond the PV, etc */
1618 _invlist_dump(file, level, " ", sv);
1621 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1624 if (SvUTF8(sv)) /* the 6? \x{....} */
1625 PerlIO_printf(file, " [UTF8 \"%s\"]",
1626 sv_uni_display(d, sv, 6 * SvCUR(sv),
1628 PerlIO_printf(file, "\n");
1630 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1632 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1634 #ifdef PERL_COPY_ON_WRITE
1635 if (SvIsCOW(sv) && SvLEN(sv))
1636 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1641 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1644 if (type >= SVt_PVMG) {
1646 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1648 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1650 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1651 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1655 /* Dump type-specific SV fields */
1659 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1660 if (AvARRAY(sv) != AvALLOC(sv)) {
1661 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1662 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1665 (void)PerlIO_putc(file, '\n');
1666 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1667 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1668 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1669 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1671 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1672 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1673 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1674 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1675 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1677 SV **svp = AvARRAY(MUTABLE_AV(sv));
1679 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1682 SV* const elt = *svp;
1683 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1684 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1691 struct xpvhv_aux *const aux = HvAUX(sv);
1692 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1693 (UV)aux->xhv_aux_flags);
1695 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1696 usedkeys = HvUSEDKEYS(sv);
1697 if (HvARRAY(sv) && usedkeys) {
1698 /* Show distribution of HEs in the ARRAY */
1700 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1703 U32 pow2 = 2, keys = usedkeys;
1704 NV theoret, sum = 0;
1706 PerlIO_printf(file, " (");
1707 Zero(freq, FREQ_MAX + 1, int);
1708 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1711 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1713 if (count > FREQ_MAX)
1719 for (i = 0; i <= max; i++) {
1721 PerlIO_printf(file, "%d%s:%d", i,
1722 (i == FREQ_MAX) ? "+" : "",
1725 PerlIO_printf(file, ", ");
1728 (void)PerlIO_putc(file, ')');
1729 /* The "quality" of a hash is defined as the total number of
1730 comparisons needed to access every element once, relative
1731 to the expected number needed for a random hash.
1733 The total number of comparisons is equal to the sum of
1734 the squares of the number of entries in each bucket.
1735 For a random hash of n keys into k buckets, the expected
1740 for (i = max; i > 0; i--) { /* Precision: count down. */
1741 sum += freq[i] * i * i;
1743 while ((keys = keys >> 1))
1746 theoret += theoret * (theoret-1)/pow2;
1747 (void)PerlIO_putc(file, '\n');
1748 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1750 (void)PerlIO_putc(file, '\n');
1751 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1754 HE **ents = HvARRAY(sv);
1757 HE *const *const last = ents + HvMAX(sv);
1758 count = last + 1 - ents;
1763 } while (++ents <= last);
1766 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1769 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1771 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1772 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1773 #ifdef PERL_HASH_RANDOMIZE_KEYS
1774 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1775 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1776 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1779 (void)PerlIO_putc(file, '\n');
1782 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1783 if (mg && mg->mg_obj) {
1784 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1788 const char * const hvname = HvNAME_get(sv);
1790 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1791 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1792 generic_pv_escape( tmpsv, hvname,
1793 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1798 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1799 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1800 if (HvAUX(sv)->xhv_name_count)
1801 Perl_dump_indent(aTHX_
1802 level, file, " NAMECOUNT = %"IVdf"\n",
1803 (IV)HvAUX(sv)->xhv_name_count
1805 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1806 const I32 count = HvAUX(sv)->xhv_name_count;
1808 SV * const names = newSVpvs_flags("", SVs_TEMP);
1809 /* The starting point is the first element if count is
1810 positive and the second element if count is negative. */
1811 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1812 + (count < 0 ? 1 : 0);
1813 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1814 + (count < 0 ? -count : count);
1815 while (hekp < endp) {
1817 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1818 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1819 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1821 /* This should never happen. */
1822 sv_catpvs(names, ", (null)");
1826 Perl_dump_indent(aTHX_
1827 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1831 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1832 const char *const hvename = HvENAME_get(sv);
1833 Perl_dump_indent(aTHX_
1834 level, file, " ENAME = \"%s\"\n",
1835 generic_pv_escape(tmp, hvename,
1836 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1840 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1842 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1846 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1847 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1848 generic_pv_escape( tmpsv, meta->mro_which->name,
1849 meta->mro_which->length,
1850 (meta->mro_which->kflags & HVhek_UTF8)),
1851 PTR2UV(meta->mro_which));
1852 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1853 (UV)meta->cache_gen);
1854 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1856 if (meta->mro_linear_all) {
1857 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1858 PTR2UV(meta->mro_linear_all));
1859 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1862 if (meta->mro_linear_current) {
1863 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1864 PTR2UV(meta->mro_linear_current));
1865 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1868 if (meta->mro_nextmethod) {
1869 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1870 PTR2UV(meta->mro_nextmethod));
1871 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1875 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1877 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1882 if (nest < maxnest) {
1883 HV * const hv = MUTABLE_HV(sv);
1888 int count = maxnest - nest;
1889 for (i=0; i <= HvMAX(hv); i++) {
1890 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1897 if (count-- <= 0) goto DONEHV;
1900 keysv = hv_iterkeysv(he);
1901 keypv = SvPV_const(keysv, len);
1904 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1906 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1907 if (HvEITER_get(hv) == he)
1908 PerlIO_printf(file, "[CURRENT] ");
1909 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1910 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1917 } /* case SVt_PVHV */
1920 if (CvAUTOLOAD(sv)) {
1921 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1923 const char *const name = SvPV_const(sv, len);
1924 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1925 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1928 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1929 const char *const proto = CvPROTO(sv);
1930 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1931 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1936 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1937 if (!CvISXSUB(sv)) {
1939 Perl_dump_indent(aTHX_ level, file,
1940 " START = 0x%"UVxf" ===> %"IVdf"\n",
1941 PTR2UV(CvSTART(sv)),
1942 (IV)sequence_num(CvSTART(sv)));
1944 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1945 PTR2UV(CvROOT(sv)));
1946 if (CvROOT(sv) && dumpops) {
1947 do_op_dump(level+1, file, CvROOT(sv));
1950 SV * const constant = cv_const_sv((const CV *)sv);
1952 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1955 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1957 PTR2UV(CvXSUBANY(sv).any_ptr));
1958 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1961 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1962 (IV)CvXSUBANY(sv).any_i32);
1966 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1967 HEK_KEY(CvNAME_HEK((CV *)sv)));
1968 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1969 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1970 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1971 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1972 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1973 if (!CvISXSUB(sv)) {
1974 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1975 if (nest < maxnest) {
1976 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1980 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
1982 const CV * const outside = CvOUTSIDE(sv);
1983 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1986 : CvANON(outside) ? "ANON"
1987 : (outside == PL_main_cv) ? "MAIN"
1988 : CvUNIQUE(outside) ? "UNIQUE"
1991 newSVpvs_flags("", SVs_TEMP),
1992 GvNAME(CvGV(outside)),
1993 GvNAMELEN(CvGV(outside)),
1994 GvNAMEUTF8(CvGV(outside)))
1998 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
1999 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2004 if (type == SVt_PVLV) {
2005 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2006 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2007 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2008 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2009 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2010 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2011 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2014 if (isREGEXP(sv)) goto dumpregexp;
2015 if (!isGV_with_GP(sv))
2018 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2019 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2020 generic_pv_escape(tmpsv, GvNAME(sv),
2024 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2025 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2026 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2027 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2030 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2031 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2032 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2033 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2038 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2042 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2043 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2044 do_gv_dump (level, file, " EGV", GvEGV(sv));
2047 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2048 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2049 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2050 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2051 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2052 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2053 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2055 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2056 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2057 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2059 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2060 PTR2UV(IoTOP_GV(sv)));
2061 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2062 maxnest, dumpops, pvlim);
2064 /* Source filters hide things that are not GVs in these three, so let's
2065 be careful out there. */
2067 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2068 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2069 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2071 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2072 PTR2UV(IoFMT_GV(sv)));
2073 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2074 maxnest, dumpops, pvlim);
2076 if (IoBOTTOM_NAME(sv))
2077 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2078 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2079 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2081 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2082 PTR2UV(IoBOTTOM_GV(sv)));
2083 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2084 maxnest, dumpops, pvlim);
2086 if (isPRINT(IoTYPE(sv)))
2087 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2089 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2090 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2095 struct regexp * const r = ReANY((REGEXP*)sv);
2097 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2099 append_flags(d, flags, names); \
2100 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2101 SvCUR_set(d, SvCUR(d) - 1); \
2102 SvPVX(d)[SvCUR(d)] = '\0'; \
2105 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2106 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2107 (UV)(r->compflags), SvPVX_const(d));
2109 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2110 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2111 (UV)(r->extflags), SvPVX_const(d));
2113 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2114 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2115 if (r->engine == &PL_core_reg_engine) {
2116 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2117 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2118 (UV)(r->intflags), SvPVX_const(d));
2120 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2123 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2124 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2126 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2127 (UV)(r->lastparen));
2128 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2129 (UV)(r->lastcloseparen));
2130 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2132 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2133 (IV)(r->minlenret));
2134 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2136 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2137 (UV)(r->pre_prefix));
2138 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2140 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2141 (IV)(r->suboffset));
2142 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2143 (IV)(r->subcoffset));
2145 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2147 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2149 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2150 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2151 PTR2UV(r->mother_re));
2152 if (nest < maxnest && r->mother_re)
2153 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2154 maxnest, dumpops, pvlim);
2155 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2156 PTR2UV(r->paren_names));
2157 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2158 PTR2UV(r->substrs));
2159 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2160 PTR2UV(r->pprivate));
2161 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2163 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2164 PTR2UV(r->qr_anoncv));
2166 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2167 PTR2UV(r->saved_copy));
2178 Dumps the contents of an SV to the C<STDERR> filehandle.
2180 For an example of its output, see L<Devel::Peek>.
2186 Perl_sv_dump(pTHX_ SV *sv)
2188 PERL_ARGS_ASSERT_SV_DUMP;
2191 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2193 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2197 Perl_runops_debug(pTHX)
2200 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2204 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2206 #ifdef PERL_TRACE_OPS
2207 ++PL_op_exec_cnt[PL_op->op_type];
2212 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2213 PerlIO_printf(Perl_debug_log,
2214 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2215 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2216 PTR2UV(*PL_watchaddr));
2217 if (DEBUG_s_TEST_) {
2218 if (DEBUG_v_TEST_) {
2219 PerlIO_printf(Perl_debug_log, "\n");
2227 if (DEBUG_t_TEST_) debop(PL_op);
2228 if (DEBUG_P_TEST_) debprof(PL_op);
2233 PERL_DTRACE_PROBE_OP(PL_op);
2234 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2235 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2243 /* print the names of the n lexical vars starting at pad offset off */
2246 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2249 CV * const cv = deb_curcv(cxstack_ix);
2250 PADNAMELIST *comppad = NULL;
2254 PADLIST * const padlist = CvPADLIST(cv);
2255 comppad = PadlistNAMES(padlist);
2258 PerlIO_printf(Perl_debug_log, "(");
2259 for (i = 0; i < n; i++) {
2260 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2261 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2263 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2266 PerlIO_printf(Perl_debug_log, ",");
2269 PerlIO_printf(Perl_debug_log, ")");
2273 /* append to the out SV, the name of the lexical at offset off in the CV
2277 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2278 bool paren, bool is_scalar)
2281 PADNAMELIST *namepad = NULL;
2285 PADLIST * const padlist = CvPADLIST(cv);
2286 namepad = PadlistNAMES(padlist);
2290 sv_catpvs_nomg(out, "(");
2291 for (i = 0; i < n; i++) {
2292 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2294 STRLEN cur = SvCUR(out);
2295 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2296 UTF8fARG(1, PadnameLEN(sv) - 1,
2297 PadnamePV(sv) + 1));
2299 SvPVX(out)[cur] = '$';
2302 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2304 sv_catpvs_nomg(out, ",");
2307 sv_catpvs_nomg(out, "(");
2312 S_append_gv_name(pTHX_ GV *gv, SV *out)
2316 sv_catpvs_nomg(out, "<NULLGV>");
2320 gv_fullname4(sv, gv, NULL, FALSE);
2321 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2322 SvREFCNT_dec_NN(sv);
2326 # define ITEM_SV(item) (comppad ? \
2327 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2329 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2333 /* return a temporary SV containing a stringified representation of
2334 * the op_aux field of a MULTIDEREF op, associated with CV cv
2338 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2340 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2341 UV actions = items->uv;
2344 bool is_hash = FALSE;
2346 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2351 PADLIST *padlist = CvPADLIST(cv);
2352 comppad = PadlistARRAY(padlist)[1];
2358 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2361 switch (actions & MDEREF_ACTION_MASK) {
2364 actions = (++items)->uv;
2366 NOT_REACHED; /* NOTREACHED */
2368 case MDEREF_HV_padhv_helem:
2371 case MDEREF_AV_padav_aelem:
2373 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2375 NOT_REACHED; /* NOTREACHED */
2377 case MDEREF_HV_gvhv_helem:
2380 case MDEREF_AV_gvav_aelem:
2383 sv = ITEM_SV(items);
2384 S_append_gv_name(aTHX_ (GV*)sv, out);
2386 NOT_REACHED; /* NOTREACHED */
2388 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2391 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2393 sv = ITEM_SV(items);
2394 S_append_gv_name(aTHX_ (GV*)sv, out);
2395 goto do_vivify_rv2xv_elem;
2396 NOT_REACHED; /* NOTREACHED */
2398 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2401 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2402 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2403 goto do_vivify_rv2xv_elem;
2404 NOT_REACHED; /* NOTREACHED */
2406 case MDEREF_HV_pop_rv2hv_helem:
2407 case MDEREF_HV_vivify_rv2hv_helem:
2410 do_vivify_rv2xv_elem:
2411 case MDEREF_AV_pop_rv2av_aelem:
2412 case MDEREF_AV_vivify_rv2av_aelem:
2414 sv_catpvs_nomg(out, "->");
2416 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2417 sv_catpvs_nomg(out, "->");
2422 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2423 switch (actions & MDEREF_INDEX_MASK) {
2424 case MDEREF_INDEX_const:
2427 sv = ITEM_SV(items);
2429 sv_catpvs_nomg(out, "???");
2434 pv_pretty(out, s, cur, 30,
2436 (PERL_PV_PRETTY_NOCLEAR
2437 |PERL_PV_PRETTY_QUOTE
2438 |PERL_PV_PRETTY_ELLIPSES));
2442 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2444 case MDEREF_INDEX_padsv:
2445 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2447 case MDEREF_INDEX_gvsv:
2449 sv = ITEM_SV(items);
2450 S_append_gv_name(aTHX_ (GV*)sv, out);
2453 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2455 if (actions & MDEREF_FLAG_last)
2462 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2463 (int)(actions & MDEREF_ACTION_MASK));
2469 actions >>= MDEREF_SHIFT;
2476 Perl_debop(pTHX_ const OP *o)
2478 PERL_ARGS_ASSERT_DEBOP;
2480 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2483 Perl_deb(aTHX_ "%s", OP_NAME(o));
2484 switch (o->op_type) {
2487 /* With ITHREADS, consts are stored in the pad, and the right pad
2488 * may not be active here, so check.
2489 * Looks like only during compiling the pads are illegal.
2492 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2494 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2498 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2499 SV * const sv = newSV(0);
2500 gv_fullname3(sv, cGVOPo_gv, NULL);
2501 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2502 SvREFCNT_dec_NN(sv);
2504 else if (cGVOPo_gv) {
2505 SV * const sv = newSV(0);
2506 assert(SvROK(cGVOPo_gv));
2507 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2508 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2509 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2510 SvREFCNT_dec_NN(sv);
2513 PerlIO_printf(Perl_debug_log, "(NULL)");
2520 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2524 S_deb_padvar(aTHX_ o->op_targ,
2525 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2529 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2530 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2536 PerlIO_printf(Perl_debug_log, "\n");
2541 S_deb_curcv(pTHX_ I32 ix)
2543 PERL_SI *si = PL_curstackinfo;
2544 for (; ix >=0; ix--) {
2545 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2547 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2548 return cx->blk_sub.cv;
2549 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2550 return cx->blk_eval.cv;
2551 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2553 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2554 && si->si_type == PERLSI_SORT)
2556 /* fake sort sub; use CV of caller */
2558 ix = si->si_cxix + 1;
2565 Perl_watch(pTHX_ char **addr)
2567 PERL_ARGS_ASSERT_WATCH;
2569 PL_watchaddr = addr;
2571 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2572 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2576 S_debprof(pTHX_ const OP *o)
2578 PERL_ARGS_ASSERT_DEBPROF;
2580 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2582 if (!PL_profiledata)
2583 Newxz(PL_profiledata, MAXO, U32);
2584 ++PL_profiledata[o->op_type];
2588 Perl_debprofdump(pTHX)
2591 if (!PL_profiledata)
2593 for (i = 0; i < MAXO; i++) {
2594 if (PL_profiledata[i])
2595 PerlIO_printf(Perl_debug_log,
2596 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2603 * ex: set ts=8 sts=4 sw=4 et: