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",
975 case OP_METHOD_NAMED:
976 case OP_METHOD_SUPER:
977 case OP_METHOD_REDIR:
978 case OP_METHOD_REDIR_SUPER:
980 /* with ITHREADS, consts are stored in the pad, and the right pad
981 * may not be active here, so skip */
982 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
986 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
992 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
994 if (CopSTASHPV(cCOPo)) {
995 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
996 HV *stash = CopSTASH(cCOPo);
997 const char * const hvname = HvNAME_get(stash);
999 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1000 generic_pv_escape(tmpsv, hvname,
1001 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1003 if (CopLABEL(cCOPo)) {
1004 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1007 const char *label = CopLABEL_len_flags(cCOPo,
1008 &label_len, &label_flags);
1009 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1010 generic_pv_escape( tmpsv, label, label_len,
1011 (label_flags & SVf_UTF8)));
1013 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1014 (unsigned int)cCOPo->cop_seq);
1017 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1018 if (cLOOPo->op_redoop)
1019 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1021 PerlIO_printf(file, "DONE\n");
1022 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1023 if (cLOOPo->op_nextop)
1024 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1026 PerlIO_printf(file, "DONE\n");
1027 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1028 if (cLOOPo->op_lastop)
1029 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1031 PerlIO_printf(file, "DONE\n");
1039 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1040 if (cLOGOPo->op_other)
1041 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1043 PerlIO_printf(file, "DONE\n");
1049 do_pmop_dump(level, file, cPMOPo);
1057 if (o->op_private & OPpREFCOUNTED)
1058 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1063 if (o->op_flags & OPf_KIDS) {
1065 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1066 do_op_dump(level, file, kid);
1068 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1074 Dumps the optree starting at OP C<o> to C<STDERR>.
1080 Perl_op_dump(pTHX_ const OP *o)
1082 PERL_ARGS_ASSERT_OP_DUMP;
1083 do_op_dump(0, Perl_debug_log, o);
1087 Perl_gv_dump(pTHX_ GV *gv)
1091 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1094 PerlIO_printf(Perl_debug_log, "{}\n");
1097 sv = sv_newmortal();
1098 PerlIO_printf(Perl_debug_log, "{\n");
1099 gv_fullname3(sv, gv, NULL);
1100 name = SvPV_const(sv, len);
1101 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1102 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1103 if (gv != GvEGV(gv)) {
1104 gv_efullname3(sv, GvEGV(gv), NULL);
1105 name = SvPV_const(sv, len);
1106 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1107 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1109 (void)PerlIO_putc(Perl_debug_log, '\n');
1110 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1114 /* map magic types to the symbolic names
1115 * (with the PERL_MAGIC_ prefixed stripped)
1118 static const struct { const char type; const char *name; } magic_names[] = {
1119 #include "mg_names.inc"
1120 /* this null string terminates the list */
1125 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1127 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1129 for (; mg; mg = mg->mg_moremagic) {
1130 Perl_dump_indent(aTHX_ level, file,
1131 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1132 if (mg->mg_virtual) {
1133 const MGVTBL * const v = mg->mg_virtual;
1134 if (v >= PL_magic_vtables
1135 && v < PL_magic_vtables + magic_vtable_max) {
1136 const U32 i = v - PL_magic_vtables;
1137 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1140 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1143 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1146 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1150 const char *name = NULL;
1151 for (n = 0; magic_names[n].name; n++) {
1152 if (mg->mg_type == magic_names[n].type) {
1153 name = magic_names[n].name;
1158 Perl_dump_indent(aTHX_ level, file,
1159 " MG_TYPE = PERL_MAGIC_%s\n", name);
1161 Perl_dump_indent(aTHX_ level, file,
1162 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1166 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1167 if (mg->mg_type == PERL_MAGIC_envelem &&
1168 mg->mg_flags & MGf_TAINTEDDIR)
1169 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1170 if (mg->mg_type == PERL_MAGIC_regex_global &&
1171 mg->mg_flags & MGf_MINMATCH)
1172 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1173 if (mg->mg_flags & MGf_REFCOUNTED)
1174 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1175 if (mg->mg_flags & MGf_GSKIP)
1176 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1177 if (mg->mg_flags & MGf_COPY)
1178 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1179 if (mg->mg_flags & MGf_DUP)
1180 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1181 if (mg->mg_flags & MGf_LOCAL)
1182 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1183 if (mg->mg_type == PERL_MAGIC_regex_global &&
1184 mg->mg_flags & MGf_BYTES)
1185 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1188 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1189 PTR2UV(mg->mg_obj));
1190 if (mg->mg_type == PERL_MAGIC_qr) {
1191 REGEXP* const re = (REGEXP *)mg->mg_obj;
1192 SV * const dsv = sv_newmortal();
1193 const char * const s
1194 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1196 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1197 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1199 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1200 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1203 if (mg->mg_flags & MGf_REFCOUNTED)
1204 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1207 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1209 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1210 if (mg->mg_len >= 0) {
1211 if (mg->mg_type != PERL_MAGIC_utf8) {
1212 SV * const sv = newSVpvs("");
1213 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1214 SvREFCNT_dec_NN(sv);
1217 else if (mg->mg_len == HEf_SVKEY) {
1218 PerlIO_puts(file, " => HEf_SVKEY\n");
1219 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1220 maxnest, dumpops, pvlim); /* MG is already +1 */
1223 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1228 " does not know how to handle this MG_LEN"
1230 (void)PerlIO_putc(file, '\n');
1232 if (mg->mg_type == PERL_MAGIC_utf8) {
1233 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1236 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1237 Perl_dump_indent(aTHX_ level, file,
1238 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1241 (UV)cache[i * 2 + 1]);
1248 Perl_magic_dump(pTHX_ const MAGIC *mg)
1250 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1254 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1258 PERL_ARGS_ASSERT_DO_HV_DUMP;
1260 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1261 if (sv && (hvname = HvNAME_get(sv)))
1263 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1264 name which quite legally could contain insane things like tabs, newlines, nulls or
1265 other scary crap - this should produce sane results - except maybe for unicode package
1266 names - but we will wait for someone to file a bug on that - demerphq */
1267 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1268 PerlIO_printf(file, "\t\"%s\"\n",
1269 generic_pv_escape( tmpsv, hvname,
1270 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1273 (void)PerlIO_putc(file, '\n');
1277 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1279 PERL_ARGS_ASSERT_DO_GV_DUMP;
1281 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1282 if (sv && GvNAME(sv)) {
1283 SV * const tmpsv = newSVpvs("");
1284 PerlIO_printf(file, "\t\"%s\"\n",
1285 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1288 (void)PerlIO_putc(file, '\n');
1292 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1294 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1296 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1297 if (sv && GvNAME(sv)) {
1298 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1300 HV * const stash = GvSTASH(sv);
1301 PerlIO_printf(file, "\t");
1302 /* TODO might have an extra \" here */
1303 if (stash && (hvname = HvNAME_get(stash))) {
1304 PerlIO_printf(file, "\"%s\" :: \"",
1305 generic_pv_escape(tmp, hvname,
1306 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1308 PerlIO_printf(file, "%s\"\n",
1309 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1312 (void)PerlIO_putc(file, '\n');
1315 const struct flag_to_name first_sv_flags_names[] = {
1316 {SVs_TEMP, "TEMP,"},
1317 {SVs_OBJECT, "OBJECT,"},
1326 const struct flag_to_name second_sv_flags_names[] = {
1328 {SVf_FAKE, "FAKE,"},
1329 {SVf_READONLY, "READONLY,"},
1330 {SVf_PROTECT, "PROTECT,"},
1331 {SVf_BREAK, "BREAK,"},
1337 const struct flag_to_name cv_flags_names[] = {
1338 {CVf_ANON, "ANON,"},
1339 {CVf_UNIQUE, "UNIQUE,"},
1340 {CVf_CLONE, "CLONE,"},
1341 {CVf_CLONED, "CLONED,"},
1342 {CVf_CONST, "CONST,"},
1343 {CVf_NODEBUG, "NODEBUG,"},
1344 {CVf_LVALUE, "LVALUE,"},
1345 {CVf_METHOD, "METHOD,"},
1346 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1347 {CVf_CVGV_RC, "CVGV_RC,"},
1348 {CVf_DYNFILE, "DYNFILE,"},
1349 {CVf_AUTOLOAD, "AUTOLOAD,"},
1350 {CVf_HASEVAL, "HASEVAL,"},
1351 {CVf_SLABBED, "SLABBED,"},
1352 {CVf_NAMED, "NAMED,"},
1353 {CVf_LEXICAL, "LEXICAL,"},
1354 {CVf_ISXSUB, "ISXSUB,"}
1357 const struct flag_to_name hv_flags_names[] = {
1358 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1359 {SVphv_LAZYDEL, "LAZYDEL,"},
1360 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1361 {SVf_AMAGIC, "OVERLOAD,"},
1362 {SVphv_CLONEABLE, "CLONEABLE,"}
1365 const struct flag_to_name gp_flags_names[] = {
1366 {GVf_INTRO, "INTRO,"},
1367 {GVf_MULTI, "MULTI,"},
1368 {GVf_ASSUMECV, "ASSUMECV,"},
1371 const struct flag_to_name gp_flags_imported_names[] = {
1372 {GVf_IMPORTED_SV, " SV"},
1373 {GVf_IMPORTED_AV, " AV"},
1374 {GVf_IMPORTED_HV, " HV"},
1375 {GVf_IMPORTED_CV, " CV"},
1378 /* NOTE: this structure is mostly duplicative of one generated by
1379 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1380 * the two. - Yves */
1381 const struct flag_to_name regexp_extflags_names[] = {
1382 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1383 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1384 {RXf_PMf_FOLD, "PMf_FOLD,"},
1385 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1386 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1387 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1388 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1389 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1390 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1391 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1392 {RXf_CHECK_ALL, "CHECK_ALL,"},
1393 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1394 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1395 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1396 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1397 {RXf_SPLIT, "SPLIT,"},
1398 {RXf_COPY_DONE, "COPY_DONE,"},
1399 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1400 {RXf_TAINTED, "TAINTED,"},
1401 {RXf_START_ONLY, "START_ONLY,"},
1402 {RXf_SKIPWHITE, "SKIPWHITE,"},
1403 {RXf_WHITE, "WHITE,"},
1404 {RXf_NULL, "NULL,"},
1407 /* NOTE: this structure is mostly duplicative of one generated by
1408 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1409 * the two. - Yves */
1410 const struct flag_to_name regexp_core_intflags_names[] = {
1411 {PREGf_SKIP, "SKIP,"},
1412 {PREGf_IMPLICIT, "IMPLICIT,"},
1413 {PREGf_NAUGHTY, "NAUGHTY,"},
1414 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1415 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1416 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1417 {PREGf_NOSCAN, "NOSCAN,"},
1418 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1419 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1420 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1421 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1422 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1426 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1433 PERL_ARGS_ASSERT_DO_SV_DUMP;
1436 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1440 flags = SvFLAGS(sv);
1443 /* process general SV flags */
1445 d = Perl_newSVpvf(aTHX_
1446 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1447 PTR2UV(SvANY(sv)), PTR2UV(sv),
1448 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1449 (int)(PL_dumpindent*level), "");
1451 if ((flags & SVs_PADSTALE))
1452 sv_catpv(d, "PADSTALE,");
1453 if ((flags & SVs_PADTMP))
1454 sv_catpv(d, "PADTMP,");
1455 append_flags(d, flags, first_sv_flags_names);
1456 if (flags & SVf_ROK) {
1457 sv_catpv(d, "ROK,");
1458 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1460 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1461 append_flags(d, flags, second_sv_flags_names);
1462 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1463 && type != SVt_PVAV) {
1464 if (SvPCS_IMPORTED(sv))
1465 sv_catpv(d, "PCS_IMPORTED,");
1467 sv_catpv(d, "SCREAM,");
1470 /* process type-specific SV flags */
1475 append_flags(d, CvFLAGS(sv), cv_flags_names);
1478 append_flags(d, flags, hv_flags_names);
1482 if (isGV_with_GP(sv)) {
1483 append_flags(d, GvFLAGS(sv), gp_flags_names);
1485 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1486 sv_catpv(d, "IMPORT");
1487 if (GvIMPORTED(sv) == GVf_IMPORTED)
1488 sv_catpv(d, "ALL,");
1491 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1498 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1499 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1502 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1503 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1509 /* SVphv_SHAREKEYS is also 0x20000000 */
1510 if ((type != SVt_PVHV) && SvUTF8(sv))
1511 sv_catpv(d, "UTF8");
1513 if (*(SvEND(d) - 1) == ',') {
1514 SvCUR_set(d, SvCUR(d) - 1);
1515 SvPVX(d)[SvCUR(d)] = '\0';
1520 /* dump initial SV details */
1522 #ifdef DEBUG_LEAKING_SCALARS
1523 Perl_dump_indent(aTHX_ level, file,
1524 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1525 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1527 sv->sv_debug_inpad ? "for" : "by",
1528 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1529 PTR2UV(sv->sv_debug_parent),
1533 Perl_dump_indent(aTHX_ level, file, "SV = ");
1537 if (type < SVt_LAST) {
1538 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1540 if (type == SVt_NULL) {
1545 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1550 /* Dump general SV fields */
1552 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1553 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1554 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1555 || (type == SVt_IV && !SvROK(sv))) {
1558 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1560 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1561 (void)PerlIO_putc(file, '\n');
1564 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1565 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1566 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1567 || type == SVt_NV) {
1568 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1569 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1570 RESTORE_LC_NUMERIC_UNDERLYING();
1574 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1576 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1579 if (type < SVt_PV) {
1584 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1585 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1586 const bool re = isREGEXP(sv);
1587 const char * const ptr =
1588 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1592 SvOOK_offset(sv, delta);
1593 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1598 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1600 PerlIO_printf(file, "( %s . ) ",
1601 pv_display(d, ptr - delta, delta, 0,
1604 if (type == SVt_INVLIST) {
1605 PerlIO_printf(file, "\n");
1606 /* 4 blanks indents 2 beyond the PV, etc */
1607 _invlist_dump(file, level, " ", sv);
1610 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1613 if (SvUTF8(sv)) /* the 6? \x{....} */
1614 PerlIO_printf(file, " [UTF8 \"%s\"]",
1615 sv_uni_display(d, sv, 6 * SvCUR(sv),
1617 PerlIO_printf(file, "\n");
1619 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1621 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1623 #ifdef PERL_COPY_ON_WRITE
1624 if (SvIsCOW(sv) && SvLEN(sv))
1625 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1630 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1633 if (type >= SVt_PVMG) {
1635 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1637 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1639 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1640 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1644 /* Dump type-specific SV fields */
1648 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1649 if (AvARRAY(sv) != AvALLOC(sv)) {
1650 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1651 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1654 (void)PerlIO_putc(file, '\n');
1655 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1656 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1657 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1658 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1660 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1661 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1662 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1663 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1664 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1666 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1667 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1669 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1671 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1678 struct xpvhv_aux *const aux = HvAUX(sv);
1679 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1680 (UV)aux->xhv_aux_flags);
1682 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1683 usedkeys = HvUSEDKEYS(sv);
1684 if (HvARRAY(sv) && usedkeys) {
1685 /* Show distribution of HEs in the ARRAY */
1687 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1690 U32 pow2 = 2, keys = usedkeys;
1691 NV theoret, sum = 0;
1693 PerlIO_printf(file, " (");
1694 Zero(freq, FREQ_MAX + 1, int);
1695 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1698 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1700 if (count > FREQ_MAX)
1706 for (i = 0; i <= max; i++) {
1708 PerlIO_printf(file, "%d%s:%d", i,
1709 (i == FREQ_MAX) ? "+" : "",
1712 PerlIO_printf(file, ", ");
1715 (void)PerlIO_putc(file, ')');
1716 /* The "quality" of a hash is defined as the total number of
1717 comparisons needed to access every element once, relative
1718 to the expected number needed for a random hash.
1720 The total number of comparisons is equal to the sum of
1721 the squares of the number of entries in each bucket.
1722 For a random hash of n keys into k buckets, the expected
1727 for (i = max; i > 0; i--) { /* Precision: count down. */
1728 sum += freq[i] * i * i;
1730 while ((keys = keys >> 1))
1733 theoret += theoret * (theoret-1)/pow2;
1734 (void)PerlIO_putc(file, '\n');
1735 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1737 (void)PerlIO_putc(file, '\n');
1738 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1741 HE **ents = HvARRAY(sv);
1744 HE *const *const last = ents + HvMAX(sv);
1745 count = last + 1 - ents;
1750 } while (++ents <= last);
1754 struct xpvhv_aux *const aux = HvAUX(sv);
1755 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1756 " (cached = %"UVuf")\n",
1757 (UV)count, (UV)aux->xhv_fill_lazy);
1759 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1763 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1765 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1766 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1767 #ifdef PERL_HASH_RANDOMIZE_KEYS
1768 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1769 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1770 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1773 (void)PerlIO_putc(file, '\n');
1776 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1777 if (mg && mg->mg_obj) {
1778 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1782 const char * const hvname = HvNAME_get(sv);
1784 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1785 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1786 generic_pv_escape( tmpsv, hvname,
1787 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1792 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1793 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1794 if (HvAUX(sv)->xhv_name_count)
1795 Perl_dump_indent(aTHX_
1796 level, file, " NAMECOUNT = %"IVdf"\n",
1797 (IV)HvAUX(sv)->xhv_name_count
1799 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1800 const I32 count = HvAUX(sv)->xhv_name_count;
1802 SV * const names = newSVpvs_flags("", SVs_TEMP);
1803 /* The starting point is the first element if count is
1804 positive and the second element if count is negative. */
1805 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1806 + (count < 0 ? 1 : 0);
1807 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1808 + (count < 0 ? -count : count);
1809 while (hekp < endp) {
1810 if (HEK_LEN(*hekp)) {
1811 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1812 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1813 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1815 /* This should never happen. */
1816 sv_catpvs(names, ", (null)");
1820 Perl_dump_indent(aTHX_
1821 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1825 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1826 const char *const hvename = HvENAME_get(sv);
1827 Perl_dump_indent(aTHX_
1828 level, file, " ENAME = \"%s\"\n",
1829 generic_pv_escape(tmp, hvename,
1830 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1834 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1836 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1840 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1841 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1842 generic_pv_escape( tmpsv, meta->mro_which->name,
1843 meta->mro_which->length,
1844 (meta->mro_which->kflags & HVhek_UTF8)),
1845 PTR2UV(meta->mro_which));
1846 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1847 (UV)meta->cache_gen);
1848 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1850 if (meta->mro_linear_all) {
1851 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1852 PTR2UV(meta->mro_linear_all));
1853 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1856 if (meta->mro_linear_current) {
1857 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1858 PTR2UV(meta->mro_linear_current));
1859 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1862 if (meta->mro_nextmethod) {
1863 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1864 PTR2UV(meta->mro_nextmethod));
1865 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1869 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1871 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1876 if (nest < maxnest) {
1877 HV * const hv = MUTABLE_HV(sv);
1882 int count = maxnest - nest;
1883 for (i=0; i <= HvMAX(hv); i++) {
1884 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1891 if (count-- <= 0) goto DONEHV;
1894 keysv = hv_iterkeysv(he);
1895 keypv = SvPV_const(keysv, len);
1898 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1900 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1901 if (HvEITER_get(hv) == he)
1902 PerlIO_printf(file, "[CURRENT] ");
1903 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1904 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1911 } /* case SVt_PVHV */
1914 if (CvAUTOLOAD(sv)) {
1915 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1917 const char *const name = SvPV_const(sv, len);
1918 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1919 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1922 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1923 const char *const proto = CvPROTO(sv);
1924 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1925 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1930 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1931 if (!CvISXSUB(sv)) {
1933 Perl_dump_indent(aTHX_ level, file,
1934 " START = 0x%"UVxf" ===> %"IVdf"\n",
1935 PTR2UV(CvSTART(sv)),
1936 (IV)sequence_num(CvSTART(sv)));
1938 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1939 PTR2UV(CvROOT(sv)));
1940 if (CvROOT(sv) && dumpops) {
1941 do_op_dump(level+1, file, CvROOT(sv));
1944 SV * const constant = cv_const_sv((const CV *)sv);
1946 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1949 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1951 PTR2UV(CvXSUBANY(sv).any_ptr));
1952 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1955 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1956 (IV)CvXSUBANY(sv).any_i32);
1960 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1961 HEK_KEY(CvNAME_HEK((CV *)sv)));
1962 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1963 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1964 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1965 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1966 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1967 if (!CvISXSUB(sv)) {
1968 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1969 if (nest < maxnest) {
1970 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1974 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
1976 const CV * const outside = CvOUTSIDE(sv);
1977 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1980 : CvANON(outside) ? "ANON"
1981 : (outside == PL_main_cv) ? "MAIN"
1982 : CvUNIQUE(outside) ? "UNIQUE"
1985 newSVpvs_flags("", SVs_TEMP),
1986 GvNAME(CvGV(outside)),
1987 GvNAMELEN(CvGV(outside)),
1988 GvNAMEUTF8(CvGV(outside)))
1992 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
1993 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1998 if (type == SVt_PVLV) {
1999 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2000 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2001 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2002 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2003 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2004 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2005 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2008 if (isREGEXP(sv)) goto dumpregexp;
2009 if (!isGV_with_GP(sv))
2012 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2013 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2014 generic_pv_escape(tmpsv, GvNAME(sv),
2018 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2019 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2020 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2021 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2024 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2025 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2026 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2027 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2028 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2029 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2030 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2031 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2032 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2036 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2037 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2038 do_gv_dump (level, file, " EGV", GvEGV(sv));
2041 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2044 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2045 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2046 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2047 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2049 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2050 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2051 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2053 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2054 PTR2UV(IoTOP_GV(sv)));
2055 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2056 maxnest, dumpops, pvlim);
2058 /* Source filters hide things that are not GVs in these three, so let's
2059 be careful out there. */
2061 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2062 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2063 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2065 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2066 PTR2UV(IoFMT_GV(sv)));
2067 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2068 maxnest, dumpops, pvlim);
2070 if (IoBOTTOM_NAME(sv))
2071 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2072 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2073 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2075 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2076 PTR2UV(IoBOTTOM_GV(sv)));
2077 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2078 maxnest, dumpops, pvlim);
2080 if (isPRINT(IoTYPE(sv)))
2081 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2083 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2084 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2089 struct regexp * const r = ReANY((REGEXP*)sv);
2091 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2093 append_flags(d, flags, names); \
2094 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2095 SvCUR_set(d, SvCUR(d) - 1); \
2096 SvPVX(d)[SvCUR(d)] = '\0'; \
2099 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2100 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2101 (UV)(r->compflags), SvPVX_const(d));
2103 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2104 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2105 (UV)(r->extflags), SvPVX_const(d));
2107 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2108 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2109 if (r->engine == &PL_core_reg_engine) {
2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2111 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2112 (UV)(r->intflags), SvPVX_const(d));
2114 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2117 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2118 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2120 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2121 (UV)(r->lastparen));
2122 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2123 (UV)(r->lastcloseparen));
2124 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2126 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2127 (IV)(r->minlenret));
2128 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2130 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2131 (UV)(r->pre_prefix));
2132 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2134 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2135 (IV)(r->suboffset));
2136 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2137 (IV)(r->subcoffset));
2139 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2141 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2143 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2144 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2145 PTR2UV(r->mother_re));
2146 if (nest < maxnest && r->mother_re)
2147 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2148 maxnest, dumpops, pvlim);
2149 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2150 PTR2UV(r->paren_names));
2151 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2152 PTR2UV(r->substrs));
2153 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2154 PTR2UV(r->pprivate));
2155 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2157 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2158 PTR2UV(r->qr_anoncv));
2160 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2161 PTR2UV(r->saved_copy));
2172 Dumps the contents of an SV to the C<STDERR> filehandle.
2174 For an example of its output, see L<Devel::Peek>.
2180 Perl_sv_dump(pTHX_ SV *sv)
2182 PERL_ARGS_ASSERT_SV_DUMP;
2185 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2187 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2191 Perl_runops_debug(pTHX)
2194 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2198 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2200 #ifdef PERL_TRACE_OPS
2201 ++PL_op_exec_cnt[PL_op->op_type];
2204 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2205 PerlIO_printf(Perl_debug_log,
2206 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2207 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2208 PTR2UV(*PL_watchaddr));
2209 if (DEBUG_s_TEST_) {
2210 if (DEBUG_v_TEST_) {
2211 PerlIO_printf(Perl_debug_log, "\n");
2219 if (DEBUG_t_TEST_) debop(PL_op);
2220 if (DEBUG_P_TEST_) debprof(PL_op);
2223 OP_ENTRY_PROBE(OP_NAME(PL_op));
2224 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2225 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2233 /* print the names of the n lexical vars starting at pad offset off */
2236 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2239 CV * const cv = deb_curcv(cxstack_ix);
2240 PADNAMELIST *comppad = NULL;
2244 PADLIST * const padlist = CvPADLIST(cv);
2245 comppad = PadlistNAMES(padlist);
2248 PerlIO_printf(Perl_debug_log, "(");
2249 for (i = 0; i < n; i++) {
2250 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2251 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2253 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2256 PerlIO_printf(Perl_debug_log, ",");
2259 PerlIO_printf(Perl_debug_log, ")");
2263 /* append to the out SV, the name of the lexical at offset off in the CV
2267 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2268 bool paren, bool is_scalar)
2271 PADNAMELIST *namepad = NULL;
2275 PADLIST * const padlist = CvPADLIST(cv);
2276 namepad = PadlistNAMES(padlist);
2280 sv_catpvs_nomg(out, "(");
2281 for (i = 0; i < n; i++) {
2282 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2284 STRLEN cur = SvCUR(out);
2285 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2286 UTF8fARG(1, PadnameLEN(sv) - 1,
2287 PadnamePV(sv) + 1));
2289 SvPVX(out)[cur] = '$';
2292 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2294 sv_catpvs_nomg(out, ",");
2297 sv_catpvs_nomg(out, "(");
2302 S_append_gv_name(pTHX_ GV *gv, SV *out)
2306 sv_catpvs_nomg(out, "<NULLGV>");
2310 gv_fullname4(sv, gv, NULL, FALSE);
2311 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2312 SvREFCNT_dec_NN(sv);
2316 # define ITEM_SV(item) (comppad ? \
2317 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2319 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2323 /* return a temporary SV containing a stringified representation of
2324 * the op_aux field of a MULTIDEREF op, associated with CV cv
2328 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2330 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2331 UV actions = items->uv;
2334 bool is_hash = FALSE;
2336 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2341 PADLIST *padlist = CvPADLIST(cv);
2342 comppad = PadlistARRAY(padlist)[1];
2348 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2351 switch (actions & MDEREF_ACTION_MASK) {
2354 actions = (++items)->uv;
2356 NOT_REACHED; /* NOTREACHED */
2358 case MDEREF_HV_padhv_helem:
2361 case MDEREF_AV_padav_aelem:
2363 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2365 NOT_REACHED; /* NOTREACHED */
2367 case MDEREF_HV_gvhv_helem:
2370 case MDEREF_AV_gvav_aelem:
2373 sv = ITEM_SV(items);
2374 S_append_gv_name(aTHX_ (GV*)sv, out);
2376 NOT_REACHED; /* NOTREACHED */
2378 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2381 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2383 sv = ITEM_SV(items);
2384 S_append_gv_name(aTHX_ (GV*)sv, out);
2385 goto do_vivify_rv2xv_elem;
2386 NOT_REACHED; /* NOTREACHED */
2388 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2391 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2392 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2393 goto do_vivify_rv2xv_elem;
2394 NOT_REACHED; /* NOTREACHED */
2396 case MDEREF_HV_pop_rv2hv_helem:
2397 case MDEREF_HV_vivify_rv2hv_helem:
2400 do_vivify_rv2xv_elem:
2401 case MDEREF_AV_pop_rv2av_aelem:
2402 case MDEREF_AV_vivify_rv2av_aelem:
2404 sv_catpvs_nomg(out, "->");
2406 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2407 sv_catpvs_nomg(out, "->");
2412 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2413 switch (actions & MDEREF_INDEX_MASK) {
2414 case MDEREF_INDEX_const:
2417 sv = ITEM_SV(items);
2419 sv_catpvs_nomg(out, "???");
2424 pv_pretty(out, s, cur, 30,
2426 (PERL_PV_PRETTY_NOCLEAR
2427 |PERL_PV_PRETTY_QUOTE
2428 |PERL_PV_PRETTY_ELLIPSES));
2432 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2434 case MDEREF_INDEX_padsv:
2435 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2437 case MDEREF_INDEX_gvsv:
2439 sv = ITEM_SV(items);
2440 S_append_gv_name(aTHX_ (GV*)sv, out);
2443 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2445 if (actions & MDEREF_FLAG_last)
2452 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2453 (int)(actions & MDEREF_ACTION_MASK));
2459 actions >>= MDEREF_SHIFT;
2466 Perl_debop(pTHX_ const OP *o)
2468 PERL_ARGS_ASSERT_DEBOP;
2470 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2473 Perl_deb(aTHX_ "%s", OP_NAME(o));
2474 switch (o->op_type) {
2477 /* With ITHREADS, consts are stored in the pad, and the right pad
2478 * may not be active here, so check.
2479 * Looks like only during compiling the pads are illegal.
2482 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2484 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2488 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2489 SV * const sv = newSV(0);
2490 gv_fullname3(sv, cGVOPo_gv, NULL);
2491 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2492 SvREFCNT_dec_NN(sv);
2494 else if (cGVOPo_gv) {
2495 SV * const sv = newSV(0);
2496 assert(SvROK(cGVOPo_gv));
2497 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2498 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2499 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2500 SvREFCNT_dec_NN(sv);
2503 PerlIO_printf(Perl_debug_log, "(NULL)");
2509 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2513 S_deb_padvar(aTHX_ o->op_targ,
2514 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2518 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2519 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2525 PerlIO_printf(Perl_debug_log, "\n");
2530 S_deb_curcv(pTHX_ I32 ix)
2532 PERL_SI *si = PL_curstackinfo;
2533 for (; ix >=0; ix--) {
2534 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2536 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2537 return cx->blk_sub.cv;
2538 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2539 return cx->blk_eval.cv;
2540 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2542 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2543 && si->si_type == PERLSI_SORT)
2545 /* fake sort sub; use CV of caller */
2547 ix = si->si_cxix + 1;
2554 Perl_watch(pTHX_ char **addr)
2556 PERL_ARGS_ASSERT_WATCH;
2558 PL_watchaddr = addr;
2560 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2561 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2565 S_debprof(pTHX_ const OP *o)
2567 PERL_ARGS_ASSERT_DEBPROF;
2569 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2571 if (!PL_profiledata)
2572 Newxz(PL_profiledata, MAXO, U32);
2573 ++PL_profiledata[o->op_type];
2577 Perl_debprofdump(pTHX)
2580 if (!PL_profiledata)
2582 for (i = 0; i < MAXO; i++) {
2583 if (PL_profiledata[i])
2584 PerlIO_printf(Perl_debug_log,
2585 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2592 * ex: set ts=8 sts=4 sw=4 et: