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 && av_tindex(MUTABLE_AV(sv)) >= 0) {
1677 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1678 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1680 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1682 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1689 struct xpvhv_aux *const aux = HvAUX(sv);
1690 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1691 (UV)aux->xhv_aux_flags);
1693 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1694 usedkeys = HvUSEDKEYS(sv);
1695 if (HvARRAY(sv) && usedkeys) {
1696 /* Show distribution of HEs in the ARRAY */
1698 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1701 U32 pow2 = 2, keys = usedkeys;
1702 NV theoret, sum = 0;
1704 PerlIO_printf(file, " (");
1705 Zero(freq, FREQ_MAX + 1, int);
1706 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1709 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1711 if (count > FREQ_MAX)
1717 for (i = 0; i <= max; i++) {
1719 PerlIO_printf(file, "%d%s:%d", i,
1720 (i == FREQ_MAX) ? "+" : "",
1723 PerlIO_printf(file, ", ");
1726 (void)PerlIO_putc(file, ')');
1727 /* The "quality" of a hash is defined as the total number of
1728 comparisons needed to access every element once, relative
1729 to the expected number needed for a random hash.
1731 The total number of comparisons is equal to the sum of
1732 the squares of the number of entries in each bucket.
1733 For a random hash of n keys into k buckets, the expected
1738 for (i = max; i > 0; i--) { /* Precision: count down. */
1739 sum += freq[i] * i * i;
1741 while ((keys = keys >> 1))
1744 theoret += theoret * (theoret-1)/pow2;
1745 (void)PerlIO_putc(file, '\n');
1746 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1748 (void)PerlIO_putc(file, '\n');
1749 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1752 HE **ents = HvARRAY(sv);
1755 HE *const *const last = ents + HvMAX(sv);
1756 count = last + 1 - ents;
1761 } while (++ents <= last);
1765 struct xpvhv_aux *const aux = HvAUX(sv);
1766 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1767 " (cached = %"UVuf")\n",
1768 (UV)count, (UV)aux->xhv_fill_lazy);
1770 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1774 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1776 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1777 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1778 #ifdef PERL_HASH_RANDOMIZE_KEYS
1779 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1780 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1781 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1784 (void)PerlIO_putc(file, '\n');
1787 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1788 if (mg && mg->mg_obj) {
1789 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1793 const char * const hvname = HvNAME_get(sv);
1795 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1796 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1797 generic_pv_escape( tmpsv, hvname,
1798 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1803 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1804 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1805 if (HvAUX(sv)->xhv_name_count)
1806 Perl_dump_indent(aTHX_
1807 level, file, " NAMECOUNT = %"IVdf"\n",
1808 (IV)HvAUX(sv)->xhv_name_count
1810 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1811 const I32 count = HvAUX(sv)->xhv_name_count;
1813 SV * const names = newSVpvs_flags("", SVs_TEMP);
1814 /* The starting point is the first element if count is
1815 positive and the second element if count is negative. */
1816 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1817 + (count < 0 ? 1 : 0);
1818 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1819 + (count < 0 ? -count : count);
1820 while (hekp < endp) {
1822 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1823 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1824 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1826 /* This should never happen. */
1827 sv_catpvs(names, ", (null)");
1831 Perl_dump_indent(aTHX_
1832 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1836 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1837 const char *const hvename = HvENAME_get(sv);
1838 Perl_dump_indent(aTHX_
1839 level, file, " ENAME = \"%s\"\n",
1840 generic_pv_escape(tmp, hvename,
1841 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1845 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1847 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1851 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1852 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1853 generic_pv_escape( tmpsv, meta->mro_which->name,
1854 meta->mro_which->length,
1855 (meta->mro_which->kflags & HVhek_UTF8)),
1856 PTR2UV(meta->mro_which));
1857 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1858 (UV)meta->cache_gen);
1859 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1861 if (meta->mro_linear_all) {
1862 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1863 PTR2UV(meta->mro_linear_all));
1864 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1867 if (meta->mro_linear_current) {
1868 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1869 PTR2UV(meta->mro_linear_current));
1870 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1873 if (meta->mro_nextmethod) {
1874 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1875 PTR2UV(meta->mro_nextmethod));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1880 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1882 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1887 if (nest < maxnest) {
1888 HV * const hv = MUTABLE_HV(sv);
1893 int count = maxnest - nest;
1894 for (i=0; i <= HvMAX(hv); i++) {
1895 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1902 if (count-- <= 0) goto DONEHV;
1905 keysv = hv_iterkeysv(he);
1906 keypv = SvPV_const(keysv, len);
1909 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1911 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1912 if (HvEITER_get(hv) == he)
1913 PerlIO_printf(file, "[CURRENT] ");
1914 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1915 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1922 } /* case SVt_PVHV */
1925 if (CvAUTOLOAD(sv)) {
1926 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1928 const char *const name = SvPV_const(sv, len);
1929 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1930 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1933 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1934 const char *const proto = CvPROTO(sv);
1935 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1936 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1941 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1942 if (!CvISXSUB(sv)) {
1944 Perl_dump_indent(aTHX_ level, file,
1945 " START = 0x%"UVxf" ===> %"IVdf"\n",
1946 PTR2UV(CvSTART(sv)),
1947 (IV)sequence_num(CvSTART(sv)));
1949 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1950 PTR2UV(CvROOT(sv)));
1951 if (CvROOT(sv) && dumpops) {
1952 do_op_dump(level+1, file, CvROOT(sv));
1955 SV * const constant = cv_const_sv((const CV *)sv);
1957 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1960 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1962 PTR2UV(CvXSUBANY(sv).any_ptr));
1963 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1966 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1967 (IV)CvXSUBANY(sv).any_i32);
1971 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1972 HEK_KEY(CvNAME_HEK((CV *)sv)));
1973 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1974 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1975 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1976 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1977 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1978 if (!CvISXSUB(sv)) {
1979 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1980 if (nest < maxnest) {
1981 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1985 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
1987 const CV * const outside = CvOUTSIDE(sv);
1988 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1991 : CvANON(outside) ? "ANON"
1992 : (outside == PL_main_cv) ? "MAIN"
1993 : CvUNIQUE(outside) ? "UNIQUE"
1996 newSVpvs_flags("", SVs_TEMP),
1997 GvNAME(CvGV(outside)),
1998 GvNAMELEN(CvGV(outside)),
1999 GvNAMEUTF8(CvGV(outside)))
2003 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2004 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2009 if (type == SVt_PVLV) {
2010 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2011 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2014 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2015 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2016 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2019 if (isREGEXP(sv)) goto dumpregexp;
2020 if (!isGV_with_GP(sv))
2023 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2024 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2025 generic_pv_escape(tmpsv, GvNAME(sv),
2029 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2030 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2031 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2032 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2037 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2043 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2047 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2048 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2049 do_gv_dump (level, file, " EGV", GvEGV(sv));
2052 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2056 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2057 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2058 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2060 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2061 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2062 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2064 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2065 PTR2UV(IoTOP_GV(sv)));
2066 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2067 maxnest, dumpops, pvlim);
2069 /* Source filters hide things that are not GVs in these three, so let's
2070 be careful out there. */
2072 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2073 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2074 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2076 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2077 PTR2UV(IoFMT_GV(sv)));
2078 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2079 maxnest, dumpops, pvlim);
2081 if (IoBOTTOM_NAME(sv))
2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2083 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2084 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2087 PTR2UV(IoBOTTOM_GV(sv)));
2088 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2089 maxnest, dumpops, pvlim);
2091 if (isPRINT(IoTYPE(sv)))
2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2094 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2095 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2100 struct regexp * const r = ReANY((REGEXP*)sv);
2102 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2104 append_flags(d, flags, names); \
2105 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2106 SvCUR_set(d, SvCUR(d) - 1); \
2107 SvPVX(d)[SvCUR(d)] = '\0'; \
2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2111 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2112 (UV)(r->compflags), SvPVX_const(d));
2114 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2115 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2116 (UV)(r->extflags), SvPVX_const(d));
2118 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2119 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2120 if (r->engine == &PL_core_reg_engine) {
2121 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2122 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2123 (UV)(r->intflags), SvPVX_const(d));
2125 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2128 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2129 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2131 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2132 (UV)(r->lastparen));
2133 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2134 (UV)(r->lastcloseparen));
2135 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2137 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2138 (IV)(r->minlenret));
2139 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2141 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2142 (UV)(r->pre_prefix));
2143 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2145 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2146 (IV)(r->suboffset));
2147 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2148 (IV)(r->subcoffset));
2150 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2152 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2154 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2155 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2156 PTR2UV(r->mother_re));
2157 if (nest < maxnest && r->mother_re)
2158 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2159 maxnest, dumpops, pvlim);
2160 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2161 PTR2UV(r->paren_names));
2162 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2163 PTR2UV(r->substrs));
2164 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2165 PTR2UV(r->pprivate));
2166 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2168 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2169 PTR2UV(r->qr_anoncv));
2171 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2172 PTR2UV(r->saved_copy));
2183 Dumps the contents of an SV to the C<STDERR> filehandle.
2185 For an example of its output, see L<Devel::Peek>.
2191 Perl_sv_dump(pTHX_ SV *sv)
2193 PERL_ARGS_ASSERT_SV_DUMP;
2196 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2198 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2202 Perl_runops_debug(pTHX)
2205 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2209 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2211 #ifdef PERL_TRACE_OPS
2212 ++PL_op_exec_cnt[PL_op->op_type];
2217 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2218 PerlIO_printf(Perl_debug_log,
2219 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2220 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2221 PTR2UV(*PL_watchaddr));
2222 if (DEBUG_s_TEST_) {
2223 if (DEBUG_v_TEST_) {
2224 PerlIO_printf(Perl_debug_log, "\n");
2232 if (DEBUG_t_TEST_) debop(PL_op);
2233 if (DEBUG_P_TEST_) debprof(PL_op);
2238 PERL_DTRACE_PROBE_OP(PL_op);
2239 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2240 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2248 /* print the names of the n lexical vars starting at pad offset off */
2251 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2254 CV * const cv = deb_curcv(cxstack_ix);
2255 PADNAMELIST *comppad = NULL;
2259 PADLIST * const padlist = CvPADLIST(cv);
2260 comppad = PadlistNAMES(padlist);
2263 PerlIO_printf(Perl_debug_log, "(");
2264 for (i = 0; i < n; i++) {
2265 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2266 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2268 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2271 PerlIO_printf(Perl_debug_log, ",");
2274 PerlIO_printf(Perl_debug_log, ")");
2278 /* append to the out SV, the name of the lexical at offset off in the CV
2282 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2283 bool paren, bool is_scalar)
2286 PADNAMELIST *namepad = NULL;
2290 PADLIST * const padlist = CvPADLIST(cv);
2291 namepad = PadlistNAMES(padlist);
2295 sv_catpvs_nomg(out, "(");
2296 for (i = 0; i < n; i++) {
2297 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2299 STRLEN cur = SvCUR(out);
2300 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2301 UTF8fARG(1, PadnameLEN(sv) - 1,
2302 PadnamePV(sv) + 1));
2304 SvPVX(out)[cur] = '$';
2307 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2309 sv_catpvs_nomg(out, ",");
2312 sv_catpvs_nomg(out, "(");
2317 S_append_gv_name(pTHX_ GV *gv, SV *out)
2321 sv_catpvs_nomg(out, "<NULLGV>");
2325 gv_fullname4(sv, gv, NULL, FALSE);
2326 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2327 SvREFCNT_dec_NN(sv);
2331 # define ITEM_SV(item) (comppad ? \
2332 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2334 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2338 /* return a temporary SV containing a stringified representation of
2339 * the op_aux field of a MULTIDEREF op, associated with CV cv
2343 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2345 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2346 UV actions = items->uv;
2349 bool is_hash = FALSE;
2351 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2356 PADLIST *padlist = CvPADLIST(cv);
2357 comppad = PadlistARRAY(padlist)[1];
2363 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2366 switch (actions & MDEREF_ACTION_MASK) {
2369 actions = (++items)->uv;
2371 NOT_REACHED; /* NOTREACHED */
2373 case MDEREF_HV_padhv_helem:
2376 case MDEREF_AV_padav_aelem:
2378 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2380 NOT_REACHED; /* NOTREACHED */
2382 case MDEREF_HV_gvhv_helem:
2385 case MDEREF_AV_gvav_aelem:
2388 sv = ITEM_SV(items);
2389 S_append_gv_name(aTHX_ (GV*)sv, out);
2391 NOT_REACHED; /* NOTREACHED */
2393 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2396 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2398 sv = ITEM_SV(items);
2399 S_append_gv_name(aTHX_ (GV*)sv, out);
2400 goto do_vivify_rv2xv_elem;
2401 NOT_REACHED; /* NOTREACHED */
2403 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2406 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2407 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2408 goto do_vivify_rv2xv_elem;
2409 NOT_REACHED; /* NOTREACHED */
2411 case MDEREF_HV_pop_rv2hv_helem:
2412 case MDEREF_HV_vivify_rv2hv_helem:
2415 do_vivify_rv2xv_elem:
2416 case MDEREF_AV_pop_rv2av_aelem:
2417 case MDEREF_AV_vivify_rv2av_aelem:
2419 sv_catpvs_nomg(out, "->");
2421 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2422 sv_catpvs_nomg(out, "->");
2427 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2428 switch (actions & MDEREF_INDEX_MASK) {
2429 case MDEREF_INDEX_const:
2432 sv = ITEM_SV(items);
2434 sv_catpvs_nomg(out, "???");
2439 pv_pretty(out, s, cur, 30,
2441 (PERL_PV_PRETTY_NOCLEAR
2442 |PERL_PV_PRETTY_QUOTE
2443 |PERL_PV_PRETTY_ELLIPSES));
2447 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2449 case MDEREF_INDEX_padsv:
2450 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2452 case MDEREF_INDEX_gvsv:
2454 sv = ITEM_SV(items);
2455 S_append_gv_name(aTHX_ (GV*)sv, out);
2458 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2460 if (actions & MDEREF_FLAG_last)
2467 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2468 (int)(actions & MDEREF_ACTION_MASK));
2474 actions >>= MDEREF_SHIFT;
2481 Perl_debop(pTHX_ const OP *o)
2483 PERL_ARGS_ASSERT_DEBOP;
2485 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2488 Perl_deb(aTHX_ "%s", OP_NAME(o));
2489 switch (o->op_type) {
2492 /* With ITHREADS, consts are stored in the pad, and the right pad
2493 * may not be active here, so check.
2494 * Looks like only during compiling the pads are illegal.
2497 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2499 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2503 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2504 SV * const sv = newSV(0);
2505 gv_fullname3(sv, cGVOPo_gv, NULL);
2506 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2507 SvREFCNT_dec_NN(sv);
2509 else if (cGVOPo_gv) {
2510 SV * const sv = newSV(0);
2511 assert(SvROK(cGVOPo_gv));
2512 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2513 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2514 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2515 SvREFCNT_dec_NN(sv);
2518 PerlIO_printf(Perl_debug_log, "(NULL)");
2524 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2528 S_deb_padvar(aTHX_ o->op_targ,
2529 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2533 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2534 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2540 PerlIO_printf(Perl_debug_log, "\n");
2545 S_deb_curcv(pTHX_ I32 ix)
2547 PERL_SI *si = PL_curstackinfo;
2548 for (; ix >=0; ix--) {
2549 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2551 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2552 return cx->blk_sub.cv;
2553 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2554 return cx->blk_eval.cv;
2555 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2557 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2558 && si->si_type == PERLSI_SORT)
2560 /* fake sort sub; use CV of caller */
2562 ix = si->si_cxix + 1;
2569 Perl_watch(pTHX_ char **addr)
2571 PERL_ARGS_ASSERT_WATCH;
2573 PL_watchaddr = addr;
2575 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2576 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2580 S_debprof(pTHX_ const OP *o)
2582 PERL_ARGS_ASSERT_DEBPROF;
2584 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2586 if (!PL_profiledata)
2587 Newxz(PL_profiledata, MAXO, U32);
2588 ++PL_profiledata[o->op_type];
2592 Perl_debprofdump(pTHX)
2595 if (!PL_profiledata)
2597 for (i = 0; i < MAXO; i++) {
2598 if (PL_profiledata[i])
2599 PerlIO_printf(Perl_debug_log,
2600 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2607 * ex: set ts=8 sts=4 sw=4 et: