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);
754 const struct flag_to_name op_flags_names[] = {
756 {OPf_PARENS, ",PARENS"},
759 {OPf_STACKED, ",STACKED"},
760 {OPf_SPECIAL, ",SPECIAL"}
763 const struct flag_to_name op_trans_names[] = {
764 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
765 {OPpTRANS_TO_UTF, ",TO_UTF"},
766 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
767 {OPpTRANS_SQUASH, ",SQUASH"},
768 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
769 {OPpTRANS_GROWS, ",GROWS"},
770 {OPpTRANS_DELETE, ",DELETE"}
773 const struct flag_to_name op_entersub_names[] = {
774 {OPpENTERSUB_DB, ",DB"},
775 {OPpENTERSUB_HASTARG, ",HASTARG"},
776 {OPpENTERSUB_AMPER, ",AMPER"},
777 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
778 {OPpENTERSUB_INARGS, ",INARGS"}
781 const struct flag_to_name op_const_names[] = {
782 {OPpCONST_NOVER, ",NOVER"},
783 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
784 {OPpCONST_STRICT, ",STRICT"},
785 {OPpCONST_ENTERED, ",ENTERED"},
786 {OPpCONST_BARE, ",BARE"}
789 const struct flag_to_name op_sort_names[] = {
790 {OPpSORT_NUMERIC, ",NUMERIC"},
791 {OPpSORT_INTEGER, ",INTEGER"},
792 {OPpSORT_REVERSE, ",REVERSE"},
793 {OPpSORT_INPLACE, ",INPLACE"},
794 {OPpSORT_DESCEND, ",DESCEND"},
795 {OPpSORT_QSORT, ",QSORT"},
796 {OPpSORT_STABLE, ",STABLE"}
799 const struct flag_to_name op_open_names[] = {
800 {OPpOPEN_IN_RAW, ",IN_RAW"},
801 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
802 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
803 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
806 const struct flag_to_name op_sassign_names[] = {
807 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
808 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
811 const struct flag_to_name op_leave_names[] = {
812 {OPpREFCOUNTED, ",REFCOUNTED"},
813 {OPpLVALUE, ",LVALUE"}
816 #define OP_PRIVATE_ONCE(op, flag, name) \
817 const struct flag_to_name CAT2(op, _names)[] = { \
821 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
822 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
823 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
824 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
825 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
826 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
827 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
828 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
829 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
830 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
831 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
832 OP_PRIVATE_ONCE(op_dbstate, OPpHUSH_VMSISH, ",HUSH_VMSISH");
834 struct op_private_by_op {
837 const struct flag_to_name *start;
840 const struct op_private_by_op op_private_names[] = {
841 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
842 {OP_LEAVE, C_ARRAY_LENGTH(op_leave_names), op_leave_names },
843 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
844 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
845 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
846 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
847 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
848 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
849 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
850 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
851 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
852 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
853 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
854 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
855 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
856 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
857 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
858 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
859 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
860 {OP_DBSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names },
861 {OP_NEXTSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names },
862 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
866 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
867 const struct op_private_by_op *start = op_private_names;
868 const struct op_private_by_op *const end = C_ARRAY_END(op_private_names);
870 /* This is a linear search, but no worse than the code that it replaced.
871 It's debugging code - size is more important than speed. */
873 if (optype == start->op_type) {
874 S_append_flags(aTHX_ tmpsv, op_private, start->start,
875 start->start + start->len);
878 } while (++start < end);
884 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
887 const OPCODE optype = o->op_type;
889 PERL_ARGS_ASSERT_DO_OP_DUMP;
891 Perl_dump_indent(aTHX_ level, file, "{\n");
893 seq = sequence_num(o);
895 PerlIO_printf(file, "%-4"UVuf, seq);
897 PerlIO_printf(file, "????");
899 "%*sTYPE = %s ===> ",
900 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
903 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
904 sequence_num(o->op_next));
906 PerlIO_printf(file, "NULL\n");
908 if (optype == OP_NULL) {
909 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
910 if (o->op_targ == OP_NEXTSTATE) {
912 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
914 if (CopSTASHPV(cCOPo)) {
915 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
916 HV *stash = CopSTASH(cCOPo);
917 const char * const hvname = HvNAME_get(stash);
919 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
920 generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
922 if (CopLABEL(cCOPo)) {
923 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
926 const char *label = CopLABEL_len_flags(cCOPo,
929 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
930 generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
936 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
939 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
942 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
943 SV * const tmpsv = newSVpvs("");
944 switch (o->op_flags & OPf_WANT) {
946 sv_catpv(tmpsv, ",VOID");
948 case OPf_WANT_SCALAR:
949 sv_catpv(tmpsv, ",SCALAR");
952 sv_catpv(tmpsv, ",LIST");
955 sv_catpv(tmpsv, ",UNKNOWN");
958 append_flags(tmpsv, o->op_flags, op_flags_names);
959 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
960 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
961 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
962 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
963 if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB");
964 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
965 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
969 U32 optype = o->op_type;
970 U32 oppriv = o->op_private;
971 SV * const tmpsv = newSVpvs("");
972 if (PL_opargs[optype] & OA_TARGLEX) {
973 if (oppriv & OPpTARGET_MY)
974 sv_catpv(tmpsv, ",TARGET_MY");
976 else if (optype == OP_ENTERSUB ||
977 optype == OP_RV2SV ||
979 optype == OP_RV2AV ||
980 optype == OP_RV2HV ||
981 optype == OP_RV2GV ||
982 optype == OP_AELEM ||
985 if (optype == OP_ENTERSUB) {
986 append_flags(tmpsv, oppriv, op_entersub_names);
989 switch (oppriv & OPpDEREF) {
991 sv_catpv(tmpsv, ",SV");
994 sv_catpv(tmpsv, ",AV");
997 sv_catpv(tmpsv, ",HV");
1000 if (oppriv & OPpMAYBE_LVSUB)
1001 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1003 if (optype == OP_AELEM || optype == OP_HELEM) {
1004 if (oppriv & OPpLVAL_DEFER)
1005 sv_catpv(tmpsv, ",LVAL_DEFER");
1007 else if (optype == OP_RV2HV || optype == OP_PADHV) {
1008 if (oppriv & OPpMAYBE_TRUEBOOL)
1009 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL");
1010 if (oppriv & OPpTRUEBOOL)
1011 sv_catpvs(tmpsv, ",OPpTRUEBOOL");
1014 if (oppriv & HINT_STRICT_REFS)
1015 sv_catpv(tmpsv, ",STRICT_REFS");
1016 if (oppriv & OPpOUR_INTRO)
1017 sv_catpv(tmpsv, ",OUR_INTRO");
1020 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) {
1022 else if (OP_IS_FILETEST(o->op_type)) {
1023 if (oppriv & OPpFT_ACCESS)
1024 sv_catpv(tmpsv, ",FT_ACCESS");
1025 if (oppriv & OPpFT_STACKED)
1026 sv_catpv(tmpsv, ",FT_STACKED");
1027 if (oppriv & OPpFT_STACKING)
1028 sv_catpv(tmpsv, ",FT_STACKING");
1029 if (oppriv & OPpFT_AFTER_t)
1030 sv_catpv(tmpsv, ",AFTER_t");
1032 else if (o->op_type == OP_AASSIGN) {
1033 if (oppriv & OPpASSIGN_COMMON)
1034 sv_catpvs(tmpsv, ",COMMON");
1035 if (oppriv & OPpMAYBE_LVSUB)
1036 sv_catpvs(tmpsv, ",MAYBE_LVSUB");
1038 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO)
1039 sv_catpv(tmpsv, ",INTRO");
1040 if (o->op_type == OP_PADRANGE)
1041 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf,
1042 (UV)(oppriv & OPpPADRANGE_COUNTMASK));
1043 if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV ||
1044 o->op_type == OP_PADAV || o->op_type == OP_PADHV ||
1045 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
1046 && oppriv & OPpSLICEWARNING )
1047 sv_catpvs(tmpsv, ",SLICEWARNING");
1049 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1051 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
1063 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1065 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1066 if (cSVOPo->op_sv) {
1069 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1070 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
1071 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1072 name = SvPV_const(tmpsv, len);
1073 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1074 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
1077 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1083 case OP_METHOD_NAMED:
1084 #ifndef USE_ITHREADS
1085 /* with ITHREADS, consts are stored in the pad, and the right pad
1086 * may not be active here, so skip */
1087 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1093 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1094 (UV)CopLINE(cCOPo));
1095 if (CopSTASHPV(cCOPo)) {
1096 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1097 HV *stash = CopSTASH(cCOPo);
1098 const char * const hvname = HvNAME_get(stash);
1100 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1101 generic_pv_escape(tmpsv, hvname,
1102 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1104 if (CopLABEL(cCOPo)) {
1105 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1108 const char *label = CopLABEL_len_flags(cCOPo,
1109 &label_len, &label_flags);
1110 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1111 generic_pv_escape( tmpsv, label, label_len,
1112 (label_flags & SVf_UTF8)));
1116 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1117 if (cLOOPo->op_redoop)
1118 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1120 PerlIO_printf(file, "DONE\n");
1121 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1122 if (cLOOPo->op_nextop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1125 PerlIO_printf(file, "DONE\n");
1126 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1127 if (cLOOPo->op_lastop)
1128 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1130 PerlIO_printf(file, "DONE\n");
1138 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1139 if (cLOGOPo->op_other)
1140 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1142 PerlIO_printf(file, "DONE\n");
1148 do_pmop_dump(level, file, cPMOPo);
1156 if (o->op_private & OPpREFCOUNTED)
1157 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1162 if (o->op_flags & OPf_KIDS) {
1164 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1165 do_op_dump(level, file, kid);
1167 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1173 Dumps the optree starting at OP C<o> to C<STDERR>.
1179 Perl_op_dump(pTHX_ const OP *o)
1181 PERL_ARGS_ASSERT_OP_DUMP;
1182 do_op_dump(0, Perl_debug_log, o);
1186 Perl_gv_dump(pTHX_ GV *gv)
1190 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1193 PERL_ARGS_ASSERT_GV_DUMP;
1196 PerlIO_printf(Perl_debug_log, "{}\n");
1199 sv = sv_newmortal();
1200 PerlIO_printf(Perl_debug_log, "{\n");
1201 gv_fullname3(sv, gv, NULL);
1202 name = SvPV_const(sv, len);
1203 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1204 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1205 if (gv != GvEGV(gv)) {
1206 gv_efullname3(sv, GvEGV(gv), NULL);
1207 name = SvPV_const(sv, len);
1208 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1209 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1211 PerlIO_putc(Perl_debug_log, '\n');
1212 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1216 /* map magic types to the symbolic names
1217 * (with the PERL_MAGIC_ prefixed stripped)
1220 static const struct { const char type; const char *name; } magic_names[] = {
1221 #include "mg_names.c"
1222 /* this null string terminates the list */
1227 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1229 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1231 for (; mg; mg = mg->mg_moremagic) {
1232 Perl_dump_indent(aTHX_ level, file,
1233 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1234 if (mg->mg_virtual) {
1235 const MGVTBL * const v = mg->mg_virtual;
1236 if (v >= PL_magic_vtables
1237 && v < PL_magic_vtables + magic_vtable_max) {
1238 const U32 i = v - PL_magic_vtables;
1239 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1242 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1245 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1248 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1252 const char *name = NULL;
1253 for (n = 0; magic_names[n].name; n++) {
1254 if (mg->mg_type == magic_names[n].type) {
1255 name = magic_names[n].name;
1260 Perl_dump_indent(aTHX_ level, file,
1261 " MG_TYPE = PERL_MAGIC_%s\n", name);
1263 Perl_dump_indent(aTHX_ level, file,
1264 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1268 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1269 if (mg->mg_type == PERL_MAGIC_envelem &&
1270 mg->mg_flags & MGf_TAINTEDDIR)
1271 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1272 if (mg->mg_type == PERL_MAGIC_regex_global &&
1273 mg->mg_flags & MGf_MINMATCH)
1274 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1275 if (mg->mg_flags & MGf_REFCOUNTED)
1276 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1277 if (mg->mg_flags & MGf_GSKIP)
1278 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1279 if (mg->mg_flags & MGf_COPY)
1280 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1281 if (mg->mg_flags & MGf_DUP)
1282 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1283 if (mg->mg_flags & MGf_LOCAL)
1284 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1285 if (mg->mg_type == PERL_MAGIC_regex_global &&
1286 mg->mg_flags & MGf_BYTES)
1287 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1290 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1291 PTR2UV(mg->mg_obj));
1292 if (mg->mg_type == PERL_MAGIC_qr) {
1293 REGEXP* const re = (REGEXP *)mg->mg_obj;
1294 SV * const dsv = sv_newmortal();
1295 const char * const s
1296 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1298 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1299 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1301 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1302 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1305 if (mg->mg_flags & MGf_REFCOUNTED)
1306 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1309 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1311 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1312 if (mg->mg_len >= 0) {
1313 if (mg->mg_type != PERL_MAGIC_utf8) {
1314 SV * const sv = newSVpvs("");
1315 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1316 SvREFCNT_dec_NN(sv);
1319 else if (mg->mg_len == HEf_SVKEY) {
1320 PerlIO_puts(file, " => HEf_SVKEY\n");
1321 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1322 maxnest, dumpops, pvlim); /* MG is already +1 */
1325 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1330 " does not know how to handle this MG_LEN"
1332 PerlIO_putc(file, '\n');
1334 if (mg->mg_type == PERL_MAGIC_utf8) {
1335 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1338 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1339 Perl_dump_indent(aTHX_ level, file,
1340 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1343 (UV)cache[i * 2 + 1]);
1350 Perl_magic_dump(pTHX_ const MAGIC *mg)
1352 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1356 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1360 PERL_ARGS_ASSERT_DO_HV_DUMP;
1362 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1363 if (sv && (hvname = HvNAME_get(sv)))
1365 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1366 name which quite legally could contain insane things like tabs, newlines, nulls or
1367 other scary crap - this should produce sane results - except maybe for unicode package
1368 names - but we will wait for someone to file a bug on that - demerphq */
1369 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1370 PerlIO_printf(file, "\t\"%s\"\n",
1371 generic_pv_escape( tmpsv, hvname,
1372 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1375 PerlIO_putc(file, '\n');
1379 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1381 PERL_ARGS_ASSERT_DO_GV_DUMP;
1383 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1384 if (sv && GvNAME(sv)) {
1385 SV * const tmpsv = newSVpvs("");
1386 PerlIO_printf(file, "\t\"%s\"\n",
1387 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1390 PerlIO_putc(file, '\n');
1394 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1396 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1398 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1399 if (sv && GvNAME(sv)) {
1400 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1402 HV * const stash = GvSTASH(sv);
1403 PerlIO_printf(file, "\t");
1404 /* TODO might have an extra \" here */
1405 if (stash && (hvname = HvNAME_get(stash))) {
1406 PerlIO_printf(file, "\"%s\" :: \"",
1407 generic_pv_escape(tmp, hvname,
1408 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1410 PerlIO_printf(file, "%s\"\n",
1411 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1414 PerlIO_putc(file, '\n');
1417 const struct flag_to_name first_sv_flags_names[] = {
1418 {SVs_TEMP, "TEMP,"},
1419 {SVs_OBJECT, "OBJECT,"},
1428 const struct flag_to_name second_sv_flags_names[] = {
1430 {SVf_FAKE, "FAKE,"},
1431 {SVf_READONLY, "READONLY,"},
1432 {SVf_IsCOW, "IsCOW,"},
1433 {SVf_BREAK, "BREAK,"},
1434 {SVf_AMAGIC, "OVERLOAD,"},
1440 const struct flag_to_name cv_flags_names[] = {
1441 {CVf_ANON, "ANON,"},
1442 {CVf_UNIQUE, "UNIQUE,"},
1443 {CVf_CLONE, "CLONE,"},
1444 {CVf_CLONED, "CLONED,"},
1445 {CVf_CONST, "CONST,"},
1446 {CVf_NODEBUG, "NODEBUG,"},
1447 {CVf_LVALUE, "LVALUE,"},
1448 {CVf_METHOD, "METHOD,"},
1449 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1450 {CVf_CVGV_RC, "CVGV_RC,"},
1451 {CVf_DYNFILE, "DYNFILE,"},
1452 {CVf_AUTOLOAD, "AUTOLOAD,"},
1453 {CVf_HASEVAL, "HASEVAL"},
1454 {CVf_SLABBED, "SLABBED,"},
1455 {CVf_ISXSUB, "ISXSUB,"}
1458 const struct flag_to_name hv_flags_names[] = {
1459 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1460 {SVphv_LAZYDEL, "LAZYDEL,"},
1461 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1462 {SVphv_CLONEABLE, "CLONEABLE,"}
1465 const struct flag_to_name gp_flags_names[] = {
1466 {GVf_INTRO, "INTRO,"},
1467 {GVf_MULTI, "MULTI,"},
1468 {GVf_ASSUMECV, "ASSUMECV,"},
1469 {GVf_IN_PAD, "IN_PAD,"}
1472 const struct flag_to_name gp_flags_imported_names[] = {
1473 {GVf_IMPORTED_SV, " SV"},
1474 {GVf_IMPORTED_AV, " AV"},
1475 {GVf_IMPORTED_HV, " HV"},
1476 {GVf_IMPORTED_CV, " CV"},
1479 /* NOTE: this structure is mostly duplicative of one generated by
1480 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1481 * the two. - Yves */
1482 const struct flag_to_name regexp_extflags_names[] = {
1483 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1484 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1485 {RXf_PMf_FOLD, "PMf_FOLD,"},
1486 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1487 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1488 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1489 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1490 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1491 {RXf_CHECK_ALL, "CHECK_ALL,"},
1492 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1493 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1494 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1495 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1496 {RXf_SPLIT, "SPLIT,"},
1497 {RXf_COPY_DONE, "COPY_DONE,"},
1498 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1499 {RXf_TAINTED, "TAINTED,"},
1500 {RXf_START_ONLY, "START_ONLY,"},
1501 {RXf_SKIPWHITE, "SKIPWHITE,"},
1502 {RXf_WHITE, "WHITE,"},
1503 {RXf_NULL, "NULL,"},
1506 /* NOTE: this structure is mostly duplicative of one generated by
1507 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1508 * the two. - Yves */
1509 const struct flag_to_name regexp_core_intflags_names[] = {
1510 {PREGf_SKIP, "SKIP,"},
1511 {PREGf_IMPLICIT, "IMPLICIT,"},
1512 {PREGf_NAUGHTY, "NAUGHTY,"},
1513 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1514 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1515 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1516 {PREGf_NOSCAN, "NOSCAN,"},
1517 {PREGf_CANY_SEEN, "CANY_SEEN,"},
1518 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1519 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1520 {PREGf_ANCH_BOL, "ANCH_BOL,"},
1521 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1522 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1523 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1527 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1534 PERL_ARGS_ASSERT_DO_SV_DUMP;
1537 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1541 flags = SvFLAGS(sv);
1544 /* process general SV flags */
1546 d = Perl_newSVpvf(aTHX_
1547 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1548 PTR2UV(SvANY(sv)), PTR2UV(sv),
1549 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1550 (int)(PL_dumpindent*level), "");
1552 if (!((flags & SVpad_NAME) == SVpad_NAME
1553 && (type == SVt_PVMG || type == SVt_PVNV))) {
1554 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1555 sv_catpv(d, "PADSTALE,");
1557 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1558 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1559 sv_catpv(d, "PADTMP,");
1560 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1562 append_flags(d, flags, first_sv_flags_names);
1563 if (flags & SVf_ROK) {
1564 sv_catpv(d, "ROK,");
1565 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1567 append_flags(d, flags, second_sv_flags_names);
1568 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1569 && type != SVt_PVAV) {
1570 if (SvPCS_IMPORTED(sv))
1571 sv_catpv(d, "PCS_IMPORTED,");
1573 sv_catpv(d, "SCREAM,");
1576 /* process type-specific SV flags */
1581 append_flags(d, CvFLAGS(sv), cv_flags_names);
1584 append_flags(d, flags, hv_flags_names);
1588 if (isGV_with_GP(sv)) {
1589 append_flags(d, GvFLAGS(sv), gp_flags_names);
1591 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1592 sv_catpv(d, "IMPORT");
1593 if (GvIMPORTED(sv) == GVf_IMPORTED)
1594 sv_catpv(d, "ALL,");
1597 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1604 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1605 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1608 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1609 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1610 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1611 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1614 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1617 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1620 /* SVphv_SHAREKEYS is also 0x20000000 */
1621 if ((type != SVt_PVHV) && SvUTF8(sv))
1622 sv_catpv(d, "UTF8");
1624 if (*(SvEND(d) - 1) == ',') {
1625 SvCUR_set(d, SvCUR(d) - 1);
1626 SvPVX(d)[SvCUR(d)] = '\0';
1631 /* dump initial SV details */
1633 #ifdef DEBUG_LEAKING_SCALARS
1634 Perl_dump_indent(aTHX_ level, file,
1635 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1636 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1638 sv->sv_debug_inpad ? "for" : "by",
1639 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1640 PTR2UV(sv->sv_debug_parent),
1644 Perl_dump_indent(aTHX_ level, file, "SV = ");
1648 if (type < SVt_LAST) {
1649 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1651 if (type == SVt_NULL) {
1656 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1661 /* Dump general SV fields */
1663 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1664 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1665 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1666 || (type == SVt_IV && !SvROK(sv))) {
1668 #ifdef PERL_OLD_COPY_ON_WRITE
1672 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1674 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1675 #ifdef PERL_OLD_COPY_ON_WRITE
1676 if (SvIsCOW_shared_hash(sv))
1677 PerlIO_printf(file, " (HASH)");
1678 else if (SvIsCOW_normal(sv))
1679 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1681 PerlIO_putc(file, '\n');
1684 if ((type == SVt_PVNV || type == SVt_PVMG)
1685 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1686 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1687 (UV) COP_SEQ_RANGE_LOW(sv));
1688 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1689 (UV) COP_SEQ_RANGE_HIGH(sv));
1690 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1691 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1692 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1693 || type == SVt_NV) {
1694 STORE_NUMERIC_LOCAL_SET_STANDARD();
1695 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1696 RESTORE_NUMERIC_LOCAL();
1700 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1702 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1705 if (type < SVt_PV) {
1710 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1711 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1712 const bool re = isREGEXP(sv);
1713 const char * const ptr =
1714 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1718 SvOOK_offset(sv, delta);
1719 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1724 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1726 PerlIO_printf(file, "( %s . ) ",
1727 pv_display(d, ptr - delta, delta, 0,
1730 if (type == SVt_INVLIST) {
1731 PerlIO_printf(file, "\n");
1732 /* 4 blanks indents 2 beyond the PV, etc */
1733 _invlist_dump(file, level, " ", sv);
1736 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1739 if (SvUTF8(sv)) /* the 6? \x{....} */
1740 PerlIO_printf(file, " [UTF8 \"%s\"]",
1741 sv_uni_display(d, sv, 6 * SvCUR(sv),
1743 PerlIO_printf(file, "\n");
1745 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1747 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1749 #ifdef PERL_NEW_COPY_ON_WRITE
1750 if (SvIsCOW(sv) && SvLEN(sv))
1751 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1756 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1759 if (type >= SVt_PVMG) {
1760 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1761 HV * const ost = SvOURSTASH(sv);
1763 do_hv_dump(level, file, " OURSTASH", ost);
1764 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1765 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1766 (UV)PadnamelistMAXNAMED(sv));
1769 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1772 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1774 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1775 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1779 /* Dump type-specific SV fields */
1783 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1784 if (AvARRAY(sv) != AvALLOC(sv)) {
1785 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1786 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1789 PerlIO_putc(file, '\n');
1790 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1791 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1792 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1794 if (!AvPAD_NAMELIST(sv))
1795 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1796 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1798 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1799 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1800 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1801 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1802 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1804 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1805 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1807 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1809 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1816 struct xpvhv_aux *const aux = HvAUX(sv);
1817 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1818 (UV)aux->xhv_aux_flags);
1820 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1821 usedkeys = HvUSEDKEYS(sv);
1822 if (HvARRAY(sv) && usedkeys) {
1823 /* Show distribution of HEs in the ARRAY */
1825 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1828 U32 pow2 = 2, keys = usedkeys;
1829 NV theoret, sum = 0;
1831 PerlIO_printf(file, " (");
1832 Zero(freq, FREQ_MAX + 1, int);
1833 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1836 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1838 if (count > FREQ_MAX)
1844 for (i = 0; i <= max; i++) {
1846 PerlIO_printf(file, "%d%s:%d", i,
1847 (i == FREQ_MAX) ? "+" : "",
1850 PerlIO_printf(file, ", ");
1853 PerlIO_putc(file, ')');
1854 /* The "quality" of a hash is defined as the total number of
1855 comparisons needed to access every element once, relative
1856 to the expected number needed for a random hash.
1858 The total number of comparisons is equal to the sum of
1859 the squares of the number of entries in each bucket.
1860 For a random hash of n keys into k buckets, the expected
1865 for (i = max; i > 0; i--) { /* Precision: count down. */
1866 sum += freq[i] * i * i;
1868 while ((keys = keys >> 1))
1871 theoret += theoret * (theoret-1)/pow2;
1872 PerlIO_putc(file, '\n');
1873 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1875 PerlIO_putc(file, '\n');
1876 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1879 HE **ents = HvARRAY(sv);
1882 HE *const *const last = ents + HvMAX(sv);
1883 count = last + 1 - ents;
1888 } while (++ents <= last);
1892 struct xpvhv_aux *const aux = HvAUX(sv);
1893 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1894 " (cached = %"UVuf")\n",
1895 (UV)count, (UV)aux->xhv_fill_lazy);
1897 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1901 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1903 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1904 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1905 #ifdef PERL_HASH_RANDOMIZE_KEYS
1906 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1907 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1908 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1911 PerlIO_putc(file, '\n');
1914 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1915 if (mg && mg->mg_obj) {
1916 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1920 const char * const hvname = HvNAME_get(sv);
1922 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1923 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1924 generic_pv_escape( tmpsv, hvname,
1925 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1930 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1931 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1932 if (HvAUX(sv)->xhv_name_count)
1933 Perl_dump_indent(aTHX_
1934 level, file, " NAMECOUNT = %"IVdf"\n",
1935 (IV)HvAUX(sv)->xhv_name_count
1937 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1938 const I32 count = HvAUX(sv)->xhv_name_count;
1940 SV * const names = newSVpvs_flags("", SVs_TEMP);
1941 /* The starting point is the first element if count is
1942 positive and the second element if count is negative. */
1943 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1944 + (count < 0 ? 1 : 0);
1945 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1946 + (count < 0 ? -count : count);
1947 while (hekp < endp) {
1948 if (HEK_LEN(*hekp)) {
1949 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1950 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1951 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1953 /* This should never happen. */
1954 sv_catpvs(names, ", (null)");
1958 Perl_dump_indent(aTHX_
1959 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1963 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1964 const char *const hvename = HvENAME_get(sv);
1965 Perl_dump_indent(aTHX_
1966 level, file, " ENAME = \"%s\"\n",
1967 generic_pv_escape(tmp, hvename,
1968 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1974 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1978 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1979 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1980 generic_pv_escape( tmpsv, meta->mro_which->name,
1981 meta->mro_which->length,
1982 (meta->mro_which->kflags & HVhek_UTF8)),
1983 PTR2UV(meta->mro_which));
1984 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1985 (UV)meta->cache_gen);
1986 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1988 if (meta->mro_linear_all) {
1989 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1990 PTR2UV(meta->mro_linear_all));
1991 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1994 if (meta->mro_linear_current) {
1995 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1996 PTR2UV(meta->mro_linear_current));
1997 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2000 if (meta->mro_nextmethod) {
2001 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
2002 PTR2UV(meta->mro_nextmethod));
2003 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2007 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
2009 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2014 if (nest < maxnest) {
2015 HV * const hv = MUTABLE_HV(sv);
2020 int count = maxnest - nest;
2021 for (i=0; i <= HvMAX(hv); i++) {
2022 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2029 if (count-- <= 0) goto DONEHV;
2032 keysv = hv_iterkeysv(he);
2033 keypv = SvPV_const(keysv, len);
2036 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2038 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2039 if (HvEITER_get(hv) == he)
2040 PerlIO_printf(file, "[CURRENT] ");
2041 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
2042 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2049 } /* case SVt_PVHV */
2052 if (CvAUTOLOAD(sv)) {
2053 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2055 const char *const name = SvPV_const(sv, len);
2056 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2057 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2060 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2061 const char *const proto = CvPROTO(sv);
2062 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2063 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2068 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2069 if (!CvISXSUB(sv)) {
2071 Perl_dump_indent(aTHX_ level, file,
2072 " START = 0x%"UVxf" ===> %"IVdf"\n",
2073 PTR2UV(CvSTART(sv)),
2074 (IV)sequence_num(CvSTART(sv)));
2076 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2077 PTR2UV(CvROOT(sv)));
2078 if (CvROOT(sv) && dumpops) {
2079 do_op_dump(level+1, file, CvROOT(sv));
2082 SV * const constant = cv_const_sv((const CV *)sv);
2084 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2087 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2089 PTR2UV(CvXSUBANY(sv).any_ptr));
2090 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2093 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2094 (IV)CvXSUBANY(sv).any_i32);
2098 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2099 HEK_KEY(CvNAME_HEK((CV *)sv)));
2100 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2101 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2102 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2103 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2104 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2105 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2106 if (nest < maxnest) {
2107 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2110 const CV * const outside = CvOUTSIDE(sv);
2111 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2114 : CvANON(outside) ? "ANON"
2115 : (outside == PL_main_cv) ? "MAIN"
2116 : CvUNIQUE(outside) ? "UNIQUE"
2119 newSVpvs_flags("", SVs_TEMP),
2120 GvNAME(CvGV(outside)),
2121 GvNAMELEN(CvGV(outside)),
2122 GvNAMEUTF8(CvGV(outside)))
2125 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2126 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2131 if (type == SVt_PVLV) {
2132 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2133 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2134 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2135 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2136 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2137 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2138 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2141 if (isREGEXP(sv)) goto dumpregexp;
2142 if (!isGV_with_GP(sv))
2145 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2146 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2147 generic_pv_escape(tmpsv, GvNAME(sv),
2151 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2152 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2153 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2156 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2157 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2158 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2159 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2160 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2161 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2162 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2163 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2164 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2165 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2166 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2167 do_gv_dump (level, file, " EGV", GvEGV(sv));
2170 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2171 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2172 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2173 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2174 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2175 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2176 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2178 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2179 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2180 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2182 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2183 PTR2UV(IoTOP_GV(sv)));
2184 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2185 maxnest, dumpops, pvlim);
2187 /* Source filters hide things that are not GVs in these three, so let's
2188 be careful out there. */
2190 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2191 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2192 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2194 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2195 PTR2UV(IoFMT_GV(sv)));
2196 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2197 maxnest, dumpops, pvlim);
2199 if (IoBOTTOM_NAME(sv))
2200 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2201 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2202 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2204 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2205 PTR2UV(IoBOTTOM_GV(sv)));
2206 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2207 maxnest, dumpops, pvlim);
2209 if (isPRINT(IoTYPE(sv)))
2210 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2212 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2213 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2218 struct regexp * const r = ReANY((REGEXP*)sv);
2220 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2222 append_flags(d, flags, names); \
2223 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2224 SvCUR_set(d, SvCUR(d) - 1); \
2225 SvPVX(d)[SvCUR(d)] = '\0'; \
2228 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2229 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2230 (UV)(r->compflags), SvPVX_const(d));
2232 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2233 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2234 (UV)(r->extflags), SvPVX_const(d));
2236 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2237 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2238 if (r->engine == &PL_core_reg_engine) {
2239 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2240 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2241 (UV)(r->intflags), SvPVX_const(d));
2243 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2246 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2247 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2249 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2250 (UV)(r->lastparen));
2251 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2252 (UV)(r->lastcloseparen));
2253 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2255 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2256 (IV)(r->minlenret));
2257 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2259 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2260 (UV)(r->pre_prefix));
2261 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2263 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2264 (IV)(r->suboffset));
2265 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2266 (IV)(r->subcoffset));
2268 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2270 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2272 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2273 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2274 PTR2UV(r->mother_re));
2275 if (nest < maxnest && r->mother_re)
2276 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2277 maxnest, dumpops, pvlim);
2278 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2279 PTR2UV(r->paren_names));
2280 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2281 PTR2UV(r->substrs));
2282 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2283 PTR2UV(r->pprivate));
2284 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2286 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2287 PTR2UV(r->qr_anoncv));
2289 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2290 PTR2UV(r->saved_copy));
2301 Dumps the contents of an SV to the C<STDERR> filehandle.
2303 For an example of its output, see L<Devel::Peek>.
2309 Perl_sv_dump(pTHX_ SV *sv)
2311 PERL_ARGS_ASSERT_SV_DUMP;
2314 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2316 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2320 Perl_runops_debug(pTHX)
2323 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2327 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2329 #ifdef PERL_TRACE_OPS
2330 ++PL_op_exec_cnt[PL_op->op_type];
2333 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2334 PerlIO_printf(Perl_debug_log,
2335 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2336 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2337 PTR2UV(*PL_watchaddr));
2338 if (DEBUG_s_TEST_) {
2339 if (DEBUG_v_TEST_) {
2340 PerlIO_printf(Perl_debug_log, "\n");
2348 if (DEBUG_t_TEST_) debop(PL_op);
2349 if (DEBUG_P_TEST_) debprof(PL_op);
2352 OP_ENTRY_PROBE(OP_NAME(PL_op));
2353 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2354 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2362 Perl_debop(pTHX_ const OP *o)
2366 PERL_ARGS_ASSERT_DEBOP;
2368 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2371 Perl_deb(aTHX_ "%s", OP_NAME(o));
2372 switch (o->op_type) {
2375 /* With ITHREADS, consts are stored in the pad, and the right pad
2376 * may not be active here, so check.
2377 * Looks like only during compiling the pads are illegal.
2380 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2382 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2387 SV * const sv = newSV(0);
2388 gv_fullname3(sv, cGVOPo_gv, NULL);
2389 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2390 SvREFCNT_dec_NN(sv);
2393 PerlIO_printf(Perl_debug_log, "(NULL)");
2402 count = o->op_private & OPpPADRANGE_COUNTMASK;
2404 /* print the lexical's name */
2406 CV * const cv = deb_curcv(cxstack_ix);
2408 PAD * comppad = NULL;
2412 PADLIST * const padlist = CvPADLIST(cv);
2413 comppad = *PadlistARRAY(padlist);
2415 PerlIO_printf(Perl_debug_log, "(");
2416 for (i = 0; i < count; i++) {
2418 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2419 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2421 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2424 PerlIO_printf(Perl_debug_log, ",");
2426 PerlIO_printf(Perl_debug_log, ")");
2433 PerlIO_printf(Perl_debug_log, "\n");
2438 S_deb_curcv(pTHX_ const I32 ix)
2440 const PERL_CONTEXT * const cx = &cxstack[ix];
2441 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2442 return cx->blk_sub.cv;
2443 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2444 return cx->blk_eval.cv;
2445 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2450 return deb_curcv(ix - 1);
2454 Perl_watch(pTHX_ char **addr)
2456 PERL_ARGS_ASSERT_WATCH;
2458 PL_watchaddr = addr;
2460 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2461 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2465 S_debprof(pTHX_ const OP *o)
2467 PERL_ARGS_ASSERT_DEBPROF;
2469 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2471 if (!PL_profiledata)
2472 Newxz(PL_profiledata, MAXO, U32);
2473 ++PL_profiledata[o->op_type];
2477 Perl_debprofdump(pTHX)
2480 if (!PL_profiledata)
2482 for (i = 0; i < MAXO; i++) {
2483 if (PL_profiledata[i])
2484 PerlIO_printf(Perl_debug_log,
2485 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2493 * c-indentation-style: bsd
2495 * indent-tabs-mode: nil
2498 * ex: set ts=8 sts=4 sw=4 et: