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 (is_tmp || SvREFCNT(sv) > 1) {
425 Perl_sv_catpvf(aTHX_ t, "<");
426 if (SvREFCNT(sv) > 1)
427 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
429 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
430 Perl_sv_catpvf(aTHX_ t, ">");
436 if (SvCUR(t) + unref > 10) {
437 SvCUR_set(t, unref + 3);
446 if (type == SVt_PVCV) {
447 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
449 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
450 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
453 } else if (type < SVt_LAST) {
454 sv_catpv(t, svshorttypenames[type]);
456 if (type == SVt_NULL)
459 sv_catpv(t, "FREED");
464 if (!SvPVX_const(sv))
465 sv_catpv(t, "(null)");
467 SV * const tmp = newSVpvs("");
471 SvOOK_offset(sv, delta);
472 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
474 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
476 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
477 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
479 SvREFCNT_dec_NN(tmp);
482 else if (SvNOKp(sv)) {
483 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
484 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
485 RESTORE_LC_NUMERIC_UNDERLYING();
487 else if (SvIOKp(sv)) {
489 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
491 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
499 if (TAINTING_get && sv && SvTAINTED(sv))
500 sv_catpv(t, " [tainted]");
501 return SvPV_nolen(t);
505 =head1 Debugging Utilities
509 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
512 PERL_ARGS_ASSERT_DUMP_INDENT;
514 dump_vindent(level, file, pat, &args);
519 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
521 PERL_ARGS_ASSERT_DUMP_VINDENT;
522 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
523 PerlIO_vprintf(file, pat, *args);
529 Dumps the entire optree of the current program starting at C<PL_main_root> to
530 C<STDERR>. Also dumps the optrees for all visible subroutines in
539 dump_all_perl(FALSE);
543 Perl_dump_all_perl(pTHX_ bool justperl)
545 PerlIO_setlinebuf(Perl_debug_log);
547 op_dump(PL_main_root);
548 dump_packsubs_perl(PL_defstash, justperl);
552 =for apidoc dump_packsubs
554 Dumps the optrees for all visible subroutines in C<stash>.
560 Perl_dump_packsubs(pTHX_ const HV *stash)
562 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
563 dump_packsubs_perl(stash, FALSE);
567 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
571 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
575 for (i = 0; i <= (I32) HvMAX(stash); i++) {
577 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
578 GV * gv = (GV *)HeVAL(entry);
579 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
580 /* unfake a fake GV */
581 (void)CvGV(SvRV(gv));
582 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
585 dump_sub_perl(gv, justperl);
588 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
589 const HV * const hv = GvHV(gv);
590 if (hv && (hv != PL_defstash))
591 dump_packsubs_perl(hv, justperl); /* nested package */
598 Perl_dump_sub(pTHX_ const GV *gv)
600 PERL_ARGS_ASSERT_DUMP_SUB;
601 dump_sub_perl(gv, FALSE);
605 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
608 SV * const sv = newSVpvs_flags("", SVs_TEMP);
612 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
614 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
617 tmpsv = newSVpvs_flags("", SVs_TEMP);
618 gv_fullname3(sv, gv, NULL);
619 name = SvPV_const(sv, len);
620 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
621 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
622 if (CvISXSUB(GvCV(gv)))
623 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
624 PTR2UV(CvXSUB(GvCV(gv))),
625 (int)CvXSUBANY(GvCV(gv)).any_i32);
626 else if (CvROOT(GvCV(gv)))
627 op_dump(CvROOT(GvCV(gv)));
629 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
633 Perl_dump_form(pTHX_ const GV *gv)
635 SV * const sv = sv_newmortal();
637 PERL_ARGS_ASSERT_DUMP_FORM;
639 gv_fullname3(sv, gv, NULL);
640 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
641 if (CvROOT(GvFORM(gv)))
642 op_dump(CvROOT(GvFORM(gv)));
644 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
650 op_dump(PL_eval_root);
654 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
658 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
662 if (pm->op_pmflags & PMf_ONCE)
667 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c\n",
668 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
670 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
672 if (pm->op_type == OP_SPLIT)
673 Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%" UVxf "\n",
674 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
676 if (pm->op_pmreplrootu.op_pmreplroot) {
677 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
678 op_dump(pm->op_pmreplrootu.op_pmreplroot);
682 if (pm->op_code_list) {
683 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
684 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
685 do_op_dump(level, file, pm->op_code_list);
688 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%" UVxf "\n",
689 PTR2UV(pm->op_code_list));
691 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
692 SV * const tmpsv = pm_description(pm);
693 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
694 SvREFCNT_dec_NN(tmpsv);
698 const struct flag_to_name pmflags_flags_names[] = {
699 {PMf_CONST, ",CONST"},
701 {PMf_GLOBAL, ",GLOBAL"},
702 {PMf_CONTINUE, ",CONTINUE"},
703 {PMf_RETAINT, ",RETAINT"},
705 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
706 {PMf_HAS_CV, ",HAS_CV"},
707 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
708 {PMf_IS_QR, ",IS_QR"}
712 S_pm_description(pTHX_ const PMOP *pm)
714 SV * const desc = newSVpvs("");
715 const REGEXP * const regex = PM_GETRE(pm);
716 const U32 pmflags = pm->op_pmflags;
718 PERL_ARGS_ASSERT_PM_DESCRIPTION;
720 if (pmflags & PMf_ONCE)
721 sv_catpv(desc, ",ONCE");
723 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
724 sv_catpv(desc, ":USED");
726 if (pmflags & PMf_USED)
727 sv_catpv(desc, ":USED");
731 if (RX_ISTAINTED(regex))
732 sv_catpv(desc, ",TAINTED");
733 if (RX_CHECK_SUBSTR(regex)) {
734 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
735 sv_catpv(desc, ",SCANFIRST");
736 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
737 sv_catpv(desc, ",ALL");
739 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
740 sv_catpv(desc, ",SKIPWHITE");
743 append_flags(desc, pmflags, pmflags_flags_names);
748 Perl_pmop_dump(pTHX_ PMOP *pm)
750 do_pmop_dump(0, Perl_debug_log, pm);
753 /* Return a unique integer to represent the address of op o.
754 * If it already exists in PL_op_sequence, just return it;
756 * *** Note that this isn't thread-safe */
759 S_sequence_num(pTHX_ const OP *o)
768 op = newSVuv(PTR2UV(o));
770 key = SvPV_const(op, len);
772 PL_op_sequence = newHV();
773 seq = hv_fetch(PL_op_sequence, key, len, 0);
776 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
784 const struct flag_to_name op_flags_names[] = {
786 {OPf_PARENS, ",PARENS"},
789 {OPf_STACKED, ",STACKED"},
790 {OPf_SPECIAL, ",SPECIAL"}
795 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
798 const OPCODE optype = o->op_type;
800 PERL_ARGS_ASSERT_DO_OP_DUMP;
802 Perl_dump_indent(aTHX_ level, file, "{\n");
804 seq = sequence_num(o);
806 PerlIO_printf(file, "%-4" UVuf, seq);
808 PerlIO_printf(file, "????");
810 "%*sTYPE = %s ===> ",
811 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
814 o->op_type == OP_NULL ? "(%" UVuf ")\n" : "%" UVuf "\n",
815 sequence_num(o->op_next));
817 PerlIO_printf(file, "NULL\n");
819 if (optype == OP_NULL) {
820 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
823 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
826 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%" UVxf " => 0x%" UVxf "\n",
827 (UV)o, (UV)o->op_next);
830 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
831 SV * const tmpsv = newSVpvs("");
832 switch (o->op_flags & OPf_WANT) {
834 sv_catpv(tmpsv, ",VOID");
836 case OPf_WANT_SCALAR:
837 sv_catpv(tmpsv, ",SCALAR");
840 sv_catpv(tmpsv, ",LIST");
843 sv_catpv(tmpsv, ",UNKNOWN");
846 append_flags(tmpsv, o->op_flags, op_flags_names);
847 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
848 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
849 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
850 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
851 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
852 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
853 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
857 U16 oppriv = o->op_private;
858 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
863 tmpsv = newSVpvs("");
864 for (; !stop; op_ix++) {
865 U16 entry = PL_op_private_bitdefs[op_ix];
866 U16 bit = (entry >> 2) & 7;
873 I16 const *p = &PL_op_private_bitfields[ix];
874 U16 bitmin = (U16) *p++;
881 for (i = bitmin; i<= bit; i++)
884 val = (oppriv & mask);
887 && PL_op_private_labels[label] == '-'
888 && PL_op_private_labels[label+1] == '\0'
890 /* display as raw number */
903 if (val == 0 && enum_label == -1)
904 /* don't display anonymous zero values */
907 sv_catpv(tmpsv, ",");
909 sv_catpv(tmpsv, &PL_op_private_labels[label]);
910 sv_catpv(tmpsv, "=");
912 if (enum_label == -1)
913 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
915 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
920 if ( oppriv & (1<<bit)
921 && !(PL_op_private_labels[ix] == '-'
922 && PL_op_private_labels[ix+1] == '\0'))
925 sv_catpv(tmpsv, ",");
926 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
931 sv_catpv(tmpsv, ",");
932 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
935 if (tmpsv && SvCUR(tmpsv)) {
936 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
938 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%" UVxf ")\n",
947 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
949 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
953 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
954 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
955 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
956 name = SvPV_const(tmpsv, len);
957 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
958 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
961 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
968 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
969 UV i, count = items[-1].uv;
971 Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
972 for (i=0; i < count; i++)
973 Perl_dump_indent(aTHX_ level+1, file, "%" UVuf " => 0x%" UVxf "\n",
980 case OP_METHOD_NAMED:
981 case OP_METHOD_SUPER:
982 case OP_METHOD_REDIR:
983 case OP_METHOD_REDIR_SUPER:
985 /* with ITHREADS, consts are stored in the pad, and the right pad
986 * may not be active here, so skip */
987 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
991 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
997 Perl_dump_indent(aTHX_ level, file, "LINE = %" UVuf "\n",
999 if (CopSTASHPV(cCOPo)) {
1000 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1001 HV *stash = CopSTASH(cCOPo);
1002 const char * const hvname = HvNAME_get(stash);
1004 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1005 generic_pv_escape(tmpsv, hvname,
1006 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1008 if (CopLABEL(cCOPo)) {
1009 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1012 const char *label = CopLABEL_len_flags(cCOPo,
1013 &label_len, &label_flags);
1014 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1015 generic_pv_escape( tmpsv, label, label_len,
1016 (label_flags & SVf_UTF8)));
1018 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1019 (unsigned int)cCOPo->cop_seq);
1022 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1023 if (cLOOPo->op_redoop)
1024 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_redoop));
1026 PerlIO_printf(file, "DONE\n");
1027 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1028 if (cLOOPo->op_nextop)
1029 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_nextop));
1031 PerlIO_printf(file, "DONE\n");
1032 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1033 if (cLOOPo->op_lastop)
1034 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_lastop));
1036 PerlIO_printf(file, "DONE\n");
1044 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1045 if (cLOGOPo->op_other)
1046 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOGOPo->op_other));
1048 PerlIO_printf(file, "DONE\n");
1054 do_pmop_dump(level, file, cPMOPo);
1062 if (o->op_private & OPpREFCOUNTED)
1063 Perl_dump_indent(aTHX_ level, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1068 if (o->op_flags & OPf_KIDS) {
1070 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1071 do_op_dump(level, file, kid);
1073 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1079 Dumps the optree starting at OP C<o> to C<STDERR>.
1085 Perl_op_dump(pTHX_ const OP *o)
1087 PERL_ARGS_ASSERT_OP_DUMP;
1088 do_op_dump(0, Perl_debug_log, o);
1092 Perl_gv_dump(pTHX_ GV *gv)
1096 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1099 PerlIO_printf(Perl_debug_log, "{}\n");
1102 sv = sv_newmortal();
1103 PerlIO_printf(Perl_debug_log, "{\n");
1104 gv_fullname3(sv, gv, NULL);
1105 name = SvPV_const(sv, len);
1106 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1107 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1108 if (gv != GvEGV(gv)) {
1109 gv_efullname3(sv, GvEGV(gv), NULL);
1110 name = SvPV_const(sv, len);
1111 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1112 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1114 (void)PerlIO_putc(Perl_debug_log, '\n');
1115 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1119 /* map magic types to the symbolic names
1120 * (with the PERL_MAGIC_ prefixed stripped)
1123 static const struct { const char type; const char *name; } magic_names[] = {
1124 #include "mg_names.inc"
1125 /* this null string terminates the list */
1130 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1132 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1134 for (; mg; mg = mg->mg_moremagic) {
1135 Perl_dump_indent(aTHX_ level, file,
1136 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1137 if (mg->mg_virtual) {
1138 const MGVTBL * const v = mg->mg_virtual;
1139 if (v >= PL_magic_vtables
1140 && v < PL_magic_vtables + magic_vtable_max) {
1141 const U32 i = v - PL_magic_vtables;
1142 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1145 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1146 UVxf "\n", PTR2UV(v));
1149 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1152 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1156 const char *name = NULL;
1157 for (n = 0; magic_names[n].name; n++) {
1158 if (mg->mg_type == magic_names[n].type) {
1159 name = magic_names[n].name;
1164 Perl_dump_indent(aTHX_ level, file,
1165 " MG_TYPE = PERL_MAGIC_%s\n", name);
1167 Perl_dump_indent(aTHX_ level, file,
1168 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1172 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1173 if (mg->mg_type == PERL_MAGIC_envelem &&
1174 mg->mg_flags & MGf_TAINTEDDIR)
1175 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1176 if (mg->mg_type == PERL_MAGIC_regex_global &&
1177 mg->mg_flags & MGf_MINMATCH)
1178 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1179 if (mg->mg_flags & MGf_REFCOUNTED)
1180 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1181 if (mg->mg_flags & MGf_GSKIP)
1182 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1183 if (mg->mg_flags & MGf_COPY)
1184 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1185 if (mg->mg_flags & MGf_DUP)
1186 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1187 if (mg->mg_flags & MGf_LOCAL)
1188 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1189 if (mg->mg_type == PERL_MAGIC_regex_global &&
1190 mg->mg_flags & MGf_BYTES)
1191 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1194 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1195 PTR2UV(mg->mg_obj));
1196 if (mg->mg_type == PERL_MAGIC_qr) {
1197 REGEXP* const re = (REGEXP *)mg->mg_obj;
1198 SV * const dsv = sv_newmortal();
1199 const char * const s
1200 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1202 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1203 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1205 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1206 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1209 if (mg->mg_flags & MGf_REFCOUNTED)
1210 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1213 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1215 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1216 if (mg->mg_len >= 0) {
1217 if (mg->mg_type != PERL_MAGIC_utf8) {
1218 SV * const sv = newSVpvs("");
1219 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1220 SvREFCNT_dec_NN(sv);
1223 else if (mg->mg_len == HEf_SVKEY) {
1224 PerlIO_puts(file, " => HEf_SVKEY\n");
1225 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1226 maxnest, dumpops, pvlim); /* MG is already +1 */
1229 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1234 " does not know how to handle this MG_LEN"
1236 (void)PerlIO_putc(file, '\n');
1238 if (mg->mg_type == PERL_MAGIC_utf8) {
1239 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1242 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1243 Perl_dump_indent(aTHX_ level, file,
1244 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1247 (UV)cache[i * 2 + 1]);
1254 Perl_magic_dump(pTHX_ const MAGIC *mg)
1256 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1260 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1264 PERL_ARGS_ASSERT_DO_HV_DUMP;
1266 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1267 if (sv && (hvname = HvNAME_get(sv)))
1269 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1270 name which quite legally could contain insane things like tabs, newlines, nulls or
1271 other scary crap - this should produce sane results - except maybe for unicode package
1272 names - but we will wait for someone to file a bug on that - demerphq */
1273 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1274 PerlIO_printf(file, "\t\"%s\"\n",
1275 generic_pv_escape( tmpsv, hvname,
1276 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1279 (void)PerlIO_putc(file, '\n');
1283 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1285 PERL_ARGS_ASSERT_DO_GV_DUMP;
1287 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1288 if (sv && GvNAME(sv)) {
1289 SV * const tmpsv = newSVpvs("");
1290 PerlIO_printf(file, "\t\"%s\"\n",
1291 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1294 (void)PerlIO_putc(file, '\n');
1298 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1300 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1302 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1303 if (sv && GvNAME(sv)) {
1304 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1306 HV * const stash = GvSTASH(sv);
1307 PerlIO_printf(file, "\t");
1308 /* TODO might have an extra \" here */
1309 if (stash && (hvname = HvNAME_get(stash))) {
1310 PerlIO_printf(file, "\"%s\" :: \"",
1311 generic_pv_escape(tmp, hvname,
1312 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1314 PerlIO_printf(file, "%s\"\n",
1315 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1318 (void)PerlIO_putc(file, '\n');
1321 const struct flag_to_name first_sv_flags_names[] = {
1322 {SVs_TEMP, "TEMP,"},
1323 {SVs_OBJECT, "OBJECT,"},
1332 const struct flag_to_name second_sv_flags_names[] = {
1334 {SVf_FAKE, "FAKE,"},
1335 {SVf_READONLY, "READONLY,"},
1336 {SVf_PROTECT, "PROTECT,"},
1337 {SVf_BREAK, "BREAK,"},
1343 const struct flag_to_name cv_flags_names[] = {
1344 {CVf_ANON, "ANON,"},
1345 {CVf_UNIQUE, "UNIQUE,"},
1346 {CVf_CLONE, "CLONE,"},
1347 {CVf_CLONED, "CLONED,"},
1348 {CVf_CONST, "CONST,"},
1349 {CVf_NODEBUG, "NODEBUG,"},
1350 {CVf_LVALUE, "LVALUE,"},
1351 {CVf_METHOD, "METHOD,"},
1352 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1353 {CVf_CVGV_RC, "CVGV_RC,"},
1354 {CVf_DYNFILE, "DYNFILE,"},
1355 {CVf_AUTOLOAD, "AUTOLOAD,"},
1356 {CVf_HASEVAL, "HASEVAL,"},
1357 {CVf_SLABBED, "SLABBED,"},
1358 {CVf_NAMED, "NAMED,"},
1359 {CVf_LEXICAL, "LEXICAL,"},
1360 {CVf_ISXSUB, "ISXSUB,"}
1363 const struct flag_to_name hv_flags_names[] = {
1364 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1365 {SVphv_LAZYDEL, "LAZYDEL,"},
1366 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1367 {SVf_AMAGIC, "OVERLOAD,"},
1368 {SVphv_CLONEABLE, "CLONEABLE,"}
1371 const struct flag_to_name gp_flags_names[] = {
1372 {GVf_INTRO, "INTRO,"},
1373 {GVf_MULTI, "MULTI,"},
1374 {GVf_ASSUMECV, "ASSUMECV,"},
1377 const struct flag_to_name gp_flags_imported_names[] = {
1378 {GVf_IMPORTED_SV, " SV"},
1379 {GVf_IMPORTED_AV, " AV"},
1380 {GVf_IMPORTED_HV, " HV"},
1381 {GVf_IMPORTED_CV, " CV"},
1384 /* NOTE: this structure is mostly duplicative of one generated by
1385 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1386 * the two. - Yves */
1387 const struct flag_to_name regexp_extflags_names[] = {
1388 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1389 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1390 {RXf_PMf_FOLD, "PMf_FOLD,"},
1391 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1392 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1393 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1394 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1395 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1396 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1397 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1398 {RXf_CHECK_ALL, "CHECK_ALL,"},
1399 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1400 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1401 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1402 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1403 {RXf_SPLIT, "SPLIT,"},
1404 {RXf_COPY_DONE, "COPY_DONE,"},
1405 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1406 {RXf_TAINTED, "TAINTED,"},
1407 {RXf_START_ONLY, "START_ONLY,"},
1408 {RXf_SKIPWHITE, "SKIPWHITE,"},
1409 {RXf_WHITE, "WHITE,"},
1410 {RXf_NULL, "NULL,"},
1413 /* NOTE: this structure is mostly duplicative of one generated by
1414 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1415 * the two. - Yves */
1416 const struct flag_to_name regexp_core_intflags_names[] = {
1417 {PREGf_SKIP, "SKIP,"},
1418 {PREGf_IMPLICIT, "IMPLICIT,"},
1419 {PREGf_NAUGHTY, "NAUGHTY,"},
1420 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1421 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1422 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1423 {PREGf_NOSCAN, "NOSCAN,"},
1424 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1425 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1426 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1427 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1428 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1431 /* Perl_do_sv_dump():
1433 * level: amount to indent the output
1434 * sv: the object to dump
1435 * nest: the current level of recursion
1436 * maxnest: the maximum allowed level of recursion
1437 * dumpops: if true, also dump the ops associated with a CV
1438 * pvlim: limit on the length of any strings that are output
1442 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1449 PERL_ARGS_ASSERT_DO_SV_DUMP;
1452 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1456 flags = SvFLAGS(sv);
1459 /* process general SV flags */
1461 d = Perl_newSVpvf(aTHX_
1462 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1463 PTR2UV(SvANY(sv)), PTR2UV(sv),
1464 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1465 (int)(PL_dumpindent*level), "");
1467 if ((flags & SVs_PADSTALE))
1468 sv_catpv(d, "PADSTALE,");
1469 if ((flags & SVs_PADTMP))
1470 sv_catpv(d, "PADTMP,");
1471 append_flags(d, flags, first_sv_flags_names);
1472 if (flags & SVf_ROK) {
1473 sv_catpv(d, "ROK,");
1474 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1476 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1477 append_flags(d, flags, second_sv_flags_names);
1478 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1479 && type != SVt_PVAV) {
1480 if (SvPCS_IMPORTED(sv))
1481 sv_catpv(d, "PCS_IMPORTED,");
1483 sv_catpv(d, "SCREAM,");
1486 /* process type-specific SV flags */
1491 append_flags(d, CvFLAGS(sv), cv_flags_names);
1494 append_flags(d, flags, hv_flags_names);
1498 if (isGV_with_GP(sv)) {
1499 append_flags(d, GvFLAGS(sv), gp_flags_names);
1501 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1502 sv_catpv(d, "IMPORT");
1503 if (GvIMPORTED(sv) == GVf_IMPORTED)
1504 sv_catpv(d, "ALL,");
1507 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1514 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1520 /* SVphv_SHAREKEYS is also 0x20000000 */
1521 if ((type != SVt_PVHV) && SvUTF8(sv))
1522 sv_catpv(d, "UTF8");
1524 if (*(SvEND(d) - 1) == ',') {
1525 SvCUR_set(d, SvCUR(d) - 1);
1526 SvPVX(d)[SvCUR(d)] = '\0';
1531 /* dump initial SV details */
1533 #ifdef DEBUG_LEAKING_SCALARS
1534 Perl_dump_indent(aTHX_ level, file,
1535 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1536 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1538 sv->sv_debug_inpad ? "for" : "by",
1539 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1540 PTR2UV(sv->sv_debug_parent),
1544 Perl_dump_indent(aTHX_ level, file, "SV = ");
1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551 if (type == SVt_NULL) {
1556 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1561 /* Dump general SV fields */
1563 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1564 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1565 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1566 || (type == SVt_IV && !SvROK(sv))) {
1569 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1571 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1572 (void)PerlIO_putc(file, '\n');
1575 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1576 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1577 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1578 || type == SVt_NV) {
1579 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1580 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1581 RESTORE_LC_NUMERIC_UNDERLYING();
1585 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1588 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1591 if (type < SVt_PV) {
1596 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1597 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1598 const bool re = isREGEXP(sv);
1599 const char * const ptr =
1600 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1604 SvOOK_offset(sv, delta);
1605 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1610 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1613 PerlIO_printf(file, "( %s . ) ",
1614 pv_display(d, ptr - delta, delta, 0,
1617 if (type == SVt_INVLIST) {
1618 PerlIO_printf(file, "\n");
1619 /* 4 blanks indents 2 beyond the PV, etc */
1620 _invlist_dump(file, level, " ", sv);
1623 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1626 if (SvUTF8(sv)) /* the 6? \x{....} */
1627 PerlIO_printf(file, " [UTF8 \"%s\"]",
1628 sv_uni_display(d, sv, 6 * SvCUR(sv),
1630 PerlIO_printf(file, "\n");
1632 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1634 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1636 #ifdef PERL_COPY_ON_WRITE
1637 if (SvIsCOW(sv) && SvLEN(sv))
1638 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1643 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1646 if (type >= SVt_PVMG) {
1648 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1650 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1652 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1653 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1658 /* Dump type-specific SV fields */
1662 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1663 PTR2UV(AvARRAY(sv)));
1664 if (AvARRAY(sv) != AvALLOC(sv)) {
1665 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1666 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1667 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1668 PTR2UV(AvALLOC(sv)));
1671 (void)PerlIO_putc(file, '\n');
1672 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1674 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1677 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1678 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1679 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1680 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1681 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1683 SV **svp = AvARRAY(MUTABLE_AV(sv));
1685 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1688 SV* const elt = *svp;
1689 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1691 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1698 struct xpvhv_aux *const aux = HvAUX(sv);
1699 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1700 (UV)aux->xhv_aux_flags);
1702 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1703 usedkeys = HvUSEDKEYS(sv);
1704 if (HvARRAY(sv) && usedkeys) {
1705 /* Show distribution of HEs in the ARRAY */
1707 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1710 U32 pow2 = 2, keys = usedkeys;
1711 NV theoret, sum = 0;
1713 PerlIO_printf(file, " (");
1714 Zero(freq, FREQ_MAX + 1, int);
1715 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1718 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1720 if (count > FREQ_MAX)
1726 for (i = 0; i <= max; i++) {
1728 PerlIO_printf(file, "%d%s:%d", i,
1729 (i == FREQ_MAX) ? "+" : "",
1732 PerlIO_printf(file, ", ");
1735 (void)PerlIO_putc(file, ')');
1736 /* The "quality" of a hash is defined as the total number of
1737 comparisons needed to access every element once, relative
1738 to the expected number needed for a random hash.
1740 The total number of comparisons is equal to the sum of
1741 the squares of the number of entries in each bucket.
1742 For a random hash of n keys into k buckets, the expected
1747 for (i = max; i > 0; i--) { /* Precision: count down. */
1748 sum += freq[i] * i * i;
1750 while ((keys = keys >> 1))
1753 theoret += theoret * (theoret-1)/pow2;
1754 (void)PerlIO_putc(file, '\n');
1755 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
1756 NVff "%%", theoret/sum*100);
1758 (void)PerlIO_putc(file, '\n');
1759 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
1763 HE **ents = HvARRAY(sv);
1766 HE *const *const last = ents + HvMAX(sv);
1767 count = last + 1 - ents;
1772 } while (++ents <= last);
1775 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
1778 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1781 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
1782 (IV)HvRITER_get(sv));
1783 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
1784 PTR2UV(HvEITER_get(sv)));
1785 #ifdef PERL_HASH_RANDOMIZE_KEYS
1786 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
1787 (UV)HvRAND_get(sv));
1788 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1789 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1790 (UV)HvLASTRAND_get(sv));
1793 (void)PerlIO_putc(file, '\n');
1796 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1797 if (mg && mg->mg_obj) {
1798 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
1802 const char * const hvname = HvNAME_get(sv);
1804 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1805 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1806 generic_pv_escape( tmpsv, hvname,
1807 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1812 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1813 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1814 if (HvAUX(sv)->xhv_name_count)
1815 Perl_dump_indent(aTHX_
1816 level, file, " NAMECOUNT = %" IVdf "\n",
1817 (IV)HvAUX(sv)->xhv_name_count
1819 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1820 const I32 count = HvAUX(sv)->xhv_name_count;
1822 SV * const names = newSVpvs_flags("", SVs_TEMP);
1823 /* The starting point is the first element if count is
1824 positive and the second element if count is negative. */
1825 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1826 + (count < 0 ? 1 : 0);
1827 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1828 + (count < 0 ? -count : count);
1829 while (hekp < endp) {
1831 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1832 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1833 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1835 /* This should never happen. */
1836 sv_catpvs(names, ", (null)");
1840 Perl_dump_indent(aTHX_
1841 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1845 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1846 const char *const hvename = HvENAME_get(sv);
1847 Perl_dump_indent(aTHX_
1848 level, file, " ENAME = \"%s\"\n",
1849 generic_pv_escape(tmp, hvename,
1850 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1854 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
1856 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1860 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1861 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
1863 generic_pv_escape( tmpsv, meta->mro_which->name,
1864 meta->mro_which->length,
1865 (meta->mro_which->kflags & HVhek_UTF8)),
1866 PTR2UV(meta->mro_which));
1867 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
1869 (UV)meta->cache_gen);
1870 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
1872 if (meta->mro_linear_all) {
1873 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
1875 PTR2UV(meta->mro_linear_all));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1879 if (meta->mro_linear_current) {
1880 Perl_dump_indent(aTHX_ level, file,
1881 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
1882 PTR2UV(meta->mro_linear_current));
1883 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1886 if (meta->mro_nextmethod) {
1887 Perl_dump_indent(aTHX_ level, file,
1888 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
1889 PTR2UV(meta->mro_nextmethod));
1890 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1894 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
1896 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1901 if (nest < maxnest) {
1902 HV * const hv = MUTABLE_HV(sv);
1907 int count = maxnest - nest;
1908 for (i=0; i <= HvMAX(hv); i++) {
1909 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1916 if (count-- <= 0) goto DONEHV;
1919 keysv = hv_iterkeysv(he);
1920 keypv = SvPV_const(keysv, len);
1923 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1925 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1926 if (HvEITER_get(hv) == he)
1927 PerlIO_printf(file, "[CURRENT] ");
1928 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
1929 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1936 } /* case SVt_PVHV */
1939 if (CvAUTOLOAD(sv)) {
1940 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1942 const char *const name = SvPV_const(sv, len);
1943 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1944 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1947 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1948 const char *const proto = CvPROTO(sv);
1949 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1950 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1955 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1956 if (!CvISXSUB(sv)) {
1959 Perl_dump_indent(aTHX_ level, file,
1960 " SLAB = 0x%" UVxf "\n",
1961 PTR2UV(CvSTART(sv)));
1963 Perl_dump_indent(aTHX_ level, file,
1964 " START = 0x%" UVxf " ===> %" IVdf "\n",
1965 PTR2UV(CvSTART(sv)),
1966 (IV)sequence_num(CvSTART(sv)));
1968 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
1969 PTR2UV(CvROOT(sv)));
1970 if (CvROOT(sv) && dumpops) {
1971 do_op_dump(level+1, file, CvROOT(sv));
1974 SV * const constant = cv_const_sv((const CV *)sv);
1976 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
1979 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
1981 PTR2UV(CvXSUBANY(sv).any_ptr));
1982 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1985 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
1986 (IV)CvXSUBANY(sv).any_i32);
1990 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1991 HEK_KEY(CvNAME_HEK((CV *)sv)));
1992 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1993 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1994 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
1995 IVdf "\n", (IV)CvDEPTH(sv));
1996 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
1998 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
1999 if (!CvISXSUB(sv)) {
2000 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2001 if (nest < maxnest) {
2002 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2006 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2008 const CV * const outside = CvOUTSIDE(sv);
2009 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2012 : CvANON(outside) ? "ANON"
2013 : (outside == PL_main_cv) ? "MAIN"
2014 : CvUNIQUE(outside) ? "UNIQUE"
2017 newSVpvs_flags("", SVs_TEMP),
2018 GvNAME(CvGV(outside)),
2019 GvNAMELEN(CvGV(outside)),
2020 GvNAMEUTF8(CvGV(outside)))
2024 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2025 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2030 if (type == SVt_PVLV) {
2031 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2032 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2033 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2034 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2036 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2037 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2040 if (isREGEXP(sv)) goto dumpregexp;
2041 if (!isGV_with_GP(sv))
2044 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2045 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2046 generic_pv_escape(tmpsv, GvNAME(sv),
2050 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2051 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2052 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2053 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2056 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2057 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2058 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2059 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2060 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2061 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2062 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2063 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2064 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2068 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2069 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2070 do_gv_dump (level, file, " EGV", GvEGV(sv));
2073 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2074 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2075 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2076 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2077 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2078 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2079 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2081 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2082 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2083 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2085 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2086 PTR2UV(IoTOP_GV(sv)));
2087 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2088 maxnest, dumpops, pvlim);
2090 /* Source filters hide things that are not GVs in these three, so let's
2091 be careful out there. */
2093 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2094 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2095 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2097 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2098 PTR2UV(IoFMT_GV(sv)));
2099 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2100 maxnest, dumpops, pvlim);
2102 if (IoBOTTOM_NAME(sv))
2103 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2104 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2105 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2107 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2108 PTR2UV(IoBOTTOM_GV(sv)));
2109 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2110 maxnest, dumpops, pvlim);
2112 if (isPRINT(IoTYPE(sv)))
2113 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2115 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2116 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2121 struct regexp * const r = ReANY((REGEXP*)sv);
2123 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2125 append_flags(d, flags, names); \
2126 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2127 SvCUR_set(d, SvCUR(d) - 1); \
2128 SvPVX(d)[SvCUR(d)] = '\0'; \
2131 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2132 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2133 (UV)(r->compflags), SvPVX_const(d));
2135 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2136 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2137 (UV)(r->extflags), SvPVX_const(d));
2139 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2140 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2141 if (r->engine == &PL_core_reg_engine) {
2142 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2143 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2144 (UV)(r->intflags), SvPVX_const(d));
2146 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2149 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2150 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2152 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2153 (UV)(r->lastparen));
2154 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2155 (UV)(r->lastcloseparen));
2156 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2158 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2159 (IV)(r->minlenret));
2160 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2162 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2163 (UV)(r->pre_prefix));
2164 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2166 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2167 (IV)(r->suboffset));
2168 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2169 (IV)(r->subcoffset));
2171 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2173 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2175 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2176 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2177 PTR2UV(r->mother_re));
2178 if (nest < maxnest && r->mother_re)
2179 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2180 maxnest, dumpops, pvlim);
2181 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2182 PTR2UV(r->paren_names));
2183 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2184 PTR2UV(r->substrs));
2185 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2186 PTR2UV(r->pprivate));
2187 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2189 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2190 PTR2UV(r->qr_anoncv));
2192 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2193 PTR2UV(r->saved_copy));
2204 Dumps the contents of an SV to the C<STDERR> filehandle.
2206 For an example of its output, see L<Devel::Peek>.
2212 Perl_sv_dump(pTHX_ SV *sv)
2214 PERL_ARGS_ASSERT_SV_DUMP;
2217 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2219 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2223 Perl_runops_debug(pTHX)
2226 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2230 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2232 #ifdef PERL_TRACE_OPS
2233 ++PL_op_exec_cnt[PL_op->op_type];
2238 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2239 PerlIO_printf(Perl_debug_log,
2240 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2241 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2242 PTR2UV(*PL_watchaddr));
2243 if (DEBUG_s_TEST_) {
2244 if (DEBUG_v_TEST_) {
2245 PerlIO_printf(Perl_debug_log, "\n");
2253 if (DEBUG_t_TEST_) debop(PL_op);
2254 if (DEBUG_P_TEST_) debprof(PL_op);
2259 PERL_DTRACE_PROBE_OP(PL_op);
2260 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2261 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2269 /* print the names of the n lexical vars starting at pad offset off */
2272 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2275 CV * const cv = deb_curcv(cxstack_ix);
2276 PADNAMELIST *comppad = NULL;
2280 PADLIST * const padlist = CvPADLIST(cv);
2281 comppad = PadlistNAMES(padlist);
2284 PerlIO_printf(Perl_debug_log, "(");
2285 for (i = 0; i < n; i++) {
2286 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2287 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2289 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2292 PerlIO_printf(Perl_debug_log, ",");
2295 PerlIO_printf(Perl_debug_log, ")");
2299 /* append to the out SV, the name of the lexical at offset off in the CV
2303 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2304 bool paren, bool is_scalar)
2307 PADNAMELIST *namepad = NULL;
2311 PADLIST * const padlist = CvPADLIST(cv);
2312 namepad = PadlistNAMES(padlist);
2316 sv_catpvs_nomg(out, "(");
2317 for (i = 0; i < n; i++) {
2318 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2320 STRLEN cur = SvCUR(out);
2321 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2322 UTF8fARG(1, PadnameLEN(sv) - 1,
2323 PadnamePV(sv) + 1));
2325 SvPVX(out)[cur] = '$';
2328 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2330 sv_catpvs_nomg(out, ",");
2333 sv_catpvs_nomg(out, "(");
2338 S_append_gv_name(pTHX_ GV *gv, SV *out)
2342 sv_catpvs_nomg(out, "<NULLGV>");
2346 gv_fullname4(sv, gv, NULL, FALSE);
2347 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2348 SvREFCNT_dec_NN(sv);
2352 # define ITEM_SV(item) (comppad ? \
2353 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2355 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2359 /* return a temporary SV containing a stringified representation of
2360 * the op_aux field of a MULTIDEREF op, associated with CV cv
2364 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2366 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2367 UV actions = items->uv;
2370 bool is_hash = FALSE;
2372 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2377 PADLIST *padlist = CvPADLIST(cv);
2378 comppad = PadlistARRAY(padlist)[1];
2384 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2387 switch (actions & MDEREF_ACTION_MASK) {
2390 actions = (++items)->uv;
2392 NOT_REACHED; /* NOTREACHED */
2394 case MDEREF_HV_padhv_helem:
2397 case MDEREF_AV_padav_aelem:
2399 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2401 NOT_REACHED; /* NOTREACHED */
2403 case MDEREF_HV_gvhv_helem:
2406 case MDEREF_AV_gvav_aelem:
2409 sv = ITEM_SV(items);
2410 S_append_gv_name(aTHX_ (GV*)sv, out);
2412 NOT_REACHED; /* NOTREACHED */
2414 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2417 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2419 sv = ITEM_SV(items);
2420 S_append_gv_name(aTHX_ (GV*)sv, out);
2421 goto do_vivify_rv2xv_elem;
2422 NOT_REACHED; /* NOTREACHED */
2424 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2427 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2428 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2429 goto do_vivify_rv2xv_elem;
2430 NOT_REACHED; /* NOTREACHED */
2432 case MDEREF_HV_pop_rv2hv_helem:
2433 case MDEREF_HV_vivify_rv2hv_helem:
2436 do_vivify_rv2xv_elem:
2437 case MDEREF_AV_pop_rv2av_aelem:
2438 case MDEREF_AV_vivify_rv2av_aelem:
2440 sv_catpvs_nomg(out, "->");
2442 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2443 sv_catpvs_nomg(out, "->");
2448 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2449 switch (actions & MDEREF_INDEX_MASK) {
2450 case MDEREF_INDEX_const:
2453 sv = ITEM_SV(items);
2455 sv_catpvs_nomg(out, "???");
2460 pv_pretty(out, s, cur, 30,
2462 (PERL_PV_PRETTY_NOCLEAR
2463 |PERL_PV_PRETTY_QUOTE
2464 |PERL_PV_PRETTY_ELLIPSES));
2468 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2470 case MDEREF_INDEX_padsv:
2471 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2473 case MDEREF_INDEX_gvsv:
2475 sv = ITEM_SV(items);
2476 S_append_gv_name(aTHX_ (GV*)sv, out);
2479 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2481 if (actions & MDEREF_FLAG_last)
2488 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2489 (int)(actions & MDEREF_ACTION_MASK));
2495 actions >>= MDEREF_SHIFT;
2502 Perl_debop(pTHX_ const OP *o)
2504 PERL_ARGS_ASSERT_DEBOP;
2506 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2509 Perl_deb(aTHX_ "%s", OP_NAME(o));
2510 switch (o->op_type) {
2513 /* With ITHREADS, consts are stored in the pad, and the right pad
2514 * may not be active here, so check.
2515 * Looks like only during compiling the pads are illegal.
2518 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2520 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2524 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2525 SV * const sv = newSV(0);
2526 gv_fullname3(sv, cGVOPo_gv, NULL);
2527 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2528 SvREFCNT_dec_NN(sv);
2530 else if (cGVOPo_gv) {
2531 SV * const sv = newSV(0);
2532 assert(SvROK(cGVOPo_gv));
2533 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2534 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2535 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2536 SvREFCNT_dec_NN(sv);
2539 PerlIO_printf(Perl_debug_log, "(NULL)");
2546 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2550 S_deb_padvar(aTHX_ o->op_targ,
2551 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2555 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2556 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2562 PerlIO_printf(Perl_debug_log, "\n");
2567 S_deb_curcv(pTHX_ I32 ix)
2569 PERL_SI *si = PL_curstackinfo;
2570 for (; ix >=0; ix--) {
2571 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2573 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2574 return cx->blk_sub.cv;
2575 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2576 return cx->blk_eval.cv;
2577 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2579 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2580 && si->si_type == PERLSI_SORT)
2582 /* fake sort sub; use CV of caller */
2584 ix = si->si_cxix + 1;
2591 Perl_watch(pTHX_ char **addr)
2593 PERL_ARGS_ASSERT_WATCH;
2595 PL_watchaddr = addr;
2597 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
2598 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2602 S_debprof(pTHX_ const OP *o)
2604 PERL_ARGS_ASSERT_DEBPROF;
2606 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2608 if (!PL_profiledata)
2609 Newxz(PL_profiledata, MAXO, U32);
2610 ++PL_profiledata[o->op_type];
2614 Perl_debprofdump(pTHX)
2617 if (!PL_profiledata)
2619 for (i = 0; i < MAXO; i++) {
2620 if (PL_profiledata[i])
2621 PerlIO_printf(Perl_debug_log,
2622 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2629 * ex: set ts=8 sts=4 sw=4 et: