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,"},
1427 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1434 PERL_ARGS_ASSERT_DO_SV_DUMP;
1437 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1441 flags = SvFLAGS(sv);
1444 /* process general SV flags */
1446 d = Perl_newSVpvf(aTHX_
1447 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1448 PTR2UV(SvANY(sv)), PTR2UV(sv),
1449 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1450 (int)(PL_dumpindent*level), "");
1452 if ((flags & SVs_PADSTALE))
1453 sv_catpv(d, "PADSTALE,");
1454 if ((flags & SVs_PADTMP))
1455 sv_catpv(d, "PADTMP,");
1456 append_flags(d, flags, first_sv_flags_names);
1457 if (flags & SVf_ROK) {
1458 sv_catpv(d, "ROK,");
1459 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1461 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1462 append_flags(d, flags, second_sv_flags_names);
1463 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1464 && type != SVt_PVAV) {
1465 if (SvPCS_IMPORTED(sv))
1466 sv_catpv(d, "PCS_IMPORTED,");
1468 sv_catpv(d, "SCREAM,");
1471 /* process type-specific SV flags */
1476 append_flags(d, CvFLAGS(sv), cv_flags_names);
1479 append_flags(d, flags, hv_flags_names);
1483 if (isGV_with_GP(sv)) {
1484 append_flags(d, GvFLAGS(sv), gp_flags_names);
1486 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1487 sv_catpv(d, "IMPORT");
1488 if (GvIMPORTED(sv) == GVf_IMPORTED)
1489 sv_catpv(d, "ALL,");
1492 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1499 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1500 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1503 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1504 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1510 /* SVphv_SHAREKEYS is also 0x20000000 */
1511 if ((type != SVt_PVHV) && SvUTF8(sv))
1512 sv_catpv(d, "UTF8");
1514 if (*(SvEND(d) - 1) == ',') {
1515 SvCUR_set(d, SvCUR(d) - 1);
1516 SvPVX(d)[SvCUR(d)] = '\0';
1521 /* dump initial SV details */
1523 #ifdef DEBUG_LEAKING_SCALARS
1524 Perl_dump_indent(aTHX_ level, file,
1525 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1526 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1528 sv->sv_debug_inpad ? "for" : "by",
1529 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1530 PTR2UV(sv->sv_debug_parent),
1534 Perl_dump_indent(aTHX_ level, file, "SV = ");
1538 if (type < SVt_LAST) {
1539 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1541 if (type == SVt_NULL) {
1546 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1551 /* Dump general SV fields */
1553 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1554 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1555 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1556 || (type == SVt_IV && !SvROK(sv))) {
1559 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1561 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1562 (void)PerlIO_putc(file, '\n');
1565 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1566 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1567 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1568 || type == SVt_NV) {
1569 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1570 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1571 RESTORE_LC_NUMERIC_UNDERLYING();
1575 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1577 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1580 if (type < SVt_PV) {
1585 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1586 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1587 const bool re = isREGEXP(sv);
1588 const char * const ptr =
1589 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1593 SvOOK_offset(sv, delta);
1594 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1599 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1601 PerlIO_printf(file, "( %s . ) ",
1602 pv_display(d, ptr - delta, delta, 0,
1605 if (type == SVt_INVLIST) {
1606 PerlIO_printf(file, "\n");
1607 /* 4 blanks indents 2 beyond the PV, etc */
1608 _invlist_dump(file, level, " ", sv);
1611 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1614 if (SvUTF8(sv)) /* the 6? \x{....} */
1615 PerlIO_printf(file, " [UTF8 \"%s\"]",
1616 sv_uni_display(d, sv, 6 * SvCUR(sv),
1618 PerlIO_printf(file, "\n");
1620 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1622 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1624 #ifdef PERL_COPY_ON_WRITE
1625 if (SvIsCOW(sv) && SvLEN(sv))
1626 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1631 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1634 if (type >= SVt_PVMG) {
1636 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1638 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1640 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1641 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1645 /* Dump type-specific SV fields */
1649 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1650 if (AvARRAY(sv) != AvALLOC(sv)) {
1651 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1652 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1655 (void)PerlIO_putc(file, '\n');
1656 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1657 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1658 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1659 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1661 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1662 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1663 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1664 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1665 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1667 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1668 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1670 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1672 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1679 struct xpvhv_aux *const aux = HvAUX(sv);
1680 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1681 (UV)aux->xhv_aux_flags);
1683 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1684 usedkeys = HvUSEDKEYS(sv);
1685 if (HvARRAY(sv) && usedkeys) {
1686 /* Show distribution of HEs in the ARRAY */
1688 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1691 U32 pow2 = 2, keys = usedkeys;
1692 NV theoret, sum = 0;
1694 PerlIO_printf(file, " (");
1695 Zero(freq, FREQ_MAX + 1, int);
1696 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1699 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1701 if (count > FREQ_MAX)
1707 for (i = 0; i <= max; i++) {
1709 PerlIO_printf(file, "%d%s:%d", i,
1710 (i == FREQ_MAX) ? "+" : "",
1713 PerlIO_printf(file, ", ");
1716 (void)PerlIO_putc(file, ')');
1717 /* The "quality" of a hash is defined as the total number of
1718 comparisons needed to access every element once, relative
1719 to the expected number needed for a random hash.
1721 The total number of comparisons is equal to the sum of
1722 the squares of the number of entries in each bucket.
1723 For a random hash of n keys into k buckets, the expected
1728 for (i = max; i > 0; i--) { /* Precision: count down. */
1729 sum += freq[i] * i * i;
1731 while ((keys = keys >> 1))
1734 theoret += theoret * (theoret-1)/pow2;
1735 (void)PerlIO_putc(file, '\n');
1736 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1738 (void)PerlIO_putc(file, '\n');
1739 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1742 HE **ents = HvARRAY(sv);
1745 HE *const *const last = ents + HvMAX(sv);
1746 count = last + 1 - ents;
1751 } while (++ents <= last);
1755 struct xpvhv_aux *const aux = HvAUX(sv);
1756 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1757 " (cached = %"UVuf")\n",
1758 (UV)count, (UV)aux->xhv_fill_lazy);
1760 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1764 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1766 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1767 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1768 #ifdef PERL_HASH_RANDOMIZE_KEYS
1769 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1770 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1771 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1774 (void)PerlIO_putc(file, '\n');
1777 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1778 if (mg && mg->mg_obj) {
1779 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1783 const char * const hvname = HvNAME_get(sv);
1785 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1786 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1787 generic_pv_escape( tmpsv, hvname,
1788 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1793 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1794 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1795 if (HvAUX(sv)->xhv_name_count)
1796 Perl_dump_indent(aTHX_
1797 level, file, " NAMECOUNT = %"IVdf"\n",
1798 (IV)HvAUX(sv)->xhv_name_count
1800 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1801 const I32 count = HvAUX(sv)->xhv_name_count;
1803 SV * const names = newSVpvs_flags("", SVs_TEMP);
1804 /* The starting point is the first element if count is
1805 positive and the second element if count is negative. */
1806 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1807 + (count < 0 ? 1 : 0);
1808 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1809 + (count < 0 ? -count : count);
1810 while (hekp < endp) {
1811 if (HEK_LEN(*hekp)) {
1812 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1813 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1814 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1816 /* This should never happen. */
1817 sv_catpvs(names, ", (null)");
1821 Perl_dump_indent(aTHX_
1822 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1826 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1827 const char *const hvename = HvENAME_get(sv);
1828 Perl_dump_indent(aTHX_
1829 level, file, " ENAME = \"%s\"\n",
1830 generic_pv_escape(tmp, hvename,
1831 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1835 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1837 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1841 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1842 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1843 generic_pv_escape( tmpsv, meta->mro_which->name,
1844 meta->mro_which->length,
1845 (meta->mro_which->kflags & HVhek_UTF8)),
1846 PTR2UV(meta->mro_which));
1847 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1848 (UV)meta->cache_gen);
1849 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1851 if (meta->mro_linear_all) {
1852 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1853 PTR2UV(meta->mro_linear_all));
1854 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1857 if (meta->mro_linear_current) {
1858 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1859 PTR2UV(meta->mro_linear_current));
1860 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1863 if (meta->mro_nextmethod) {
1864 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1865 PTR2UV(meta->mro_nextmethod));
1866 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1870 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1872 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1877 if (nest < maxnest) {
1878 HV * const hv = MUTABLE_HV(sv);
1883 int count = maxnest - nest;
1884 for (i=0; i <= HvMAX(hv); i++) {
1885 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1892 if (count-- <= 0) goto DONEHV;
1895 keysv = hv_iterkeysv(he);
1896 keypv = SvPV_const(keysv, len);
1899 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1901 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1902 if (HvEITER_get(hv) == he)
1903 PerlIO_printf(file, "[CURRENT] ");
1904 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1905 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1912 } /* case SVt_PVHV */
1915 if (CvAUTOLOAD(sv)) {
1916 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1918 const char *const name = SvPV_const(sv, len);
1919 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1920 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1923 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1924 const char *const proto = CvPROTO(sv);
1925 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1926 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1931 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1932 if (!CvISXSUB(sv)) {
1934 Perl_dump_indent(aTHX_ level, file,
1935 " START = 0x%"UVxf" ===> %"IVdf"\n",
1936 PTR2UV(CvSTART(sv)),
1937 (IV)sequence_num(CvSTART(sv)));
1939 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1940 PTR2UV(CvROOT(sv)));
1941 if (CvROOT(sv) && dumpops) {
1942 do_op_dump(level+1, file, CvROOT(sv));
1945 SV * const constant = cv_const_sv((const CV *)sv);
1947 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1950 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1952 PTR2UV(CvXSUBANY(sv).any_ptr));
1953 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1956 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1957 (IV)CvXSUBANY(sv).any_i32);
1961 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1962 HEK_KEY(CvNAME_HEK((CV *)sv)));
1963 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1964 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1965 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1966 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1967 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1968 if (!CvISXSUB(sv)) {
1969 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1970 if (nest < maxnest) {
1971 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1975 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
1977 const CV * const outside = CvOUTSIDE(sv);
1978 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1981 : CvANON(outside) ? "ANON"
1982 : (outside == PL_main_cv) ? "MAIN"
1983 : CvUNIQUE(outside) ? "UNIQUE"
1986 newSVpvs_flags("", SVs_TEMP),
1987 GvNAME(CvGV(outside)),
1988 GvNAMELEN(CvGV(outside)),
1989 GvNAMEUTF8(CvGV(outside)))
1993 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
1994 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1999 if (type == SVt_PVLV) {
2000 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2001 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2002 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2003 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2004 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2005 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2006 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2009 if (isREGEXP(sv)) goto dumpregexp;
2010 if (!isGV_with_GP(sv))
2013 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2014 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2015 generic_pv_escape(tmpsv, GvNAME(sv),
2019 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2020 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2021 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2022 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2025 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2026 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2027 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2028 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2029 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2030 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2031 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2032 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2033 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2037 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2038 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2039 do_gv_dump (level, file, " EGV", GvEGV(sv));
2042 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2044 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2045 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2046 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2047 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2048 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2050 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2051 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2052 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2054 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2055 PTR2UV(IoTOP_GV(sv)));
2056 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2057 maxnest, dumpops, pvlim);
2059 /* Source filters hide things that are not GVs in these three, so let's
2060 be careful out there. */
2062 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2063 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2064 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2066 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2067 PTR2UV(IoFMT_GV(sv)));
2068 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2069 maxnest, dumpops, pvlim);
2071 if (IoBOTTOM_NAME(sv))
2072 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2073 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2074 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2076 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2077 PTR2UV(IoBOTTOM_GV(sv)));
2078 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2079 maxnest, dumpops, pvlim);
2081 if (isPRINT(IoTYPE(sv)))
2082 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2084 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2085 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2090 struct regexp * const r = ReANY((REGEXP*)sv);
2092 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2094 append_flags(d, flags, names); \
2095 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2096 SvCUR_set(d, SvCUR(d) - 1); \
2097 SvPVX(d)[SvCUR(d)] = '\0'; \
2100 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2101 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2102 (UV)(r->compflags), SvPVX_const(d));
2104 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2105 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2106 (UV)(r->extflags), SvPVX_const(d));
2108 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2109 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2110 if (r->engine == &PL_core_reg_engine) {
2111 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2112 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2113 (UV)(r->intflags), SvPVX_const(d));
2115 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2118 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2119 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2121 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2122 (UV)(r->lastparen));
2123 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2124 (UV)(r->lastcloseparen));
2125 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2127 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2128 (IV)(r->minlenret));
2129 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2131 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2132 (UV)(r->pre_prefix));
2133 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2135 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2136 (IV)(r->suboffset));
2137 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2138 (IV)(r->subcoffset));
2140 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2142 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2144 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2145 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2146 PTR2UV(r->mother_re));
2147 if (nest < maxnest && r->mother_re)
2148 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2149 maxnest, dumpops, pvlim);
2150 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2151 PTR2UV(r->paren_names));
2152 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2153 PTR2UV(r->substrs));
2154 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2155 PTR2UV(r->pprivate));
2156 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2158 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2159 PTR2UV(r->qr_anoncv));
2161 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2162 PTR2UV(r->saved_copy));
2173 Dumps the contents of an SV to the C<STDERR> filehandle.
2175 For an example of its output, see L<Devel::Peek>.
2181 Perl_sv_dump(pTHX_ SV *sv)
2183 PERL_ARGS_ASSERT_SV_DUMP;
2186 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2188 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2192 Perl_runops_debug(pTHX)
2195 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2199 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2201 #ifdef PERL_TRACE_OPS
2202 ++PL_op_exec_cnt[PL_op->op_type];
2207 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2208 PerlIO_printf(Perl_debug_log,
2209 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2210 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2211 PTR2UV(*PL_watchaddr));
2212 if (DEBUG_s_TEST_) {
2213 if (DEBUG_v_TEST_) {
2214 PerlIO_printf(Perl_debug_log, "\n");
2222 if (DEBUG_t_TEST_) debop(PL_op);
2223 if (DEBUG_P_TEST_) debprof(PL_op);
2228 OP_ENTRY_PROBE(OP_NAME(PL_op));
2229 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2230 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2238 /* print the names of the n lexical vars starting at pad offset off */
2241 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2244 CV * const cv = deb_curcv(cxstack_ix);
2245 PADNAMELIST *comppad = NULL;
2249 PADLIST * const padlist = CvPADLIST(cv);
2250 comppad = PadlistNAMES(padlist);
2253 PerlIO_printf(Perl_debug_log, "(");
2254 for (i = 0; i < n; i++) {
2255 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2256 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2258 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2261 PerlIO_printf(Perl_debug_log, ",");
2264 PerlIO_printf(Perl_debug_log, ")");
2268 /* append to the out SV, the name of the lexical at offset off in the CV
2272 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2273 bool paren, bool is_scalar)
2276 PADNAMELIST *namepad = NULL;
2280 PADLIST * const padlist = CvPADLIST(cv);
2281 namepad = PadlistNAMES(padlist);
2285 sv_catpvs_nomg(out, "(");
2286 for (i = 0; i < n; i++) {
2287 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2289 STRLEN cur = SvCUR(out);
2290 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2291 UTF8fARG(1, PadnameLEN(sv) - 1,
2292 PadnamePV(sv) + 1));
2294 SvPVX(out)[cur] = '$';
2297 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2299 sv_catpvs_nomg(out, ",");
2302 sv_catpvs_nomg(out, "(");
2307 S_append_gv_name(pTHX_ GV *gv, SV *out)
2311 sv_catpvs_nomg(out, "<NULLGV>");
2315 gv_fullname4(sv, gv, NULL, FALSE);
2316 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2317 SvREFCNT_dec_NN(sv);
2321 # define ITEM_SV(item) (comppad ? \
2322 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2324 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2328 /* return a temporary SV containing a stringified representation of
2329 * the op_aux field of a MULTIDEREF op, associated with CV cv
2333 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2335 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2336 UV actions = items->uv;
2339 bool is_hash = FALSE;
2341 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2346 PADLIST *padlist = CvPADLIST(cv);
2347 comppad = PadlistARRAY(padlist)[1];
2353 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2356 switch (actions & MDEREF_ACTION_MASK) {
2359 actions = (++items)->uv;
2361 NOT_REACHED; /* NOTREACHED */
2363 case MDEREF_HV_padhv_helem:
2366 case MDEREF_AV_padav_aelem:
2368 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2370 NOT_REACHED; /* NOTREACHED */
2372 case MDEREF_HV_gvhv_helem:
2375 case MDEREF_AV_gvav_aelem:
2378 sv = ITEM_SV(items);
2379 S_append_gv_name(aTHX_ (GV*)sv, out);
2381 NOT_REACHED; /* NOTREACHED */
2383 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2386 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2388 sv = ITEM_SV(items);
2389 S_append_gv_name(aTHX_ (GV*)sv, out);
2390 goto do_vivify_rv2xv_elem;
2391 NOT_REACHED; /* NOTREACHED */
2393 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2396 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2397 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2398 goto do_vivify_rv2xv_elem;
2399 NOT_REACHED; /* NOTREACHED */
2401 case MDEREF_HV_pop_rv2hv_helem:
2402 case MDEREF_HV_vivify_rv2hv_helem:
2405 do_vivify_rv2xv_elem:
2406 case MDEREF_AV_pop_rv2av_aelem:
2407 case MDEREF_AV_vivify_rv2av_aelem:
2409 sv_catpvs_nomg(out, "->");
2411 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2412 sv_catpvs_nomg(out, "->");
2417 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2418 switch (actions & MDEREF_INDEX_MASK) {
2419 case MDEREF_INDEX_const:
2422 sv = ITEM_SV(items);
2424 sv_catpvs_nomg(out, "???");
2429 pv_pretty(out, s, cur, 30,
2431 (PERL_PV_PRETTY_NOCLEAR
2432 |PERL_PV_PRETTY_QUOTE
2433 |PERL_PV_PRETTY_ELLIPSES));
2437 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2439 case MDEREF_INDEX_padsv:
2440 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2442 case MDEREF_INDEX_gvsv:
2444 sv = ITEM_SV(items);
2445 S_append_gv_name(aTHX_ (GV*)sv, out);
2448 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2450 if (actions & MDEREF_FLAG_last)
2457 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2458 (int)(actions & MDEREF_ACTION_MASK));
2464 actions >>= MDEREF_SHIFT;
2471 Perl_debop(pTHX_ const OP *o)
2473 PERL_ARGS_ASSERT_DEBOP;
2475 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2478 Perl_deb(aTHX_ "%s", OP_NAME(o));
2479 switch (o->op_type) {
2482 /* With ITHREADS, consts are stored in the pad, and the right pad
2483 * may not be active here, so check.
2484 * Looks like only during compiling the pads are illegal.
2487 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2489 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2493 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2494 SV * const sv = newSV(0);
2495 gv_fullname3(sv, cGVOPo_gv, NULL);
2496 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2497 SvREFCNT_dec_NN(sv);
2499 else if (cGVOPo_gv) {
2500 SV * const sv = newSV(0);
2501 assert(SvROK(cGVOPo_gv));
2502 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2503 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2504 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2505 SvREFCNT_dec_NN(sv);
2508 PerlIO_printf(Perl_debug_log, "(NULL)");
2514 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2518 S_deb_padvar(aTHX_ o->op_targ,
2519 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2523 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2524 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2530 PerlIO_printf(Perl_debug_log, "\n");
2535 S_deb_curcv(pTHX_ I32 ix)
2537 PERL_SI *si = PL_curstackinfo;
2538 for (; ix >=0; ix--) {
2539 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2541 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2542 return cx->blk_sub.cv;
2543 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2544 return cx->blk_eval.cv;
2545 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2547 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2548 && si->si_type == PERLSI_SORT)
2550 /* fake sort sub; use CV of caller */
2552 ix = si->si_cxix + 1;
2559 Perl_watch(pTHX_ char **addr)
2561 PERL_ARGS_ASSERT_WATCH;
2563 PL_watchaddr = addr;
2565 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2566 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2570 S_debprof(pTHX_ const OP *o)
2572 PERL_ARGS_ASSERT_DEBPROF;
2574 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2576 if (!PL_profiledata)
2577 Newxz(PL_profiledata, MAXO, U32);
2578 ++PL_profiledata[o->op_type];
2582 Perl_debprofdump(pTHX)
2585 if (!PL_profiledata)
2587 for (i = 0; i < MAXO; i++) {
2588 if (PL_profiledata[i])
2589 PerlIO_printf(Perl_debug_log,
2590 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2597 * ex: set ts=8 sts=4 sw=4 et: