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.
101 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
102 will also be escaped.
104 Normally the SV will be cleared before the escaped string is prepared,
105 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
107 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
108 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
109 using C<is_utf8_string()> to determine if it is Unicode.
111 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
112 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
113 non-ASCII chars will be escaped using this style; otherwise, only chars above
114 255 will be so escaped; other non printable chars will use octal or
115 common escaped patterns like C<\n>.
116 Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
117 then all chars below 255 will be treated as printable and
118 will be output as literals.
120 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
121 string will be escaped, regardless of max. If the output is to be in hex,
122 then it will be returned as a plain hex
123 sequence. Thus the output will either be a single char,
124 an octal escape sequence, a special escape like C<\n> or a hex value.
126 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
127 not a '\\'. This is because regexes very often contain backslashed
128 sequences, whereas '%' is not a particularly common character in patterns.
130 Returns a pointer to the escaped text as held by dsv.
134 #define PV_ESCAPE_OCTBUFSIZE 32
137 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
138 const STRLEN count, const STRLEN max,
139 STRLEN * const escaped, const U32 flags )
141 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
142 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
143 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
144 STRLEN wrote = 0; /* chars written so far */
145 STRLEN chsize = 0; /* size of data to be written */
146 STRLEN readsize = 1; /* size of data just read */
147 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
148 const char *pv = str;
149 const char * const end = pv + count; /* end of string */
152 PERL_ARGS_ASSERT_PV_ESCAPE;
154 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
155 /* This won't alter the UTF-8 flag */
159 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
162 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
163 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
164 const U8 c = (U8)u & 0xFF;
167 || (flags & PERL_PV_ESCAPE_ALL)
168 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
170 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
171 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
174 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
175 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
177 : "%cx{%02"UVxf"}", esc, u);
179 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
182 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
186 case '\\' : /* FALLTHROUGH */
187 case '%' : if ( c == esc ) {
193 case '\v' : octbuf[1] = 'v'; break;
194 case '\t' : octbuf[1] = 't'; break;
195 case '\r' : octbuf[1] = 'r'; break;
196 case '\n' : octbuf[1] = 'n'; break;
197 case '\f' : octbuf[1] = 'f'; break;
205 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
206 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
207 isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
210 else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
211 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
221 if ( max && (wrote + chsize > max) ) {
223 } else if (chsize > 1) {
224 sv_catpvn(dsv, octbuf, chsize);
227 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
228 can be appended raw to the dsv. If dsv happens to be
229 UTF-8 then we need catpvf to upgrade them for us.
230 Or add a new API call sv_catpvc(). Think about that name, and
231 how to keep it clear that it's unlike the s of catpvs, which is
232 really an array of octets, not a string. */
233 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
236 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
244 =for apidoc pv_pretty
246 Converts a string into something presentable, handling escaping via
247 pv_escape() and supporting quoting and ellipses.
249 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
250 double quoted with any double quotes in the string escaped. Otherwise
251 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
254 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
255 string were output then an ellipsis C<...> will be appended to the
256 string. Note that this happens AFTER it has been quoted.
258 If start_color is non-null then it will be inserted after the opening
259 quote (if there is one) but before the escaped text. If end_color
260 is non-null then it will be inserted after the escaped text but before
261 any quotes or ellipses.
263 Returns a pointer to the prettified text as held by dsv.
269 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
270 const STRLEN max, char const * const start_color, char const * const end_color,
273 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
276 PERL_ARGS_ASSERT_PV_PRETTY;
278 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
279 /* This won't alter the UTF-8 flag */
284 sv_catpvs(dsv, "\"");
285 else if ( flags & PERL_PV_PRETTY_LTGT )
288 if ( start_color != NULL )
289 sv_catpv(dsv, start_color);
291 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
293 if ( end_color != NULL )
294 sv_catpv(dsv, end_color);
297 sv_catpvs( dsv, "\"");
298 else if ( flags & PERL_PV_PRETTY_LTGT )
301 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
302 sv_catpvs(dsv, "...");
308 =for apidoc pv_display
312 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
314 except that an additional "\0" will be appended to the string when
315 len > cur and pv[cur] is "\0".
317 Note that the final string may be up to 7 chars longer than pvlim.
323 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
325 PERL_ARGS_ASSERT_PV_DISPLAY;
327 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
328 if (len > cur && pv[cur] == '\0')
329 sv_catpvs( dsv, "\\0");
334 Perl_sv_peek(pTHX_ SV *sv)
337 SV * const t = sv_newmortal();
347 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
348 /* detect data corruption under memory poisoning */
352 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
353 if (sv == &PL_sv_undef) {
354 sv_catpv(t, "SV_UNDEF");
355 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
356 SVs_GMG|SVs_SMG|SVs_RMG)) &&
360 else if (sv == &PL_sv_no) {
361 sv_catpv(t, "SV_NO");
362 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
363 SVs_GMG|SVs_SMG|SVs_RMG)) &&
364 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
370 else if (sv == &PL_sv_yes) {
371 sv_catpv(t, "SV_YES");
372 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
373 SVs_GMG|SVs_SMG|SVs_RMG)) &&
374 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
377 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
382 sv_catpv(t, "SV_PLACEHOLDER");
383 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
384 SVs_GMG|SVs_SMG|SVs_RMG)) &&
390 else if (SvREFCNT(sv) == 0) {
394 else if (DEBUG_R_TEST_) {
397 /* is this SV on the tmps stack? */
398 for (ix=PL_tmps_ix; ix>=0; ix--) {
399 if (PL_tmps_stack[ix] == sv) {
404 if (SvREFCNT(sv) > 1)
405 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
413 if (SvCUR(t) + unref > 10) {
414 SvCUR_set(t, unref + 3);
423 if (type == SVt_PVCV) {
424 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
426 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
427 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
430 } else if (type < SVt_LAST) {
431 sv_catpv(t, svshorttypenames[type]);
433 if (type == SVt_NULL)
436 sv_catpv(t, "FREED");
441 if (!SvPVX_const(sv))
442 sv_catpv(t, "(null)");
444 SV * const tmp = newSVpvs("");
448 SvOOK_offset(sv, delta);
449 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
451 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
453 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
454 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
456 SvREFCNT_dec_NN(tmp);
459 else if (SvNOKp(sv)) {
460 STORE_NUMERIC_LOCAL_SET_STANDARD();
461 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
462 RESTORE_NUMERIC_LOCAL();
464 else if (SvIOKp(sv)) {
466 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
468 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
476 if (TAINTING_get && sv && SvTAINTED(sv))
477 sv_catpv(t, " [tainted]");
478 return SvPV_nolen(t);
482 =head1 Debugging Utilities
486 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
489 PERL_ARGS_ASSERT_DUMP_INDENT;
491 dump_vindent(level, file, pat, &args);
496 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
498 PERL_ARGS_ASSERT_DUMP_VINDENT;
499 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
500 PerlIO_vprintf(file, pat, *args);
506 Dumps the entire optree of the current program starting at C<PL_main_root> to
507 C<STDERR>. Also dumps the optrees for all visible subroutines in
516 dump_all_perl(FALSE);
520 Perl_dump_all_perl(pTHX_ bool justperl)
522 PerlIO_setlinebuf(Perl_debug_log);
524 op_dump(PL_main_root);
525 dump_packsubs_perl(PL_defstash, justperl);
529 =for apidoc dump_packsubs
531 Dumps the optrees for all visible subroutines in C<stash>.
537 Perl_dump_packsubs(pTHX_ const HV *stash)
539 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
540 dump_packsubs_perl(stash, FALSE);
544 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
548 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
552 for (i = 0; i <= (I32) HvMAX(stash); i++) {
554 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
555 const GV * const gv = (const GV *)HeVAL(entry);
556 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
559 dump_sub_perl(gv, justperl);
562 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
563 const HV * const hv = GvHV(gv);
564 if (hv && (hv != PL_defstash))
565 dump_packsubs_perl(hv, justperl); /* nested package */
572 Perl_dump_sub(pTHX_ const GV *gv)
574 PERL_ARGS_ASSERT_DUMP_SUB;
575 dump_sub_perl(gv, FALSE);
579 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
582 SV * const sv = newSVpvs_flags("", SVs_TEMP);
586 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
588 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
591 tmpsv = newSVpvs_flags("", SVs_TEMP);
592 gv_fullname3(sv, gv, NULL);
593 name = SvPV_const(sv, len);
594 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
595 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
596 if (CvISXSUB(GvCV(gv)))
597 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
598 PTR2UV(CvXSUB(GvCV(gv))),
599 (int)CvXSUBANY(GvCV(gv)).any_i32);
600 else if (CvROOT(GvCV(gv)))
601 op_dump(CvROOT(GvCV(gv)));
603 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
607 Perl_dump_form(pTHX_ const GV *gv)
609 SV * const sv = sv_newmortal();
611 PERL_ARGS_ASSERT_DUMP_FORM;
613 gv_fullname3(sv, gv, NULL);
614 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
615 if (CvROOT(GvFORM(gv)))
616 op_dump(CvROOT(GvFORM(gv)));
618 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
624 op_dump(PL_eval_root);
628 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
632 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
635 Perl_dump_indent(aTHX_ level, file, "{}\n");
638 Perl_dump_indent(aTHX_ level, file, "{\n");
640 if (pm->op_pmflags & PMf_ONCE)
645 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
646 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
647 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
649 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
650 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
651 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
652 op_dump(pm->op_pmreplrootu.op_pmreplroot);
654 if (pm->op_code_list) {
655 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
656 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
657 do_op_dump(level, file, pm->op_code_list);
660 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
661 PTR2UV(pm->op_code_list));
663 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
664 SV * const tmpsv = pm_description(pm);
665 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
666 SvREFCNT_dec_NN(tmpsv);
669 Perl_dump_indent(aTHX_ level-1, file, "}\n");
672 const struct flag_to_name pmflags_flags_names[] = {
673 {PMf_CONST, ",CONST"},
675 {PMf_GLOBAL, ",GLOBAL"},
676 {PMf_CONTINUE, ",CONTINUE"},
677 {PMf_RETAINT, ",RETAINT"},
679 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
680 {PMf_HAS_CV, ",HAS_CV"},
681 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
682 {PMf_IS_QR, ",IS_QR"}
686 S_pm_description(pTHX_ const PMOP *pm)
688 SV * const desc = newSVpvs("");
689 const REGEXP * const regex = PM_GETRE(pm);
690 const U32 pmflags = pm->op_pmflags;
692 PERL_ARGS_ASSERT_PM_DESCRIPTION;
694 if (pmflags & PMf_ONCE)
695 sv_catpv(desc, ",ONCE");
697 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
698 sv_catpv(desc, ":USED");
700 if (pmflags & PMf_USED)
701 sv_catpv(desc, ":USED");
705 if (RX_ISTAINTED(regex))
706 sv_catpv(desc, ",TAINTED");
707 if (RX_CHECK_SUBSTR(regex)) {
708 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
709 sv_catpv(desc, ",SCANFIRST");
710 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
711 sv_catpv(desc, ",ALL");
713 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
714 sv_catpv(desc, ",SKIPWHITE");
717 append_flags(desc, pmflags, pmflags_flags_names);
722 Perl_pmop_dump(pTHX_ PMOP *pm)
724 do_pmop_dump(0, Perl_debug_log, pm);
727 /* Return a unique integer to represent the address of op o.
728 * If it already exists in PL_op_sequence, just return it;
730 * *** Note that this isn't thread-safe */
733 S_sequence_num(pTHX_ const OP *o)
742 op = newSVuv(PTR2UV(o));
744 key = SvPV_const(op, len);
746 PL_op_sequence = newHV();
747 seq = hv_fetch(PL_op_sequence, key, len, 0);
750 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
758 const struct flag_to_name op_flags_names[] = {
760 {OPf_PARENS, ",PARENS"},
763 {OPf_STACKED, ",STACKED"},
764 {OPf_SPECIAL, ",SPECIAL"}
769 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
772 const OPCODE optype = o->op_type;
774 PERL_ARGS_ASSERT_DO_OP_DUMP;
776 Perl_dump_indent(aTHX_ level, file, "{\n");
778 seq = sequence_num(o);
780 PerlIO_printf(file, "%-4"UVuf, seq);
782 PerlIO_printf(file, "????");
784 "%*sTYPE = %s ===> ",
785 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
788 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
789 sequence_num(o->op_next));
791 PerlIO_printf(file, "NULL\n");
793 if (optype == OP_NULL) {
794 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
795 if (o->op_targ == OP_NEXTSTATE) {
797 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
799 if (CopSTASHPV(cCOPo)) {
800 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
801 HV *stash = CopSTASH(cCOPo);
802 const char * const hvname = HvNAME_get(stash);
804 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
805 generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
807 if (CopLABEL(cCOPo)) {
808 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
811 const char *label = CopLABEL_len_flags(cCOPo,
814 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
815 generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
821 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
824 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
827 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
828 SV * const tmpsv = newSVpvs("");
829 switch (o->op_flags & OPf_WANT) {
831 sv_catpv(tmpsv, ",VOID");
833 case OPf_WANT_SCALAR:
834 sv_catpv(tmpsv, ",SCALAR");
837 sv_catpv(tmpsv, ",LIST");
840 sv_catpv(tmpsv, ",UNKNOWN");
843 append_flags(tmpsv, o->op_flags, op_flags_names);
844 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
845 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
846 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
847 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
848 if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB");
849 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
850 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
854 U16 oppriv = o->op_private;
855 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
860 tmpsv = newSVpvs("");
861 for (; !stop; op_ix++) {
862 U16 entry = PL_op_private_bitdefs[op_ix];
863 U16 bit = (entry >> 2) & 7;
870 I16 const *p = &PL_op_private_bitfields[ix];
871 U16 bitmin = (U16) *p++;
878 for (i = bitmin; i<= bit; i++)
881 val = (oppriv & mask);
884 && PL_op_private_labels[label] == '-'
885 && PL_op_private_labels[label+1] == '\0'
887 /* display as raw number */
900 if (val == 0 && enum_label == -1)
901 /* don't display anonymous zero values */
904 sv_catpv(tmpsv, ",");
906 sv_catpv(tmpsv, &PL_op_private_labels[label]);
907 sv_catpv(tmpsv, "=");
909 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
914 if ( oppriv & (1<<bit)
915 && !(PL_op_private_labels[ix] == '-'
916 && PL_op_private_labels[ix+1] == '\0'))
919 sv_catpv(tmpsv, ",");
920 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
925 sv_catpv(tmpsv, ",");
926 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
929 if (tmpsv && SvCUR(tmpsv)) {
930 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
932 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
941 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
943 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
947 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
948 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
949 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
950 name = SvPV_const(tmpsv, len);
951 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
952 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
955 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
961 case OP_METHOD_NAMED:
963 /* with ITHREADS, consts are stored in the pad, and the right pad
964 * may not be active here, so skip */
965 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
971 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
973 if (CopSTASHPV(cCOPo)) {
974 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
975 HV *stash = CopSTASH(cCOPo);
976 const char * const hvname = HvNAME_get(stash);
978 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
979 generic_pv_escape(tmpsv, hvname,
980 HvNAMELEN(stash), HvNAMEUTF8(stash)));
982 if (CopLABEL(cCOPo)) {
983 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
986 const char *label = CopLABEL_len_flags(cCOPo,
987 &label_len, &label_flags);
988 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
989 generic_pv_escape( tmpsv, label, label_len,
990 (label_flags & SVf_UTF8)));
994 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
995 if (cLOOPo->op_redoop)
996 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
998 PerlIO_printf(file, "DONE\n");
999 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1000 if (cLOOPo->op_nextop)
1001 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1003 PerlIO_printf(file, "DONE\n");
1004 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1005 if (cLOOPo->op_lastop)
1006 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1008 PerlIO_printf(file, "DONE\n");
1016 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1017 if (cLOGOPo->op_other)
1018 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1020 PerlIO_printf(file, "DONE\n");
1026 do_pmop_dump(level, file, cPMOPo);
1034 if (o->op_private & OPpREFCOUNTED)
1035 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1040 if (o->op_flags & OPf_KIDS) {
1042 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1043 do_op_dump(level, file, kid);
1045 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1051 Dumps the optree starting at OP C<o> to C<STDERR>.
1057 Perl_op_dump(pTHX_ const OP *o)
1059 PERL_ARGS_ASSERT_OP_DUMP;
1060 do_op_dump(0, Perl_debug_log, o);
1064 Perl_gv_dump(pTHX_ GV *gv)
1068 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1071 PERL_ARGS_ASSERT_GV_DUMP;
1074 PerlIO_printf(Perl_debug_log, "{}\n");
1077 sv = sv_newmortal();
1078 PerlIO_printf(Perl_debug_log, "{\n");
1079 gv_fullname3(sv, gv, NULL);
1080 name = SvPV_const(sv, len);
1081 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1082 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1083 if (gv != GvEGV(gv)) {
1084 gv_efullname3(sv, GvEGV(gv), NULL);
1085 name = SvPV_const(sv, len);
1086 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1087 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1089 PerlIO_putc(Perl_debug_log, '\n');
1090 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1094 /* map magic types to the symbolic names
1095 * (with the PERL_MAGIC_ prefixed stripped)
1098 static const struct { const char type; const char *name; } magic_names[] = {
1099 #include "mg_names.c"
1100 /* this null string terminates the list */
1105 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1107 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1109 for (; mg; mg = mg->mg_moremagic) {
1110 Perl_dump_indent(aTHX_ level, file,
1111 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1112 if (mg->mg_virtual) {
1113 const MGVTBL * const v = mg->mg_virtual;
1114 if (v >= PL_magic_vtables
1115 && v < PL_magic_vtables + magic_vtable_max) {
1116 const U32 i = v - PL_magic_vtables;
1117 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1120 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1123 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1126 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1130 const char *name = NULL;
1131 for (n = 0; magic_names[n].name; n++) {
1132 if (mg->mg_type == magic_names[n].type) {
1133 name = magic_names[n].name;
1138 Perl_dump_indent(aTHX_ level, file,
1139 " MG_TYPE = PERL_MAGIC_%s\n", name);
1141 Perl_dump_indent(aTHX_ level, file,
1142 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1146 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1147 if (mg->mg_type == PERL_MAGIC_envelem &&
1148 mg->mg_flags & MGf_TAINTEDDIR)
1149 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1150 if (mg->mg_type == PERL_MAGIC_regex_global &&
1151 mg->mg_flags & MGf_MINMATCH)
1152 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1153 if (mg->mg_flags & MGf_REFCOUNTED)
1154 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1155 if (mg->mg_flags & MGf_GSKIP)
1156 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1157 if (mg->mg_flags & MGf_COPY)
1158 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1159 if (mg->mg_flags & MGf_DUP)
1160 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1161 if (mg->mg_flags & MGf_LOCAL)
1162 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1163 if (mg->mg_type == PERL_MAGIC_regex_global &&
1164 mg->mg_flags & MGf_BYTES)
1165 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1168 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1169 PTR2UV(mg->mg_obj));
1170 if (mg->mg_type == PERL_MAGIC_qr) {
1171 REGEXP* const re = (REGEXP *)mg->mg_obj;
1172 SV * const dsv = sv_newmortal();
1173 const char * const s
1174 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1176 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1177 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1179 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1180 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1183 if (mg->mg_flags & MGf_REFCOUNTED)
1184 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1187 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1189 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1190 if (mg->mg_len >= 0) {
1191 if (mg->mg_type != PERL_MAGIC_utf8) {
1192 SV * const sv = newSVpvs("");
1193 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1194 SvREFCNT_dec_NN(sv);
1197 else if (mg->mg_len == HEf_SVKEY) {
1198 PerlIO_puts(file, " => HEf_SVKEY\n");
1199 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1200 maxnest, dumpops, pvlim); /* MG is already +1 */
1203 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1208 " does not know how to handle this MG_LEN"
1210 PerlIO_putc(file, '\n');
1212 if (mg->mg_type == PERL_MAGIC_utf8) {
1213 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1216 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1217 Perl_dump_indent(aTHX_ level, file,
1218 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1221 (UV)cache[i * 2 + 1]);
1228 Perl_magic_dump(pTHX_ const MAGIC *mg)
1230 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1234 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1238 PERL_ARGS_ASSERT_DO_HV_DUMP;
1240 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1241 if (sv && (hvname = HvNAME_get(sv)))
1243 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1244 name which quite legally could contain insane things like tabs, newlines, nulls or
1245 other scary crap - this should produce sane results - except maybe for unicode package
1246 names - but we will wait for someone to file a bug on that - demerphq */
1247 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1248 PerlIO_printf(file, "\t\"%s\"\n",
1249 generic_pv_escape( tmpsv, hvname,
1250 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1253 PerlIO_putc(file, '\n');
1257 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1259 PERL_ARGS_ASSERT_DO_GV_DUMP;
1261 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1262 if (sv && GvNAME(sv)) {
1263 SV * const tmpsv = newSVpvs("");
1264 PerlIO_printf(file, "\t\"%s\"\n",
1265 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1268 PerlIO_putc(file, '\n');
1272 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1274 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1276 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1277 if (sv && GvNAME(sv)) {
1278 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1280 HV * const stash = GvSTASH(sv);
1281 PerlIO_printf(file, "\t");
1282 /* TODO might have an extra \" here */
1283 if (stash && (hvname = HvNAME_get(stash))) {
1284 PerlIO_printf(file, "\"%s\" :: \"",
1285 generic_pv_escape(tmp, hvname,
1286 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1288 PerlIO_printf(file, "%s\"\n",
1289 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1292 PerlIO_putc(file, '\n');
1295 const struct flag_to_name first_sv_flags_names[] = {
1296 {SVs_TEMP, "TEMP,"},
1297 {SVs_OBJECT, "OBJECT,"},
1306 const struct flag_to_name second_sv_flags_names[] = {
1308 {SVf_FAKE, "FAKE,"},
1309 {SVf_READONLY, "READONLY,"},
1310 {SVf_IsCOW, "IsCOW,"},
1311 {SVf_BREAK, "BREAK,"},
1312 {SVf_AMAGIC, "OVERLOAD,"},
1318 const struct flag_to_name cv_flags_names[] = {
1319 {CVf_ANON, "ANON,"},
1320 {CVf_UNIQUE, "UNIQUE,"},
1321 {CVf_CLONE, "CLONE,"},
1322 {CVf_CLONED, "CLONED,"},
1323 {CVf_CONST, "CONST,"},
1324 {CVf_NODEBUG, "NODEBUG,"},
1325 {CVf_LVALUE, "LVALUE,"},
1326 {CVf_METHOD, "METHOD,"},
1327 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1328 {CVf_CVGV_RC, "CVGV_RC,"},
1329 {CVf_DYNFILE, "DYNFILE,"},
1330 {CVf_AUTOLOAD, "AUTOLOAD,"},
1331 {CVf_HASEVAL, "HASEVAL,"},
1332 {CVf_SLABBED, "SLABBED,"},
1333 {CVf_NAMED, "NAMED,"},
1334 {CVf_LEXICAL, "LEXICAL,"},
1335 {CVf_ISXSUB, "ISXSUB,"}
1338 const struct flag_to_name hv_flags_names[] = {
1339 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1340 {SVphv_LAZYDEL, "LAZYDEL,"},
1341 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1342 {SVphv_CLONEABLE, "CLONEABLE,"}
1345 const struct flag_to_name gp_flags_names[] = {
1346 {GVf_INTRO, "INTRO,"},
1347 {GVf_MULTI, "MULTI,"},
1348 {GVf_ASSUMECV, "ASSUMECV,"},
1349 {GVf_IN_PAD, "IN_PAD,"}
1352 const struct flag_to_name gp_flags_imported_names[] = {
1353 {GVf_IMPORTED_SV, " SV"},
1354 {GVf_IMPORTED_AV, " AV"},
1355 {GVf_IMPORTED_HV, " HV"},
1356 {GVf_IMPORTED_CV, " CV"},
1359 /* NOTE: this structure is mostly duplicative of one generated by
1360 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1361 * the two. - Yves */
1362 const struct flag_to_name regexp_extflags_names[] = {
1363 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1364 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1365 {RXf_PMf_FOLD, "PMf_FOLD,"},
1366 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1367 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1368 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1369 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1370 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1371 {RXf_CHECK_ALL, "CHECK_ALL,"},
1372 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1373 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1374 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1375 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1376 {RXf_SPLIT, "SPLIT,"},
1377 {RXf_COPY_DONE, "COPY_DONE,"},
1378 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1379 {RXf_TAINTED, "TAINTED,"},
1380 {RXf_START_ONLY, "START_ONLY,"},
1381 {RXf_SKIPWHITE, "SKIPWHITE,"},
1382 {RXf_WHITE, "WHITE,"},
1383 {RXf_NULL, "NULL,"},
1386 /* NOTE: this structure is mostly duplicative of one generated by
1387 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1388 * the two. - Yves */
1389 const struct flag_to_name regexp_core_intflags_names[] = {
1390 {PREGf_SKIP, "SKIP,"},
1391 {PREGf_IMPLICIT, "IMPLICIT,"},
1392 {PREGf_NAUGHTY, "NAUGHTY,"},
1393 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1394 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1395 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1396 {PREGf_NOSCAN, "NOSCAN,"},
1397 {PREGf_CANY_SEEN, "CANY_SEEN,"},
1398 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1399 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1400 {PREGf_ANCH_BOL, "ANCH_BOL,"},
1401 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1402 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1403 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1407 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1414 PERL_ARGS_ASSERT_DO_SV_DUMP;
1417 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1421 flags = SvFLAGS(sv);
1424 /* process general SV flags */
1426 d = Perl_newSVpvf(aTHX_
1427 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1428 PTR2UV(SvANY(sv)), PTR2UV(sv),
1429 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1430 (int)(PL_dumpindent*level), "");
1432 if (!((flags & SVpad_NAME) == SVpad_NAME
1433 && (type == SVt_PVMG || type == SVt_PVNV))) {
1434 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1435 sv_catpv(d, "PADSTALE,");
1437 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1438 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1439 sv_catpv(d, "PADTMP,");
1440 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1442 append_flags(d, flags, first_sv_flags_names);
1443 if (flags & SVf_ROK) {
1444 sv_catpv(d, "ROK,");
1445 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1447 append_flags(d, flags, second_sv_flags_names);
1448 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1449 && type != SVt_PVAV) {
1450 if (SvPCS_IMPORTED(sv))
1451 sv_catpv(d, "PCS_IMPORTED,");
1453 sv_catpv(d, "SCREAM,");
1456 /* process type-specific SV flags */
1461 append_flags(d, CvFLAGS(sv), cv_flags_names);
1464 append_flags(d, flags, hv_flags_names);
1468 if (isGV_with_GP(sv)) {
1469 append_flags(d, GvFLAGS(sv), gp_flags_names);
1471 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1472 sv_catpv(d, "IMPORT");
1473 if (GvIMPORTED(sv) == GVf_IMPORTED)
1474 sv_catpv(d, "ALL,");
1477 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1484 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1485 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1488 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1489 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1490 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1491 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1494 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1497 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1500 /* SVphv_SHAREKEYS is also 0x20000000 */
1501 if ((type != SVt_PVHV) && SvUTF8(sv))
1502 sv_catpv(d, "UTF8");
1504 if (*(SvEND(d) - 1) == ',') {
1505 SvCUR_set(d, SvCUR(d) - 1);
1506 SvPVX(d)[SvCUR(d)] = '\0';
1511 /* dump initial SV details */
1513 #ifdef DEBUG_LEAKING_SCALARS
1514 Perl_dump_indent(aTHX_ level, file,
1515 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1516 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1518 sv->sv_debug_inpad ? "for" : "by",
1519 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1520 PTR2UV(sv->sv_debug_parent),
1524 Perl_dump_indent(aTHX_ level, file, "SV = ");
1528 if (type < SVt_LAST) {
1529 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1531 if (type == SVt_NULL) {
1536 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1541 /* Dump general SV fields */
1543 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1544 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1545 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1546 || (type == SVt_IV && !SvROK(sv))) {
1548 #ifdef PERL_OLD_COPY_ON_WRITE
1552 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1554 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1555 #ifdef PERL_OLD_COPY_ON_WRITE
1556 if (SvIsCOW_shared_hash(sv))
1557 PerlIO_printf(file, " (HASH)");
1558 else if (SvIsCOW_normal(sv))
1559 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1561 PerlIO_putc(file, '\n');
1564 if ((type == SVt_PVNV || type == SVt_PVMG)
1565 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1566 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1567 (UV) COP_SEQ_RANGE_LOW(sv));
1568 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1569 (UV) COP_SEQ_RANGE_HIGH(sv));
1570 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1571 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1572 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1573 || type == SVt_NV) {
1574 STORE_NUMERIC_LOCAL_SET_STANDARD();
1575 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1576 RESTORE_NUMERIC_LOCAL();
1580 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1582 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1585 if (type < SVt_PV) {
1590 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1591 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1592 const bool re = isREGEXP(sv);
1593 const char * const ptr =
1594 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1598 SvOOK_offset(sv, delta);
1599 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1604 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1606 PerlIO_printf(file, "( %s . ) ",
1607 pv_display(d, ptr - delta, delta, 0,
1610 if (type == SVt_INVLIST) {
1611 PerlIO_printf(file, "\n");
1612 /* 4 blanks indents 2 beyond the PV, etc */
1613 _invlist_dump(file, level, " ", sv);
1616 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1619 if (SvUTF8(sv)) /* the 6? \x{....} */
1620 PerlIO_printf(file, " [UTF8 \"%s\"]",
1621 sv_uni_display(d, sv, 6 * SvCUR(sv),
1623 PerlIO_printf(file, "\n");
1625 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1627 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1629 #ifdef PERL_NEW_COPY_ON_WRITE
1630 if (SvIsCOW(sv) && SvLEN(sv))
1631 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1636 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1639 if (type >= SVt_PVMG) {
1640 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1641 HV * const ost = SvOURSTASH(sv);
1643 do_hv_dump(level, file, " OURSTASH", ost);
1644 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1645 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1646 (UV)PadnamelistMAXNAMED(sv));
1649 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1652 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1654 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1655 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1659 /* Dump type-specific SV fields */
1663 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1664 if (AvARRAY(sv) != AvALLOC(sv)) {
1665 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1666 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1669 PerlIO_putc(file, '\n');
1670 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1671 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1672 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1674 if (!AvPAD_NAMELIST(sv))
1675 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1676 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1678 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1679 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1680 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1681 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1682 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1684 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1685 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1687 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1689 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1696 struct xpvhv_aux *const aux = HvAUX(sv);
1697 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1698 (UV)aux->xhv_aux_flags);
1700 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1701 usedkeys = HvUSEDKEYS(sv);
1702 if (HvARRAY(sv) && usedkeys) {
1703 /* Show distribution of HEs in the ARRAY */
1705 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1708 U32 pow2 = 2, keys = usedkeys;
1709 NV theoret, sum = 0;
1711 PerlIO_printf(file, " (");
1712 Zero(freq, FREQ_MAX + 1, int);
1713 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1716 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1718 if (count > FREQ_MAX)
1724 for (i = 0; i <= max; i++) {
1726 PerlIO_printf(file, "%d%s:%d", i,
1727 (i == FREQ_MAX) ? "+" : "",
1730 PerlIO_printf(file, ", ");
1733 PerlIO_putc(file, ')');
1734 /* The "quality" of a hash is defined as the total number of
1735 comparisons needed to access every element once, relative
1736 to the expected number needed for a random hash.
1738 The total number of comparisons is equal to the sum of
1739 the squares of the number of entries in each bucket.
1740 For a random hash of n keys into k buckets, the expected
1745 for (i = max; i > 0; i--) { /* Precision: count down. */
1746 sum += freq[i] * i * i;
1748 while ((keys = keys >> 1))
1751 theoret += theoret * (theoret-1)/pow2;
1752 PerlIO_putc(file, '\n');
1753 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1755 PerlIO_putc(file, '\n');
1756 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1759 HE **ents = HvARRAY(sv);
1762 HE *const *const last = ents + HvMAX(sv);
1763 count = last + 1 - ents;
1768 } while (++ents <= last);
1772 struct xpvhv_aux *const aux = HvAUX(sv);
1773 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1774 " (cached = %"UVuf")\n",
1775 (UV)count, (UV)aux->xhv_fill_lazy);
1777 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1781 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1783 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1784 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1785 #ifdef PERL_HASH_RANDOMIZE_KEYS
1786 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1787 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1788 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1791 PerlIO_putc(file, '\n');
1794 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1795 if (mg && mg->mg_obj) {
1796 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1800 const char * const hvname = HvNAME_get(sv);
1802 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1803 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1804 generic_pv_escape( tmpsv, hvname,
1805 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1810 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1811 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1812 if (HvAUX(sv)->xhv_name_count)
1813 Perl_dump_indent(aTHX_
1814 level, file, " NAMECOUNT = %"IVdf"\n",
1815 (IV)HvAUX(sv)->xhv_name_count
1817 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1818 const I32 count = HvAUX(sv)->xhv_name_count;
1820 SV * const names = newSVpvs_flags("", SVs_TEMP);
1821 /* The starting point is the first element if count is
1822 positive and the second element if count is negative. */
1823 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1824 + (count < 0 ? 1 : 0);
1825 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1826 + (count < 0 ? -count : count);
1827 while (hekp < endp) {
1828 if (HEK_LEN(*hekp)) {
1829 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1830 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1831 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1833 /* This should never happen. */
1834 sv_catpvs(names, ", (null)");
1838 Perl_dump_indent(aTHX_
1839 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1843 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1844 const char *const hvename = HvENAME_get(sv);
1845 Perl_dump_indent(aTHX_
1846 level, file, " ENAME = \"%s\"\n",
1847 generic_pv_escape(tmp, hvename,
1848 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1852 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1854 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1858 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1859 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1860 generic_pv_escape( tmpsv, meta->mro_which->name,
1861 meta->mro_which->length,
1862 (meta->mro_which->kflags & HVhek_UTF8)),
1863 PTR2UV(meta->mro_which));
1864 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1865 (UV)meta->cache_gen);
1866 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1868 if (meta->mro_linear_all) {
1869 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1870 PTR2UV(meta->mro_linear_all));
1871 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1874 if (meta->mro_linear_current) {
1875 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1876 PTR2UV(meta->mro_linear_current));
1877 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1880 if (meta->mro_nextmethod) {
1881 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1882 PTR2UV(meta->mro_nextmethod));
1883 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1887 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1889 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1894 if (nest < maxnest) {
1895 HV * const hv = MUTABLE_HV(sv);
1900 int count = maxnest - nest;
1901 for (i=0; i <= HvMAX(hv); i++) {
1902 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1909 if (count-- <= 0) goto DONEHV;
1912 keysv = hv_iterkeysv(he);
1913 keypv = SvPV_const(keysv, len);
1916 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1918 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1919 if (HvEITER_get(hv) == he)
1920 PerlIO_printf(file, "[CURRENT] ");
1921 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1922 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1929 } /* case SVt_PVHV */
1932 if (CvAUTOLOAD(sv)) {
1933 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1935 const char *const name = SvPV_const(sv, len);
1936 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1937 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1940 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1941 const char *const proto = CvPROTO(sv);
1942 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1943 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1948 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1949 if (!CvISXSUB(sv)) {
1951 Perl_dump_indent(aTHX_ level, file,
1952 " START = 0x%"UVxf" ===> %"IVdf"\n",
1953 PTR2UV(CvSTART(sv)),
1954 (IV)sequence_num(CvSTART(sv)));
1956 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1957 PTR2UV(CvROOT(sv)));
1958 if (CvROOT(sv) && dumpops) {
1959 do_op_dump(level+1, file, CvROOT(sv));
1962 SV * const constant = cv_const_sv((const CV *)sv);
1964 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1967 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1969 PTR2UV(CvXSUBANY(sv).any_ptr));
1970 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1973 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1974 (IV)CvXSUBANY(sv).any_i32);
1978 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1979 HEK_KEY(CvNAME_HEK((CV *)sv)));
1980 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1981 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1982 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1983 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1984 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1985 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1986 if (nest < maxnest) {
1987 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1990 const CV * const outside = CvOUTSIDE(sv);
1991 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1994 : CvANON(outside) ? "ANON"
1995 : (outside == PL_main_cv) ? "MAIN"
1996 : CvUNIQUE(outside) ? "UNIQUE"
1999 newSVpvs_flags("", SVs_TEMP),
2000 GvNAME(CvGV(outside)),
2001 GvNAMELEN(CvGV(outside)),
2002 GvNAMEUTF8(CvGV(outside)))
2005 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2006 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2011 if (type == SVt_PVLV) {
2012 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2014 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2015 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2016 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2017 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2018 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2021 if (isREGEXP(sv)) goto dumpregexp;
2022 if (!isGV_with_GP(sv))
2025 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2026 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2027 generic_pv_escape(tmpsv, GvNAME(sv),
2031 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2032 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2033 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2038 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2044 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2045 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2046 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2047 do_gv_dump (level, file, " EGV", GvEGV(sv));
2050 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2051 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2052 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2054 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2055 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2056 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2058 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2059 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2060 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2062 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2063 PTR2UV(IoTOP_GV(sv)));
2064 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2065 maxnest, dumpops, pvlim);
2067 /* Source filters hide things that are not GVs in these three, so let's
2068 be careful out there. */
2070 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2071 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2072 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2074 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2075 PTR2UV(IoFMT_GV(sv)));
2076 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2077 maxnest, dumpops, pvlim);
2079 if (IoBOTTOM_NAME(sv))
2080 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2081 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2082 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2084 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2085 PTR2UV(IoBOTTOM_GV(sv)));
2086 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2087 maxnest, dumpops, pvlim);
2089 if (isPRINT(IoTYPE(sv)))
2090 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2093 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2098 struct regexp * const r = ReANY((REGEXP*)sv);
2100 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2102 append_flags(d, flags, names); \
2103 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2104 SvCUR_set(d, SvCUR(d) - 1); \
2105 SvPVX(d)[SvCUR(d)] = '\0'; \
2108 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2109 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2110 (UV)(r->compflags), SvPVX_const(d));
2112 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2113 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2114 (UV)(r->extflags), SvPVX_const(d));
2116 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2117 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2118 if (r->engine == &PL_core_reg_engine) {
2119 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2120 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2121 (UV)(r->intflags), SvPVX_const(d));
2123 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2126 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2127 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2129 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2130 (UV)(r->lastparen));
2131 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2132 (UV)(r->lastcloseparen));
2133 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2135 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2136 (IV)(r->minlenret));
2137 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2139 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2140 (UV)(r->pre_prefix));
2141 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2143 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2144 (IV)(r->suboffset));
2145 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2146 (IV)(r->subcoffset));
2148 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2150 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2152 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2153 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2154 PTR2UV(r->mother_re));
2155 if (nest < maxnest && r->mother_re)
2156 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2157 maxnest, dumpops, pvlim);
2158 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2159 PTR2UV(r->paren_names));
2160 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2161 PTR2UV(r->substrs));
2162 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2163 PTR2UV(r->pprivate));
2164 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2166 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2167 PTR2UV(r->qr_anoncv));
2169 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2170 PTR2UV(r->saved_copy));
2181 Dumps the contents of an SV to the C<STDERR> filehandle.
2183 For an example of its output, see L<Devel::Peek>.
2189 Perl_sv_dump(pTHX_ SV *sv)
2191 PERL_ARGS_ASSERT_SV_DUMP;
2194 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2196 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2200 Perl_runops_debug(pTHX)
2203 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2207 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2209 #ifdef PERL_TRACE_OPS
2210 ++PL_op_exec_cnt[PL_op->op_type];
2213 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2214 PerlIO_printf(Perl_debug_log,
2215 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2216 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2217 PTR2UV(*PL_watchaddr));
2218 if (DEBUG_s_TEST_) {
2219 if (DEBUG_v_TEST_) {
2220 PerlIO_printf(Perl_debug_log, "\n");
2228 if (DEBUG_t_TEST_) debop(PL_op);
2229 if (DEBUG_P_TEST_) debprof(PL_op);
2232 OP_ENTRY_PROBE(OP_NAME(PL_op));
2233 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2234 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2242 Perl_debop(pTHX_ const OP *o)
2246 PERL_ARGS_ASSERT_DEBOP;
2248 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2251 Perl_deb(aTHX_ "%s", OP_NAME(o));
2252 switch (o->op_type) {
2255 /* With ITHREADS, consts are stored in the pad, and the right pad
2256 * may not be active here, so check.
2257 * Looks like only during compiling the pads are illegal.
2260 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2262 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2267 SV * const sv = newSV(0);
2268 gv_fullname3(sv, cGVOPo_gv, NULL);
2269 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2270 SvREFCNT_dec_NN(sv);
2273 PerlIO_printf(Perl_debug_log, "(NULL)");
2282 count = o->op_private & OPpPADRANGE_COUNTMASK;
2284 /* print the lexical's name */
2286 CV * const cv = deb_curcv(cxstack_ix);
2288 PAD * comppad = NULL;
2292 PADLIST * const padlist = CvPADLIST(cv);
2293 comppad = *PadlistARRAY(padlist);
2295 PerlIO_printf(Perl_debug_log, "(");
2296 for (i = 0; i < count; i++) {
2298 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2299 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2301 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2304 PerlIO_printf(Perl_debug_log, ",");
2306 PerlIO_printf(Perl_debug_log, ")");
2313 PerlIO_printf(Perl_debug_log, "\n");
2318 S_deb_curcv(pTHX_ const I32 ix)
2320 const PERL_CONTEXT * const cx = &cxstack[ix];
2321 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2322 return cx->blk_sub.cv;
2323 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2324 return cx->blk_eval.cv;
2325 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2330 return deb_curcv(ix - 1);
2334 Perl_watch(pTHX_ char **addr)
2336 PERL_ARGS_ASSERT_WATCH;
2338 PL_watchaddr = addr;
2340 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2341 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2345 S_debprof(pTHX_ const OP *o)
2347 PERL_ARGS_ASSERT_DEBPROF;
2349 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2351 if (!PL_profiledata)
2352 Newxz(PL_profiledata, MAXO, U32);
2353 ++PL_profiledata[o->op_type];
2357 Perl_debprofdump(pTHX)
2360 if (!PL_profiledata)
2362 for (i = 0; i < MAXO; i++) {
2363 if (PL_profiledata[i])
2364 PerlIO_printf(Perl_debug_log,
2365 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2373 * c-indentation-style: bsd
2375 * indent-tabs-mode: nil
2378 * ex: set ts=8 sts=4 sw=4 et: