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 "count" chars of pv and puts the results into
98 dsv such that the size of the escaped string will not exceed "max" chars
99 and will not contain any incomplete escape sequences. The number of bytes
100 escaped will be returned in the STRLEN *escaped parameter if it is not null.
101 When the 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 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 PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
110 If PERL_PV_ESCAPE_UNI is set then the input string is treated as UTF-8
111 if 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 PERL_PV_ESCAPE_ALL is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if 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 PERL_PV_ESCAPE_NOBACKSLASH
120 then all chars below 255 will be treated as printable and
121 will be output as literals.
123 If 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 PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
130 not a '\\'. This is because regexes very often contain backslashed
131 sequences, whereas '%' is not a particularly common character in patterns.
133 Returns a pointer to the escaped text as held by 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 pv_escape() and supporting quoting and ellipses.
254 If the 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 PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
259 If the 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 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 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 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_lastsib) sv_catpvs(tmpsv, ",LASTSIB");
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 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.c"
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 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 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 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 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_CANY_SEEN, "CANY_SEEN,"},
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))) {
1558 #ifdef PERL_OLD_COPY_ON_WRITE
1562 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1564 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1565 #ifdef PERL_OLD_COPY_ON_WRITE
1566 if (SvIsCOW_shared_hash(sv))
1567 PerlIO_printf(file, " (HASH)");
1568 else if (SvIsCOW_normal(sv))
1569 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1571 PerlIO_putc(file, '\n');
1574 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1575 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1576 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1577 || type == SVt_NV) {
1578 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1579 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1580 RESTORE_LC_NUMERIC_UNDERLYING();
1584 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1586 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1589 if (type < SVt_PV) {
1594 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1595 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1596 const bool re = isREGEXP(sv);
1597 const char * const ptr =
1598 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1602 SvOOK_offset(sv, delta);
1603 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1608 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1610 PerlIO_printf(file, "( %s . ) ",
1611 pv_display(d, ptr - delta, delta, 0,
1614 if (type == SVt_INVLIST) {
1615 PerlIO_printf(file, "\n");
1616 /* 4 blanks indents 2 beyond the PV, etc */
1617 _invlist_dump(file, level, " ", sv);
1620 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1623 if (SvUTF8(sv)) /* the 6? \x{....} */
1624 PerlIO_printf(file, " [UTF8 \"%s\"]",
1625 sv_uni_display(d, sv, 6 * SvCUR(sv),
1627 PerlIO_printf(file, "\n");
1629 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1631 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1633 #ifdef PERL_NEW_COPY_ON_WRITE
1634 if (SvIsCOW(sv) && SvLEN(sv))
1635 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1640 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1643 if (type >= SVt_PVMG) {
1645 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1647 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1649 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1650 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1654 /* Dump type-specific SV fields */
1658 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1659 if (AvARRAY(sv) != AvALLOC(sv)) {
1660 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1661 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1664 PerlIO_putc(file, '\n');
1665 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1666 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1667 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1668 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1670 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1671 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1672 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1673 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1674 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1676 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1677 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1679 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1681 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1688 struct xpvhv_aux *const aux = HvAUX(sv);
1689 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1690 (UV)aux->xhv_aux_flags);
1692 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1693 usedkeys = HvUSEDKEYS(sv);
1694 if (HvARRAY(sv) && usedkeys) {
1695 /* Show distribution of HEs in the ARRAY */
1697 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1700 U32 pow2 = 2, keys = usedkeys;
1701 NV theoret, sum = 0;
1703 PerlIO_printf(file, " (");
1704 Zero(freq, FREQ_MAX + 1, int);
1705 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1708 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1710 if (count > FREQ_MAX)
1716 for (i = 0; i <= max; i++) {
1718 PerlIO_printf(file, "%d%s:%d", i,
1719 (i == FREQ_MAX) ? "+" : "",
1722 PerlIO_printf(file, ", ");
1725 PerlIO_putc(file, ')');
1726 /* The "quality" of a hash is defined as the total number of
1727 comparisons needed to access every element once, relative
1728 to the expected number needed for a random hash.
1730 The total number of comparisons is equal to the sum of
1731 the squares of the number of entries in each bucket.
1732 For a random hash of n keys into k buckets, the expected
1737 for (i = max; i > 0; i--) { /* Precision: count down. */
1738 sum += freq[i] * i * i;
1740 while ((keys = keys >> 1))
1743 theoret += theoret * (theoret-1)/pow2;
1744 PerlIO_putc(file, '\n');
1745 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1747 PerlIO_putc(file, '\n');
1748 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1751 HE **ents = HvARRAY(sv);
1754 HE *const *const last = ents + HvMAX(sv);
1755 count = last + 1 - ents;
1760 } while (++ents <= last);
1764 struct xpvhv_aux *const aux = HvAUX(sv);
1765 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1766 " (cached = %"UVuf")\n",
1767 (UV)count, (UV)aux->xhv_fill_lazy);
1769 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1773 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1775 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1776 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1777 #ifdef PERL_HASH_RANDOMIZE_KEYS
1778 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1779 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1780 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1783 PerlIO_putc(file, '\n');
1786 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1787 if (mg && mg->mg_obj) {
1788 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1792 const char * const hvname = HvNAME_get(sv);
1794 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1795 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1796 generic_pv_escape( tmpsv, hvname,
1797 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1802 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1803 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1804 if (HvAUX(sv)->xhv_name_count)
1805 Perl_dump_indent(aTHX_
1806 level, file, " NAMECOUNT = %"IVdf"\n",
1807 (IV)HvAUX(sv)->xhv_name_count
1809 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1810 const I32 count = HvAUX(sv)->xhv_name_count;
1812 SV * const names = newSVpvs_flags("", SVs_TEMP);
1813 /* The starting point is the first element if count is
1814 positive and the second element if count is negative. */
1815 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1816 + (count < 0 ? 1 : 0);
1817 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1818 + (count < 0 ? -count : count);
1819 while (hekp < endp) {
1820 if (HEK_LEN(*hekp)) {
1821 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1822 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1823 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1825 /* This should never happen. */
1826 sv_catpvs(names, ", (null)");
1830 Perl_dump_indent(aTHX_
1831 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1835 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1836 const char *const hvename = HvENAME_get(sv);
1837 Perl_dump_indent(aTHX_
1838 level, file, " ENAME = \"%s\"\n",
1839 generic_pv_escape(tmp, hvename,
1840 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1844 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1846 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1850 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1851 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1852 generic_pv_escape( tmpsv, meta->mro_which->name,
1853 meta->mro_which->length,
1854 (meta->mro_which->kflags & HVhek_UTF8)),
1855 PTR2UV(meta->mro_which));
1856 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1857 (UV)meta->cache_gen);
1858 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1860 if (meta->mro_linear_all) {
1861 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1862 PTR2UV(meta->mro_linear_all));
1863 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1866 if (meta->mro_linear_current) {
1867 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1868 PTR2UV(meta->mro_linear_current));
1869 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1872 if (meta->mro_nextmethod) {
1873 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1874 PTR2UV(meta->mro_nextmethod));
1875 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1879 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1881 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1886 if (nest < maxnest) {
1887 HV * const hv = MUTABLE_HV(sv);
1892 int count = maxnest - nest;
1893 for (i=0; i <= HvMAX(hv); i++) {
1894 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1901 if (count-- <= 0) goto DONEHV;
1904 keysv = hv_iterkeysv(he);
1905 keypv = SvPV_const(keysv, len);
1908 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1910 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1911 if (HvEITER_get(hv) == he)
1912 PerlIO_printf(file, "[CURRENT] ");
1913 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1914 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1921 } /* case SVt_PVHV */
1924 if (CvAUTOLOAD(sv)) {
1925 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1927 const char *const name = SvPV_const(sv, len);
1928 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1929 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1932 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1933 const char *const proto = CvPROTO(sv);
1934 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1935 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1940 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1941 if (!CvISXSUB(sv)) {
1943 Perl_dump_indent(aTHX_ level, file,
1944 " START = 0x%"UVxf" ===> %"IVdf"\n",
1945 PTR2UV(CvSTART(sv)),
1946 (IV)sequence_num(CvSTART(sv)));
1948 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1949 PTR2UV(CvROOT(sv)));
1950 if (CvROOT(sv) && dumpops) {
1951 do_op_dump(level+1, file, CvROOT(sv));
1954 SV * const constant = cv_const_sv((const CV *)sv);
1956 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1959 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1961 PTR2UV(CvXSUBANY(sv).any_ptr));
1962 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1965 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1966 (IV)CvXSUBANY(sv).any_i32);
1970 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1971 HEK_KEY(CvNAME_HEK((CV *)sv)));
1972 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1973 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1974 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1975 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1976 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1977 if (!CvISXSUB(sv)) {
1978 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1979 if (nest < maxnest) {
1980 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1984 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
1986 const CV * const outside = CvOUTSIDE(sv);
1987 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1990 : CvANON(outside) ? "ANON"
1991 : (outside == PL_main_cv) ? "MAIN"
1992 : CvUNIQUE(outside) ? "UNIQUE"
1995 newSVpvs_flags("", SVs_TEMP),
1996 GvNAME(CvGV(outside)),
1997 GvNAMELEN(CvGV(outside)),
1998 GvNAMEUTF8(CvGV(outside)))
2002 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2003 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2008 if (type == SVt_PVLV) {
2009 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2010 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2011 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2013 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2014 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2015 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2018 if (isREGEXP(sv)) goto dumpregexp;
2019 if (!isGV_with_GP(sv))
2022 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2023 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2024 generic_pv_escape(tmpsv, GvNAME(sv),
2028 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2029 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2030 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2031 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2036 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2042 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2045 GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2046 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2047 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2048 do_gv_dump (level, file, " EGV", GvEGV(sv));
2051 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2052 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2055 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2056 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2057 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2059 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2060 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2061 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2063 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2064 PTR2UV(IoTOP_GV(sv)));
2065 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2066 maxnest, dumpops, pvlim);
2068 /* Source filters hide things that are not GVs in these three, so let's
2069 be careful out there. */
2071 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2072 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2073 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2075 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2076 PTR2UV(IoFMT_GV(sv)));
2077 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2078 maxnest, dumpops, pvlim);
2080 if (IoBOTTOM_NAME(sv))
2081 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2082 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2083 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2085 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2086 PTR2UV(IoBOTTOM_GV(sv)));
2087 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2088 maxnest, dumpops, pvlim);
2090 if (isPRINT(IoTYPE(sv)))
2091 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2093 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2094 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2099 struct regexp * const r = ReANY((REGEXP*)sv);
2101 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2103 append_flags(d, flags, names); \
2104 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2105 SvCUR_set(d, SvCUR(d) - 1); \
2106 SvPVX(d)[SvCUR(d)] = '\0'; \
2109 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2110 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2111 (UV)(r->compflags), SvPVX_const(d));
2113 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2114 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2115 (UV)(r->extflags), SvPVX_const(d));
2117 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2118 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2119 if (r->engine == &PL_core_reg_engine) {
2120 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2121 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2122 (UV)(r->intflags), SvPVX_const(d));
2124 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2127 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2128 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2130 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2131 (UV)(r->lastparen));
2132 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2133 (UV)(r->lastcloseparen));
2134 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2136 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2137 (IV)(r->minlenret));
2138 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2140 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2141 (UV)(r->pre_prefix));
2142 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2144 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2145 (IV)(r->suboffset));
2146 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2147 (IV)(r->subcoffset));
2149 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2151 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2153 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2154 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2155 PTR2UV(r->mother_re));
2156 if (nest < maxnest && r->mother_re)
2157 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2158 maxnest, dumpops, pvlim);
2159 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2160 PTR2UV(r->paren_names));
2161 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2162 PTR2UV(r->substrs));
2163 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2164 PTR2UV(r->pprivate));
2165 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2167 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2168 PTR2UV(r->qr_anoncv));
2170 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2171 PTR2UV(r->saved_copy));
2182 Dumps the contents of an SV to the C<STDERR> filehandle.
2184 For an example of its output, see L<Devel::Peek>.
2190 Perl_sv_dump(pTHX_ SV *sv)
2192 PERL_ARGS_ASSERT_SV_DUMP;
2195 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2197 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2201 Perl_runops_debug(pTHX)
2204 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2208 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2210 #ifdef PERL_TRACE_OPS
2211 ++PL_op_exec_cnt[PL_op->op_type];
2214 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2215 PerlIO_printf(Perl_debug_log,
2216 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2217 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2218 PTR2UV(*PL_watchaddr));
2219 if (DEBUG_s_TEST_) {
2220 if (DEBUG_v_TEST_) {
2221 PerlIO_printf(Perl_debug_log, "\n");
2229 if (DEBUG_t_TEST_) debop(PL_op);
2230 if (DEBUG_P_TEST_) debprof(PL_op);
2233 OP_ENTRY_PROBE(OP_NAME(PL_op));
2234 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2235 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2243 /* print the names of the n lexical vars starting at pad offset off */
2246 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2249 CV * const cv = deb_curcv(cxstack_ix);
2250 PADNAMELIST *comppad = NULL;
2254 PADLIST * const padlist = CvPADLIST(cv);
2255 comppad = PadlistNAMES(padlist);
2258 PerlIO_printf(Perl_debug_log, "(");
2259 for (i = 0; i < n; i++) {
2260 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2261 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2263 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2266 PerlIO_printf(Perl_debug_log, ",");
2269 PerlIO_printf(Perl_debug_log, ")");
2273 /* append to the out SV, the name of the lexical at offset off in the CV
2277 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2278 bool paren, bool is_scalar)
2281 PADNAMELIST *namepad = NULL;
2285 PADLIST * const padlist = CvPADLIST(cv);
2286 namepad = PadlistNAMES(padlist);
2290 sv_catpvs_nomg(out, "(");
2291 for (i = 0; i < n; i++) {
2292 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2294 STRLEN cur = SvCUR(out);
2295 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2296 UTF8fARG(1, PadnameLEN(sv) - 1,
2297 PadnamePV(sv) + 1));
2299 SvPVX(out)[cur] = '$';
2302 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2304 sv_catpvs_nomg(out, ",");
2307 sv_catpvs_nomg(out, "(");
2312 S_append_gv_name(pTHX_ GV *gv, SV *out)
2316 sv_catpvs_nomg(out, "<NULLGV>");
2320 gv_fullname4(sv, gv, NULL, FALSE);
2321 Perl_sv_catpvf(aTHX_ out, "%c%-p", '$', sv);
2322 SvREFCNT_dec_NN(sv);
2326 # define ITEM_SV(item) (comppad ? \
2327 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2329 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2333 /* return a temporary SV containing a stringified representation of
2334 * the op_aux field of a MULTIDEREF op, associated with CV cv
2338 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2340 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2341 UV actions = items->uv;
2344 bool is_hash = FALSE;
2346 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2351 PADLIST *padlist = CvPADLIST(cv);
2352 comppad = PadlistARRAY(padlist)[1];
2358 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2361 switch (actions & MDEREF_ACTION_MASK) {
2364 actions = (++items)->uv;
2366 NOT_REACHED; /* NOTREACHED */
2368 case MDEREF_HV_padhv_helem:
2371 case MDEREF_AV_padav_aelem:
2373 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2375 NOT_REACHED; /* NOTREACHED */
2377 case MDEREF_HV_gvhv_helem:
2380 case MDEREF_AV_gvav_aelem:
2383 sv = ITEM_SV(items);
2384 S_append_gv_name(aTHX_ (GV*)sv, out);
2386 NOT_REACHED; /* NOTREACHED */
2388 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2391 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2393 sv = ITEM_SV(items);
2394 S_append_gv_name(aTHX_ (GV*)sv, out);
2395 goto do_vivify_rv2xv_elem;
2396 NOT_REACHED; /* NOTREACHED */
2398 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2401 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2402 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2403 goto do_vivify_rv2xv_elem;
2404 NOT_REACHED; /* NOTREACHED */
2406 case MDEREF_HV_pop_rv2hv_helem:
2407 case MDEREF_HV_vivify_rv2hv_helem:
2410 do_vivify_rv2xv_elem:
2411 case MDEREF_AV_pop_rv2av_aelem:
2412 case MDEREF_AV_vivify_rv2av_aelem:
2414 sv_catpvs_nomg(out, "->");
2416 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2417 sv_catpvs_nomg(out, "->");
2422 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2423 switch (actions & MDEREF_INDEX_MASK) {
2424 case MDEREF_INDEX_const:
2427 sv = ITEM_SV(items);
2429 sv_catpvs_nomg(out, "???");
2434 pv_pretty(out, s, cur, 30,
2436 (PERL_PV_PRETTY_NOCLEAR
2437 |PERL_PV_PRETTY_QUOTE
2438 |PERL_PV_PRETTY_ELLIPSES));
2442 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2444 case MDEREF_INDEX_padsv:
2445 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2447 case MDEREF_INDEX_gvsv:
2449 sv = ITEM_SV(items);
2450 S_append_gv_name(aTHX_ (GV*)sv, out);
2453 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2455 if (actions & MDEREF_FLAG_last)
2462 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2463 (int)(actions & MDEREF_ACTION_MASK));
2469 actions >>= MDEREF_SHIFT;
2476 Perl_debop(pTHX_ const OP *o)
2478 PERL_ARGS_ASSERT_DEBOP;
2480 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2483 Perl_deb(aTHX_ "%s", OP_NAME(o));
2484 switch (o->op_type) {
2487 /* With ITHREADS, consts are stored in the pad, and the right pad
2488 * may not be active here, so check.
2489 * Looks like only during compiling the pads are illegal.
2492 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2494 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2498 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2499 SV * const sv = newSV(0);
2500 gv_fullname3(sv, cGVOPo_gv, NULL);
2501 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2502 SvREFCNT_dec_NN(sv);
2504 else if (cGVOPo_gv) {
2505 SV * const sv = newSV(0);
2506 assert(SvROK(cGVOPo_gv));
2507 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2508 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2509 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2510 SvREFCNT_dec_NN(sv);
2513 PerlIO_printf(Perl_debug_log, "(NULL)");
2519 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2523 S_deb_padvar(aTHX_ o->op_targ,
2524 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2528 PerlIO_printf(Perl_debug_log, "(%-p)",
2529 multideref_stringify(o, deb_curcv(cxstack_ix)));
2535 PerlIO_printf(Perl_debug_log, "\n");
2540 S_deb_curcv(pTHX_ I32 ix)
2542 PERL_SI *si = PL_curstackinfo;
2543 for (; ix >=0; ix--) {
2544 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2546 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2547 return cx->blk_sub.cv;
2548 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2549 return cx->blk_eval.cv;
2550 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2552 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2553 && si->si_type == PERLSI_SORT)
2555 /* fake sort sub; use CV of caller */
2557 ix = si->si_cxix + 1;
2564 Perl_watch(pTHX_ char **addr)
2566 PERL_ARGS_ASSERT_WATCH;
2568 PL_watchaddr = addr;
2570 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2571 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2575 S_debprof(pTHX_ const OP *o)
2577 PERL_ARGS_ASSERT_DEBPROF;
2579 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2581 if (!PL_profiledata)
2582 Newxz(PL_profiledata, MAXO, U32);
2583 ++PL_profiledata[o->op_type];
2587 Perl_debprofdump(pTHX)
2590 if (!PL_profiledata)
2592 for (i = 0; i < MAXO; i++) {
2593 if (PL_profiledata[i])
2594 PerlIO_printf(Perl_debug_log,
2595 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2603 * c-indentation-style: bsd
2605 * indent-tabs-mode: nil
2608 * ex: set ts=8 sts=4 sw=4 et: