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 =for apidoc_section $display
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) )
94 #define _pv_display_for_dump(dsv, pv, cur, len, pvlim) \
95 _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, PERL_PV_ESCAPE_DWIM_ALL_HEX)
100 Escapes at most the first C<count> chars of C<pv> and puts the results into
101 C<dsv> such that the size of the escaped string will not exceed C<max> chars
102 and will not contain any incomplete escape sequences. The number of bytes
103 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
104 When the C<dsv> parameter is null no escaping actually occurs, but the number
105 of bytes that would be escaped were it not null will be calculated.
107 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
108 will also be escaped.
110 Normally the SV will be cleared before the escaped string is prepared,
111 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
113 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8.
114 If C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
115 using C<is_utf8_string()> to determine if it is UTF-8.
117 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
118 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII>
119 is set, only non-ASCII chars will be escaped using this style;
120 otherwise, only chars above 255 will be so escaped; other non printable
121 chars will use octal or common escaped patterns like C<\n>. Otherwise,
122 if C<PERL_PV_ESCAPE_NOBACKSLASH> then all chars below 255 will be
123 treated as printable and will be output as literals. The
124 C<PERL_PV_ESCAPE_NON_WC> modifies the previous rules to cause word
125 chars, unicode or otherwise, to be output as literals, note this uses
126 the *unicode* rules for deciding on word characters.
128 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
129 string will be escaped, regardless of max. If the output is to be in
130 hex, then it will be returned as a plain hex sequence. Thus the output
131 will either be a single char, an octal escape sequence, a special escape
132 like C<\n> or a hex value.
134 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a
135 C<"%"> and not a C<"\\">. This is because regexes very often contain
136 backslashed sequences, whereas C<"%"> is not a particularly common
137 character in patterns.
139 Returns a pointer to the escaped text as held by C<dsv>.
141 =for apidoc Amnh||PERL_PV_ESCAPE_ALL
142 =for apidoc Amnh||PERL_PV_ESCAPE_FIRSTCHAR
143 =for apidoc Amnh||PERL_PV_ESCAPE_NOBACKSLASH
144 =for apidoc Amnh||PERL_PV_ESCAPE_NOCLEAR
145 =for apidoc Amnh||PERL_PV_ESCAPE_NONASCII
146 =for apidoc Amnh||PERL_PV_ESCAPE_QUOTE
147 =for apidoc Amnh||PERL_PV_ESCAPE_RE
148 =for apidoc Amnh||PERL_PV_ESCAPE_UNI
149 =for apidoc Amnh||PERL_PV_ESCAPE_UNI_DETECT
150 =for apidoc Amnh||PERL_PV_ESCAPE_NON_WC
154 Unused or not for public use
155 =for apidoc Cmnh||PERL_PV_PRETTY_REGPROP
156 =for apidoc Cmnh||PERL_PV_PRETTY_DUMP
157 =for apidoc Cmnh||PERL_PV_PRETTY_NOCLEAR
161 #define PV_ESCAPE_OCTBUFSIZE 32
163 #define PV_BYTE_HEX_UC "x%02" UVXf
164 #define PV_BYTE_HEX_LC "x%02" UVxf
167 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
168 const STRLEN count, STRLEN max,
169 STRLEN * const escaped, U32 flags )
172 bool use_uc_hex = false;
173 if (flags & PERL_PV_ESCAPE_DWIM_ALL_HEX) {
175 flags |= PERL_PV_ESCAPE_DWIM;
178 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
179 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
183 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
184 STRLEN wrote = 0; /* chars written so far */
185 STRLEN chsize = 0; /* size of data to be written */
186 STRLEN readsize = 1; /* size of data just read */
187 bool isuni= (flags & PERL_PV_ESCAPE_UNI)
188 ? TRUE : FALSE; /* is this UTF-8 */
189 const char *pv = str;
190 const char * const end = pv + count; /* end of string */
191 const char *restart = NULL;
192 STRLEN extra_len = 0;
194 if ((flags & PERL_PV_ESCAPE_TRUNC_MIDDLE) && max > 3) {
195 if (flags & PERL_PV_ESCAPE_QUOTE) {
198 } else if (flags & PERL_PV_PRETTY_LTGT) {
207 restart = isuni ? (char *)utf8_hop_back((U8*)end,-tail,(U8*)pv) : end - tail;
221 PERL_ARGS_ASSERT_PV_ESCAPE;
223 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
224 /* This won't alter the UTF-8 flag */
228 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
231 for ( ; pv < end ; pv += readsize ) {
232 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
234 const char *source_buf = octbuf;
237 || (flags & PERL_PV_ESCAPE_ALL)
238 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
240 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
241 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
244 if ((flags & PERL_PV_ESCAPE_NON_WC) && isWORDCHAR_uvchr(u)) {
249 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
250 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
251 ? ( use_uc_hex ? ("%c" PV_BYTE_HEX_UC) : ("%c" PV_BYTE_HEX_LC) )
252 : "%cx{%02" UVxf "}", esc, u);
254 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
257 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
261 case '\\' : /* FALLTHROUGH */
262 case '%' : if ( c == esc ) {
268 case '\v' : octbuf[1] = 'v'; break;
269 case '\t' : octbuf[1] = 't'; break;
270 case '\r' : octbuf[1] = 'r'; break;
271 case '\n' : octbuf[1] = 'n'; break;
272 case '\f' : octbuf[1] = 'f'; break;
280 if ( (flags & PERL_PV_ESCAPE_DWIM_ALL_HEX) || ((flags & PERL_PV_ESCAPE_DWIM) && c != '\0') ) {
281 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
282 isuni ? "%cx{%02" UVxf "}" : ( use_uc_hex ? ("%c" PV_BYTE_HEX_UC) : ("%c" PV_BYTE_HEX_LC) ),
285 else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
286 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
289 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 if (max && (wrote + chsize > max)) {
298 /* this only happens with PERL_PV_ESCAPE_TRUNC_MIDDLE */
300 Perl_sv_catpvf( aTHX_ dsv,"%s...%s", qe, qs);
309 } else if (chsize > 1) {
311 sv_catpvn(dsv, source_buf, chsize);
314 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
315 can be appended raw to the dsv. If dsv happens to be
316 UTF-8 then we need catpvf to upgrade them for us.
317 Or add a new API call sv_catpvc(). Think about that name, and
318 how to keep it clear that it's unlike the s of catpvs, which is
319 really an array of octets, not a string. */
321 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
324 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
329 return dsv ? SvPVX(dsv) : NULL;
332 =for apidoc pv_pretty
334 Converts a string into something presentable, handling escaping via
335 C<pv_escape()> and supporting quoting and ellipses.
337 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
338 double quoted with any double quotes in the string escaped. Otherwise
339 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
342 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
343 string were output then an ellipsis C<...> will be appended to the
344 string. Note that this happens AFTER it has been quoted.
346 If C<start_color> is non-null then it will be inserted after the opening
347 quote (if there is one) but before the escaped text. If C<end_color>
348 is non-null then it will be inserted after the escaped text but before
349 any quotes or ellipses.
351 Returns a pointer to the prettified text as held by C<dsv>.
353 =for apidoc Amnh||PERL_PV_PRETTY_QUOTE
354 =for apidoc Amnh||PERL_PV_PRETTY_LTGT
355 =for apidoc Amnh||PERL_PV_PRETTY_ELLIPSES
361 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
362 const STRLEN max, char const * const start_color, char const * const end_color,
365 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
366 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
368 STRLEN max_adjust= 0;
371 PERL_ARGS_ASSERT_PV_PRETTY;
373 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
374 /* This won't alter the UTF-8 flag */
377 orig_cur= SvCUR(dsv);
380 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
382 if ( start_color != NULL )
383 sv_catpv(dsv, start_color);
385 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
388 assert(max > max_adjust);
389 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
390 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
392 assert(max > max_adjust);
395 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
397 if ( end_color != NULL )
398 sv_catpv(dsv, end_color);
401 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
403 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
404 sv_catpvs(dsv, "...");
406 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
407 while( SvCUR(dsv) - orig_cur < max )
415 _pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags)
417 PERL_ARGS_ASSERT_PV_DISPLAY;
419 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP | pretty_flags );
420 if (len > cur && pv[cur] == '\0')
421 sv_catpvs( dsv, "\\0");
426 =for apidoc pv_display
430 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
432 except that an additional "\0" will be appended to the string when
433 len > cur and pv[cur] is "\0".
435 Note that the final string may be up to 7 chars longer than pvlim.
441 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
443 return _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, 0);
455 Perl_sv_peek(pTHX_ SV *sv)
457 SV * const t = sv_newmortal();
464 sv_catpvs(t, "VOID");
467 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
468 /* detect data corruption under memory poisoning */
469 sv_catpvs(t, "WILD");
472 else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
473 || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
475 if (sv == &PL_sv_undef) {
476 sv_catpvs(t, "SV_UNDEF");
477 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
478 SVs_GMG|SVs_SMG|SVs_RMG)) &&
482 else if (sv == &PL_sv_no) {
483 sv_catpvs(t, "SV_NO");
484 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
486 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
492 else if (sv == &PL_sv_yes) {
493 sv_catpvs(t, "SV_YES");
494 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
495 SVs_GMG|SVs_SMG|SVs_RMG)) &&
496 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
499 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
503 else if (sv == &PL_sv_zero) {
504 sv_catpvs(t, "SV_ZERO");
505 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
506 SVs_GMG|SVs_SMG|SVs_RMG)) &&
507 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
510 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
515 sv_catpvs(t, "SV_PLACEHOLDER");
516 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
517 SVs_GMG|SVs_SMG|SVs_RMG)) &&
523 else if (SvREFCNT(sv) == 0) {
527 else if (DEBUG_R_TEST_) {
530 /* is this SV on the tmps stack? */
531 for (ix=PL_tmps_ix; ix>=0; ix--) {
532 if (PL_tmps_stack[ix] == sv) {
537 if (is_tmp || SvREFCNT(sv) > 1) {
538 Perl_sv_catpvf(aTHX_ t, "<");
539 if (SvREFCNT(sv) > 1)
540 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
542 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
543 Perl_sv_catpvf(aTHX_ t, ">");
549 if (SvCUR(t) + unref > 10) {
550 SvCUR_set(t, unref + 3);
559 if (type == SVt_PVCV) {
560 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
562 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
563 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
566 } else if (type < SVt_LAST) {
567 sv_catpv(t, svshorttypenames[type]);
569 if (type == SVt_NULL)
572 sv_catpvs(t, "FREED");
577 if (!SvPVX_const(sv))
578 sv_catpvs(t, "(null)");
580 SV * const tmp = newSVpvs("");
584 SvOOK_offset(sv, delta);
585 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
587 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
589 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
590 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
592 SvREFCNT_dec_NN(tmp);
595 else if (SvNOKp(sv)) {
596 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
597 STORE_LC_NUMERIC_SET_STANDARD();
598 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
599 RESTORE_LC_NUMERIC();
601 else if (SvIOKp(sv)) {
603 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
605 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
613 if (TAINTING_get && sv && SvTAINTED(sv))
614 sv_catpvs(t, " [tainted]");
615 return SvPV_nolen(t);
619 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
622 PERL_ARGS_ASSERT_DUMP_INDENT;
624 dump_vindent(level, file, pat, &args);
629 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
631 PERL_ARGS_ASSERT_DUMP_VINDENT;
632 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
633 PerlIO_vprintf(file, pat, *args);
637 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
638 * for each indent level as appropriate.
640 * bar contains bits indicating which indent columns should have a
641 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
642 * levels than bits in bar, then the first few indents are displayed
645 * The start of a new op is signalled by passing a value for level which
646 * has been negated and offset by 1 (so that level 0 is passed as -1 and
647 * can thus be distinguished from -0); in this case, emit a suitably
648 * indented blank line, then on the next line, display the op's sequence
649 * number, and make the final indent an '+----'.
653 * | FOO # level = 1, bar = 0b1
654 * | | # level =-2-1, bar = 0b11
656 * | BAZ # level = 2, bar = 0b10
660 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
661 const char* pat, ...)
665 bool newop = (level < 0);
669 /* start displaying a new op? */
671 UV seq = sequence_num(o);
675 /* output preceding blank line */
676 PerlIO_puts(file, " ");
677 for (i = level-1; i >= 0; i--)
678 PerlIO_puts(file, ( i == 0
679 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
682 PerlIO_puts(file, "\n");
684 /* output sequence number */
686 PerlIO_printf(file, "%-4" UVuf " ", seq);
688 PerlIO_puts(file, "???? ");
692 PerlIO_printf(file, " ");
694 for (i = level-1; i >= 0; i--)
696 (i == 0 && newop) ? "+--"
697 : (bar & (1 << i)) ? "| "
699 PerlIO_vprintf(file, pat, args);
704 /* display a link field (e.g. op_next) in the format
705 * ====> sequence_number [opname 0x123456]
709 S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file)
711 PerlIO_puts(file, " ===> ");
713 PerlIO_puts(file, "[SELF]\n");
715 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
716 sequence_num(o), OP_NAME(o), PTR2UV(o));
718 PerlIO_puts(file, "[0x0]\n");
722 =for apidoc_section $debugging
725 Dumps the entire optree of the current program starting at C<PL_main_root> to
726 C<STDERR>. Also dumps the optrees for all visible subroutines in
735 dump_all_perl(FALSE);
739 Perl_dump_all_perl(pTHX_ bool justperl)
741 PerlIO_setlinebuf(Perl_debug_log);
743 op_dump(PL_main_root);
744 dump_packsubs_perl(PL_defstash, justperl);
748 =for apidoc dump_packsubs
750 Dumps the optrees for all visible subroutines in C<stash>.
756 Perl_dump_packsubs(pTHX_ const HV *stash)
758 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
759 dump_packsubs_perl(stash, FALSE);
763 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
767 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
769 if (!HvTOTALKEYS(stash))
771 for (i = 0; i <= (I32) HvMAX(stash); i++) {
773 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
774 GV * gv = (GV *)HeVAL(entry);
775 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
776 /* unfake a fake GV */
777 (void)CvGV(SvRV(gv));
778 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
781 dump_sub_perl(gv, justperl);
784 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
785 const HV * const hv = GvHV(gv);
786 if (hv && (hv != PL_defstash))
787 dump_packsubs_perl(hv, justperl); /* nested package */
794 Perl_dump_sub(pTHX_ const GV *gv)
796 PERL_ARGS_ASSERT_DUMP_SUB;
797 dump_sub_perl(gv, FALSE);
801 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
805 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
807 cv = isGV_with_GP(gv) ? GvCV(gv) :
808 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
809 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
812 if (isGV_with_GP(gv)) {
813 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
814 SV *escsv = newSVpvs_flags("", SVs_TEMP);
817 gv_fullname3(namesv, gv, NULL);
818 namepv = SvPV_const(namesv, namelen);
819 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
820 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
822 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
825 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
827 (int)CvXSUBANY(cv).any_i32);
831 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
835 =for apidoc dump_form
837 Dumps the contents of the format contained in the GV C<gv> to C<STDERR>, or a
838 message that one doesn't exist.
844 Perl_dump_form(pTHX_ const GV *gv)
846 SV * const sv = sv_newmortal();
848 PERL_ARGS_ASSERT_DUMP_FORM;
850 gv_fullname3(sv, gv, NULL);
851 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
852 if (CvROOT(GvFORM(gv)))
853 op_dump(CvROOT(GvFORM(gv)));
855 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
861 op_dump(PL_eval_root);
865 /* returns a temp SV displaying the name of a GV. Handles the case where
866 * a GV is in fact a ref to a CV */
869 S_gv_display(pTHX_ GV *gv)
871 SV * const name = newSVpvs_flags("", SVs_TEMP);
873 SV * const raw = newSVpvs_flags("", SVs_TEMP);
877 if (isGV_with_GP(gv))
878 gv_fullname3(raw, gv, NULL);
881 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
882 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
883 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
885 rawpv = SvPV_const(raw, len);
886 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
889 sv_catpvs(name, "(NULL)");
898 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
902 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
909 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
912 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
913 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
914 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
917 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
919 if (pm->op_pmflags || PM_GETRE(pm)) {
920 SV * const tmpsv = pm_description(pm);
921 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
922 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
923 SvREFCNT_dec_NN(tmpsv);
926 if (pm->op_type == OP_SPLIT)
927 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
928 "TARGOFF/GV = 0x%" UVxf "\n",
929 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
931 if (pm->op_pmreplrootu.op_pmreplroot) {
932 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
933 S_do_op_dump_bar(aTHX_ level + 2,
934 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
935 file, pm->op_pmreplrootu.op_pmreplroot);
939 if (pm->op_code_list) {
940 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
941 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
942 S_do_op_dump_bar(aTHX_ level + 2,
943 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
944 file, pm->op_code_list);
947 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
948 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
954 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
956 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
957 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
961 const struct flag_to_name pmflags_flags_names[] = {
962 {PMf_CONST, ",CONST"},
964 {PMf_GLOBAL, ",GLOBAL"},
965 {PMf_CONTINUE, ",CONTINUE"},
966 {PMf_RETAINT, ",RETAINT"},
968 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
969 {PMf_HAS_CV, ",HAS_CV"},
970 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
971 {PMf_IS_QR, ",IS_QR"}
975 S_pm_description(pTHX_ const PMOP *pm)
977 SV * const desc = newSVpvs("");
978 const REGEXP * const regex = PM_GETRE(pm);
979 const U32 pmflags = pm->op_pmflags;
981 PERL_ARGS_ASSERT_PM_DESCRIPTION;
983 if (pmflags & PMf_ONCE)
984 sv_catpvs(desc, ",ONCE");
986 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
987 sv_catpvs(desc, ":USED");
989 if (pmflags & PMf_USED)
990 sv_catpvs(desc, ":USED");
994 if (RX_ISTAINTED(regex))
995 sv_catpvs(desc, ",TAINTED");
996 if (RX_CHECK_SUBSTR(regex)) {
997 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
998 sv_catpvs(desc, ",SCANFIRST");
999 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
1000 sv_catpvs(desc, ",ALL");
1002 if (RX_EXTFLAGS(regex) & RXf_START_ONLY)
1003 sv_catpvs(desc, ",START_ONLY");
1004 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
1005 sv_catpvs(desc, ",SKIPWHITE");
1006 if (RX_EXTFLAGS(regex) & RXf_WHITE)
1007 sv_catpvs(desc, ",WHITE");
1008 if (RX_EXTFLAGS(regex) & RXf_NULL)
1009 sv_catpvs(desc, ",NULL");
1012 append_flags(desc, pmflags, pmflags_flags_names);
1017 =for apidoc pmop_dump
1019 Dump an OP that is related to Pattern Matching, such as C<s/foo/bar/>; these require
1026 Perl_pmop_dump(pTHX_ PMOP *pm)
1028 do_pmop_dump(0, Perl_debug_log, pm);
1031 /* Return a unique integer to represent the address of op o.
1032 * If it already exists in PL_op_sequence, just return it;
1034 * *** Note that this isn't thread-safe */
1037 S_sequence_num(pTHX_ const OP *o)
1045 op = newSVuv(PTR2UV(o));
1047 key = SvPV_const(op, len);
1048 if (!PL_op_sequence)
1049 PL_op_sequence = newHV();
1050 seq = hv_fetch(PL_op_sequence, key, len, TRUE);
1053 sv_setuv(*seq, ++PL_op_seq);
1061 const struct flag_to_name op_flags_names[] = {
1062 {OPf_KIDS, ",KIDS"},
1063 {OPf_PARENS, ",PARENS"},
1066 {OPf_STACKED, ",STACKED"},
1067 {OPf_SPECIAL, ",SPECIAL"}
1071 /* indexed by enum OPclass */
1072 const char * const op_class_names[] = {
1090 /* dump an op and any children. level indicates the initial indent.
1091 * The bits of bar indicate which indents should receive a vertical bar.
1092 * For example if level == 5 and bar == 0b01101, then the indent prefix
1093 * emitted will be (not including the <>'s):
1096 * 55554444333322221111
1098 * For heavily nested output, the level may exceed the number of bits
1099 * in bar; in this case the first few columns in the output will simply
1100 * not have a bar, which is harmless.
1104 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
1106 const OPCODE optype = o->op_type;
1108 PERL_ARGS_ASSERT_DO_OP_DUMP;
1110 /* print op header line */
1112 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
1114 if (optype == OP_NULL && o->op_targ)
1115 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
1117 PerlIO_printf(file, " %s(0x%" UVxf ")",
1118 op_class_names[op_class(o)], PTR2UV(o));
1119 S_opdump_link(aTHX_ o, o->op_next, file);
1121 /* print op common fields */
1124 S_opdump_indent(aTHX_ o, level, bar, file, "PARENT");
1125 S_opdump_link(aTHX_ o, op_parent((OP*)o), file);
1127 else if (!OpHAS_SIBLING(o)) {
1129 OP *p = o->op_sibparent;
1130 if (!p || !(p->op_flags & OPf_KIDS))
1133 OP *kid = cUNOPx(p)->op_first;
1135 kid = OpSIBLING(kid);
1143 S_opdump_indent(aTHX_ o, level, bar, file,
1144 "*** WILD PARENT 0x%p\n", p);
1148 if (o->op_targ && optype != OP_NULL)
1149 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1152 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1153 SV * const tmpsv = newSVpvs("");
1154 switch (o->op_flags & OPf_WANT) {
1156 sv_catpvs(tmpsv, ",VOID");
1158 case OPf_WANT_SCALAR:
1159 sv_catpvs(tmpsv, ",SCALAR");
1162 sv_catpvs(tmpsv, ",LIST");
1165 sv_catpvs(tmpsv, ",UNKNOWN");
1168 append_flags(tmpsv, o->op_flags, op_flags_names);
1169 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1170 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1171 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1172 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1173 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1174 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1175 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1178 if (o->op_private) {
1179 U16 oppriv = o->op_private;
1180 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1185 tmpsv = newSVpvs("");
1186 for (; !stop; op_ix++) {
1187 U16 entry = PL_op_private_bitdefs[op_ix];
1188 U16 bit = (entry >> 2) & 7;
1189 U16 ix = entry >> 5;
1195 I16 const *p = &PL_op_private_bitfields[ix];
1196 U16 bitmin = (U16) *p++;
1203 for (i = bitmin; i<= bit; i++)
1206 val = (oppriv & mask);
1209 && PL_op_private_labels[label] == '-'
1210 && PL_op_private_labels[label+1] == '\0'
1212 /* display as raw number */
1225 if (val == 0 && enum_label == -1)
1226 /* don't display anonymous zero values */
1229 sv_catpvs(tmpsv, ",");
1231 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1232 sv_catpvs(tmpsv, "=");
1234 if (enum_label == -1)
1235 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1237 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1242 if ( oppriv & (1<<bit)
1243 && !(PL_op_private_labels[ix] == '-'
1244 && PL_op_private_labels[ix+1] == '\0'))
1247 sv_catpvs(tmpsv, ",");
1248 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1253 sv_catpvs(tmpsv, ",");
1254 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1257 if (tmpsv && SvCUR(tmpsv)) {
1258 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1259 SvPVX_const(tmpsv) + 1);
1261 S_opdump_indent(aTHX_ o, level, bar, file,
1262 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1270 S_opdump_indent(aTHX_ o, level, bar, file,
1271 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1273 S_opdump_indent(aTHX_ o, level, bar, file,
1274 "GV = %" SVf " (0x%" UVxf ")\n",
1275 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1281 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1282 UV i, count = items[-1].uv;
1284 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1285 for (i=0; i < count; i++)
1286 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1287 "%" UVuf " => 0x%" UVxf "\n",
1292 case OP_MULTICONCAT:
1293 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
1294 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
1295 /* XXX really ought to dump each field individually,
1296 * but that's too much like hard work */
1297 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1298 SVfARG(multiconcat_stringify(o)));
1303 case OP_METHOD_NAMED:
1304 case OP_METHOD_SUPER:
1305 case OP_METHOD_REDIR:
1306 case OP_METHOD_REDIR_SUPER:
1307 #ifndef USE_ITHREADS
1308 /* with ITHREADS, consts are stored in the pad, and the right pad
1309 * may not be active here, so skip */
1310 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1311 SvPEEK(cMETHOPo_meth));
1315 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1321 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1322 (UV)CopLINE(cCOPo));
1324 if (CopSTASHPV(cCOPo)) {
1325 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1326 HV *stash = CopSTASH(cCOPo);
1327 const char * const hvname = HvNAME_get(stash);
1329 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1330 generic_pv_escape(tmpsv, hvname,
1331 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1334 if (CopLABEL(cCOPo)) {
1335 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1338 const char *label = CopLABEL_len_flags(cCOPo,
1339 &label_len, &label_flags);
1340 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1341 generic_pv_escape( tmpsv, label, label_len,
1342 (label_flags & SVf_UTF8)));
1345 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1346 (unsigned int)cCOPo->cop_seq);
1351 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1352 S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file);
1353 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1354 S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file);
1355 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1356 S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file);
1376 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1377 S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
1383 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1391 if (o->op_private & OPpREFCOUNTED)
1392 S_opdump_indent(aTHX_ o, level, bar, file,
1393 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1401 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1404 SV * const label = newSVpvs_flags("", SVs_TEMP);
1405 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1406 S_opdump_indent(aTHX_ o, level, bar, file,
1407 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1408 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1414 if (o->op_private & OPpTRANS_USE_SVOP) {
1415 /* utf8: table stored as an inversion map */
1416 #ifndef USE_ITHREADS
1417 /* with ITHREADS, it is stored in the pad, and the right pad
1418 * may not be active here, so skip */
1419 S_opdump_indent(aTHX_ o, level, bar, file,
1420 "INVMAP = 0x%" UVxf "\n",
1421 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1425 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1426 SSize_t i, size = tbl->size;
1428 S_opdump_indent(aTHX_ o, level, bar, file,
1429 "TABLE = 0x%" UVxf "\n",
1431 S_opdump_indent(aTHX_ o, level, bar, file,
1432 " SIZE: 0x%" UVxf "\n", (UV)size);
1434 /* dump size+1 values, to include the extra slot at the end */
1435 for (i = 0; i <= size; i++) {
1436 short val = tbl->map[i];
1438 S_opdump_indent(aTHX_ o, level, bar, file,
1439 " %4" UVxf ":", (UV)i);
1441 PerlIO_printf(file, " %2" IVdf, (IV)val);
1443 PerlIO_printf(file, " %02" UVxf, (UV)val);
1445 if ( i == size || (i & 0xf) == 0xf)
1446 PerlIO_printf(file, "\n");
1455 if (o->op_flags & OPf_KIDS) {
1459 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1460 S_do_op_dump_bar(aTHX_ level,
1461 (bar | cBOOL(OpHAS_SIBLING(kid))),
1468 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1470 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1477 Dumps the optree starting at OP C<o> to C<STDERR>.
1483 Perl_op_dump(pTHX_ const OP *o)
1485 PERL_ARGS_ASSERT_OP_DUMP;
1486 do_op_dump(0, Perl_debug_log, o);
1492 Dump the name and, if they differ, the effective name of the GV C<gv> to
1499 Perl_gv_dump(pTHX_ GV *gv)
1503 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1506 PerlIO_printf(Perl_debug_log, "{}\n");
1509 sv = sv_newmortal();
1510 PerlIO_printf(Perl_debug_log, "{\n");
1511 gv_fullname3(sv, gv, NULL);
1512 name = SvPV_const(sv, len);
1513 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1514 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1515 if (gv != GvEGV(gv)) {
1516 gv_efullname3(sv, GvEGV(gv), NULL);
1517 name = SvPV_const(sv, len);
1518 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1519 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1521 (void)PerlIO_putc(Perl_debug_log, '\n');
1522 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1526 /* map magic types to the symbolic names
1527 * (with the PERL_MAGIC_ prefixed stripped)
1530 static const struct { const char type; const char *name; } magic_names[] = {
1531 #include "mg_names.inc"
1532 /* this null string terminates the list */
1537 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1539 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1541 for (; mg; mg = mg->mg_moremagic) {
1542 Perl_dump_indent(aTHX_ level, file,
1543 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1544 if (mg->mg_virtual) {
1545 const MGVTBL * const v = mg->mg_virtual;
1546 if (v >= PL_magic_vtables
1547 && v < PL_magic_vtables + magic_vtable_max) {
1548 const U32 i = v - PL_magic_vtables;
1549 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1552 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1553 UVxf "\n", PTR2UV(v));
1556 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1559 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1563 const char *name = NULL;
1564 for (n = 0; magic_names[n].name; n++) {
1565 if (mg->mg_type == magic_names[n].type) {
1566 name = magic_names[n].name;
1571 Perl_dump_indent(aTHX_ level, file,
1572 " MG_TYPE = PERL_MAGIC_%s\n", name);
1574 Perl_dump_indent(aTHX_ level, file,
1575 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1579 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1580 if (mg->mg_type == PERL_MAGIC_envelem &&
1581 mg->mg_flags & MGf_TAINTEDDIR)
1582 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1583 if (mg->mg_type == PERL_MAGIC_regex_global &&
1584 mg->mg_flags & MGf_MINMATCH)
1585 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1586 if (mg->mg_flags & MGf_REFCOUNTED)
1587 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1588 if (mg->mg_flags & MGf_GSKIP)
1589 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1590 if (mg->mg_flags & MGf_COPY)
1591 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1592 if (mg->mg_flags & MGf_DUP)
1593 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1594 if (mg->mg_flags & MGf_LOCAL)
1595 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1596 if (mg->mg_type == PERL_MAGIC_regex_global &&
1597 mg->mg_flags & MGf_BYTES)
1598 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1601 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1602 PTR2UV(mg->mg_obj));
1603 if (mg->mg_type == PERL_MAGIC_qr) {
1604 REGEXP* const re = (REGEXP *)mg->mg_obj;
1605 SV * const dsv = sv_newmortal();
1606 const char * const s
1607 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1609 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1610 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1612 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1613 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1616 if (mg->mg_flags & MGf_REFCOUNTED)
1617 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1620 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1622 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1623 if (mg->mg_len >= 0) {
1624 if (mg->mg_type != PERL_MAGIC_utf8) {
1625 SV * const sv = newSVpvs("");
1626 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1627 SvREFCNT_dec_NN(sv);
1630 else if (mg->mg_len == HEf_SVKEY) {
1631 PerlIO_puts(file, " => HEf_SVKEY\n");
1632 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1633 maxnest, dumpops, pvlim); /* MG is already +1 */
1636 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1641 " does not know how to handle this MG_LEN"
1643 (void)PerlIO_putc(file, '\n');
1645 if (mg->mg_type == PERL_MAGIC_utf8) {
1646 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1649 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1650 Perl_dump_indent(aTHX_ level, file,
1651 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1654 (UV)cache[i * 2 + 1]);
1661 =for apidoc magic_dump
1663 Dumps the contents of the MAGIC C<mg> to C<STDERR>.
1669 Perl_magic_dump(pTHX_ const MAGIC *mg)
1671 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1675 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1679 PERL_ARGS_ASSERT_DO_HV_DUMP;
1681 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1682 if (sv && (hvname = HvNAME_get(sv)))
1684 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1685 name which quite legally could contain insane things like tabs, newlines, nulls or
1686 other scary crap - this should produce sane results - except maybe for unicode package
1687 names - but we will wait for someone to file a bug on that - demerphq */
1688 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1689 PerlIO_printf(file, "\t\"%s\"\n",
1690 generic_pv_escape( tmpsv, hvname,
1691 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1694 (void)PerlIO_putc(file, '\n');
1698 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1700 PERL_ARGS_ASSERT_DO_GV_DUMP;
1702 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1703 if (sv && GvNAME(sv)) {
1704 SV * const tmpsv = newSVpvs("");
1705 PerlIO_printf(file, "\t\"%s\"\n",
1706 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1709 (void)PerlIO_putc(file, '\n');
1713 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1715 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1717 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1718 if (sv && GvNAME(sv)) {
1719 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1721 HV * const stash = GvSTASH(sv);
1722 PerlIO_printf(file, "\t");
1723 /* TODO might have an extra \" here */
1724 if (stash && (hvname = HvNAME_get(stash))) {
1725 PerlIO_printf(file, "\"%s\" :: \"",
1726 generic_pv_escape(tmp, hvname,
1727 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1729 PerlIO_printf(file, "%s\"\n",
1730 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1733 (void)PerlIO_putc(file, '\n');
1736 const struct flag_to_name first_sv_flags_names[] = {
1737 {SVs_TEMP, "TEMP,"},
1738 {SVs_OBJECT, "OBJECT,"},
1747 const struct flag_to_name second_sv_flags_names[] = {
1749 {SVf_FAKE, "FAKE,"},
1750 {SVf_READONLY, "READONLY,"},
1751 {SVf_PROTECT, "PROTECT,"},
1752 {SVf_BREAK, "BREAK,"},
1758 const struct flag_to_name cv_flags_names[] = {
1759 {CVf_ANON, "ANON,"},
1760 {CVf_UNIQUE, "UNIQUE,"},
1761 {CVf_CLONE, "CLONE,"},
1762 {CVf_CLONED, "CLONED,"},
1763 {CVf_CONST, "CONST,"},
1764 {CVf_NODEBUG, "NODEBUG,"},
1765 {CVf_LVALUE, "LVALUE,"},
1766 {CVf_NOWARN_AMBIGUOUS, "NOWARN_AMBIGUOUS,"},
1767 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1768 {CVf_CVGV_RC, "CVGV_RC,"},
1769 {CVf_DYNFILE, "DYNFILE,"},
1770 {CVf_AUTOLOAD, "AUTOLOAD,"},
1771 {CVf_HASEVAL, "HASEVAL,"},
1772 {CVf_SLABBED, "SLABBED,"},
1773 {CVf_NAMED, "NAMED,"},
1774 {CVf_LEXICAL, "LEXICAL,"},
1775 {CVf_ISXSUB, "ISXSUB,"}
1778 const struct flag_to_name hv_flags_names[] = {
1779 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1780 {SVphv_LAZYDEL, "LAZYDEL,"},
1781 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1782 {SVf_AMAGIC, "OVERLOAD,"},
1783 {SVphv_CLONEABLE, "CLONEABLE,"}
1786 const struct flag_to_name gp_flags_names[] = {
1787 {GVf_INTRO, "INTRO,"},
1788 {GVf_MULTI, "MULTI,"},
1789 {GVf_ASSUMECV, "ASSUMECV,"},
1792 const struct flag_to_name gp_flags_imported_names[] = {
1793 {GVf_IMPORTED_SV, " SV"},
1794 {GVf_IMPORTED_AV, " AV"},
1795 {GVf_IMPORTED_HV, " HV"},
1796 {GVf_IMPORTED_CV, " CV"},
1799 /* NOTE: this structure is mostly duplicative of one generated by
1800 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1801 * the two. - Yves */
1802 const struct flag_to_name regexp_extflags_names[] = {
1803 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1804 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1805 {RXf_PMf_FOLD, "PMf_FOLD,"},
1806 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1807 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1808 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1809 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1810 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1811 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1812 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1813 {RXf_CHECK_ALL, "CHECK_ALL,"},
1814 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1815 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1816 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1817 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1818 {RXf_SPLIT, "SPLIT,"},
1819 {RXf_COPY_DONE, "COPY_DONE,"},
1820 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1821 {RXf_TAINTED, "TAINTED,"},
1822 {RXf_START_ONLY, "START_ONLY,"},
1823 {RXf_SKIPWHITE, "SKIPWHITE,"},
1824 {RXf_WHITE, "WHITE,"},
1825 {RXf_NULL, "NULL,"},
1828 /* NOTE: this structure is mostly duplicative of one generated by
1829 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1830 * the two. - Yves */
1831 const struct flag_to_name regexp_core_intflags_names[] = {
1832 {PREGf_SKIP, "SKIP,"},
1833 {PREGf_IMPLICIT, "IMPLICIT,"},
1834 {PREGf_NAUGHTY, "NAUGHTY,"},
1835 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1836 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1837 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1838 {PREGf_NOSCAN, "NOSCAN,"},
1839 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1840 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1841 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1842 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1843 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1846 /* Minimum number of decimal digits to preserve the significand of NV. */
1847 #ifdef USE_LONG_DOUBLE
1848 # ifdef LDBL_DECIMAL_DIG
1849 # define NV_DECIMAL_DIG LDBL_DECIMAL_DIG
1851 #elif defined(USE_QUADMATH) && defined(I_QUADMATH)
1852 # ifdef FLT128_DECIMAL_DIG
1853 # define NV_DECIMAL_DIG FLT128_DECIMAL_DIG
1855 #else /* NV is double */
1856 # ifdef DBL_DECIMAL_DIG
1857 # define NV_DECIMAL_DIG DBL_DECIMAL_DIG
1861 #ifndef NV_DECIMAL_DIG
1862 # if defined(NV_MANT_DIG) && FLT_RADIX == 2
1863 /* NV_DECIMAL_DIG = ceil(1 + NV_MANT_DIG * log10(2)), where log10(2) is
1864 approx. 146/485. This is precise enough up to 2620 bits */
1865 # define NV_DECIMAL_DIG (1 + (NV_MANT_DIG * 146 + 484) / 485)
1869 #ifndef NV_DECIMAL_DIG
1870 # define NV_DECIMAL_DIG (NV_DIG + 3) /* last resort */
1873 /* Perl_do_sv_dump():
1875 * level: amount to indent the output
1876 * sv: the object to dump
1877 * nest: the current level of recursion
1878 * maxnest: the maximum allowed level of recursion
1879 * dumpops: if true, also dump the ops associated with a CV
1880 * pvlim: limit on the length of any strings that are output
1884 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1891 PERL_ARGS_ASSERT_DO_SV_DUMP;
1894 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1898 flags = SvFLAGS(sv);
1901 /* process general SV flags */
1903 d = Perl_newSVpvf(aTHX_
1904 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1905 PTR2UV(SvANY(sv)), PTR2UV(sv),
1906 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1907 (int)(PL_dumpindent*level), "");
1909 if ((flags & SVs_PADSTALE))
1910 sv_catpvs(d, "PADSTALE,");
1911 if ((flags & SVs_PADTMP))
1912 sv_catpvs(d, "PADTMP,");
1913 append_flags(d, flags, first_sv_flags_names);
1914 if (flags & SVf_ROK) {
1915 sv_catpvs(d, "ROK,");
1916 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
1918 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1919 append_flags(d, flags, second_sv_flags_names);
1920 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1921 && type != SVt_PVAV) {
1922 if (SvPCS_IMPORTED(sv))
1923 sv_catpvs(d, "PCS_IMPORTED,");
1925 sv_catpvs(d, "SCREAM,");
1928 /* process type-specific SV flags */
1933 append_flags(d, CvFLAGS(sv), cv_flags_names);
1936 append_flags(d, flags, hv_flags_names);
1940 if (isGV_with_GP(sv)) {
1941 append_flags(d, GvFLAGS(sv), gp_flags_names);
1943 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1944 sv_catpvs(d, "IMPORT");
1945 if (GvIMPORTED(sv) == GVf_IMPORTED)
1946 sv_catpvs(d, "ALL,");
1949 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1950 sv_catpvs(d, " ),");
1956 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1962 /* SVphv_SHAREKEYS is also 0x20000000 */
1963 if ((type != SVt_PVHV) && SvUTF8(sv))
1964 sv_catpvs(d, "UTF8");
1966 if (*(SvEND(d) - 1) == ',') {
1967 SvCUR_set(d, SvCUR(d) - 1);
1968 SvPVX(d)[SvCUR(d)] = '\0';
1973 /* dump initial SV details */
1975 #ifdef DEBUG_LEAKING_SCALARS
1976 Perl_dump_indent(aTHX_ level, file,
1977 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1978 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1980 sv->sv_debug_inpad ? "for" : "by",
1981 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1982 PTR2UV(sv->sv_debug_parent),
1986 Perl_dump_indent(aTHX_ level, file, "SV = ");
1990 if (type < SVt_LAST) {
1991 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1993 if (type == SVt_NULL) {
1998 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
2003 /* Dump general SV fields */
2005 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
2006 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
2007 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2008 || (type == SVt_IV && !SvROK(sv))) {
2011 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
2013 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
2014 (void)PerlIO_putc(file, '\n');
2017 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
2018 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
2019 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
2020 || type == SVt_NV) {
2021 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2022 STORE_LC_NUMERIC_SET_STANDARD();
2023 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DECIMAL_DIG, SvNVX(sv));
2024 RESTORE_LC_NUMERIC();
2028 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
2031 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
2034 if (type < SVt_PV) {
2039 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
2040 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
2041 const bool re = isREGEXP(sv);
2042 const char * const ptr =
2043 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2047 SvOOK_offset(sv, delta);
2048 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
2053 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
2056 PerlIO_printf(file, "( %s . ) ",
2057 _pv_display_for_dump(d, ptr - delta, delta, 0,
2060 if (type == SVt_INVLIST) {
2061 PerlIO_printf(file, "\n");
2062 /* 4 blanks indents 2 beyond the PV, etc */
2063 _invlist_dump(file, level, " ", sv);
2066 PerlIO_printf(file, "%s", _pv_display_for_dump(d, ptr, SvCUR(sv),
2069 if (SvUTF8(sv)) /* the 6? \x{....} */
2070 PerlIO_printf(file, " [UTF8 \"%s\"]",
2071 sv_uni_display(d, sv, 6 * SvCUR(sv),
2074 PerlIO_printf(file, " [BOOL %s]", ptr == PL_Yes ? "PL_Yes" : "PL_No");
2075 PerlIO_printf(file, "\n");
2077 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
2078 if (re && type == SVt_PVLV)
2079 /* LV-as-REGEXP usurps len field to store pointer to
2081 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
2082 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
2084 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
2086 #ifdef PERL_COPY_ON_WRITE
2087 if (SvIsCOW(sv) && SvLEN(sv))
2088 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
2093 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
2096 if (type >= SVt_PVMG) {
2098 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
2100 do_hv_dump(level, file, " STASH", SvSTASH(sv));
2102 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
2103 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
2108 /* Dump type-specific SV fields */
2112 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
2113 PTR2UV(AvARRAY(sv)));
2114 if (AvARRAY(sv) != AvALLOC(sv)) {
2115 PerlIO_printf(file, " (offset=%" IVdf ")\n",
2116 (IV)(AvARRAY(sv) - AvALLOC(sv)));
2117 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
2118 PTR2UV(AvALLOC(sv)));
2121 (void)PerlIO_putc(file, '\n');
2122 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
2124 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2127 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
2128 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
2129 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
2130 SvCUR(d) ? SvPVX_const(d) + 1 : "");
2131 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
2133 SV **svp = AvARRAY(MUTABLE_AV(sv));
2135 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
2138 SV* const elt = *svp;
2139 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
2141 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2148 struct xpvhv_aux *const aux = HvAUX(sv);
2149 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
2150 (UV)aux->xhv_aux_flags);
2152 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
2153 totalkeys = HvTOTALKEYS(MUTABLE_HV(sv));
2155 /* Show distribution of HEs in the ARRAY */
2157 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
2161 U32 keys = totalkeys;
2162 NV theoret, sum = 0;
2164 PerlIO_printf(file, " (");
2165 Zero(freq, FREQ_MAX + 1, int);
2166 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2169 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
2171 if (count > FREQ_MAX)
2177 for (i = 0; i <= max; i++) {
2179 PerlIO_printf(file, "%d%s:%d", i,
2180 (i == FREQ_MAX) ? "+" : "",
2183 PerlIO_printf(file, ", ");
2186 (void)PerlIO_putc(file, ')');
2187 /* The "quality" of a hash is defined as the total number of
2188 comparisons needed to access every element once, relative
2189 to the expected number needed for a random hash.
2191 The total number of comparisons is equal to the sum of
2192 the squares of the number of entries in each bucket.
2193 For a random hash of n keys into k buckets, the expected
2198 for (i = max; i > 0; i--) { /* Precision: count down. */
2199 sum += freq[i] * i * i;
2201 while ((keys = keys >> 1))
2203 theoret = totalkeys;
2204 theoret += theoret * (theoret-1)/pow2;
2205 (void)PerlIO_putc(file, '\n');
2206 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2207 NVff "%%", theoret/sum*100);
2209 (void)PerlIO_putc(file, '\n');
2210 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2214 HE **ents = HvARRAY(sv);
2217 HE *const *const last = ents + HvMAX(sv);
2218 count = last + 1 - ents;
2223 } while (++ents <= last);
2226 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2229 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2232 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2233 (IV)HvRITER_get(sv));
2234 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2235 PTR2UV(HvEITER_get(sv)));
2236 #ifdef PERL_HASH_RANDOMIZE_KEYS
2237 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2238 (UV)HvRAND_get(sv));
2239 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2240 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2241 (UV)HvLASTRAND_get(sv));
2244 (void)PerlIO_putc(file, '\n');
2247 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2248 if (mg && mg->mg_obj) {
2249 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2253 const char * const hvname = HvNAME_get(sv);
2255 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2256 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2257 generic_pv_escape( tmpsv, hvname,
2258 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2263 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2264 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2265 if (HvAUX(sv)->xhv_name_count)
2266 Perl_dump_indent(aTHX_
2267 level, file, " NAMECOUNT = %" IVdf "\n",
2268 (IV)HvAUX(sv)->xhv_name_count
2270 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2271 const I32 count = HvAUX(sv)->xhv_name_count;
2273 SV * const names = newSVpvs_flags("", SVs_TEMP);
2274 /* The starting point is the first element if count is
2275 positive and the second element if count is negative. */
2276 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2277 + (count < 0 ? 1 : 0);
2278 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2279 + (count < 0 ? -count : count);
2280 while (hekp < endp) {
2282 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2283 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2284 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2286 /* This should never happen. */
2287 sv_catpvs(names, ", (null)");
2291 Perl_dump_indent(aTHX_
2292 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2296 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2297 const char *const hvename = HvENAME_get(sv);
2298 Perl_dump_indent(aTHX_
2299 level, file, " ENAME = \"%s\"\n",
2300 generic_pv_escape(tmp, hvename,
2301 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2305 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2307 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2311 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2312 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2314 generic_pv_escape( tmpsv, meta->mro_which->name,
2315 meta->mro_which->length,
2316 (meta->mro_which->kflags & HVhek_UTF8)),
2317 PTR2UV(meta->mro_which));
2318 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2320 (UV)meta->cache_gen);
2321 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2323 if (meta->mro_linear_all) {
2324 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2326 PTR2UV(meta->mro_linear_all));
2327 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2330 if (meta->mro_linear_current) {
2331 Perl_dump_indent(aTHX_ level, file,
2332 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2333 PTR2UV(meta->mro_linear_current));
2334 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2337 if (meta->mro_nextmethod) {
2338 Perl_dump_indent(aTHX_ level, file,
2339 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2340 PTR2UV(meta->mro_nextmethod));
2341 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2345 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2347 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2352 if (nest < maxnest) {
2353 HV * const hv = MUTABLE_HV(sv);
2355 if (HvTOTALKEYS(hv)) {
2357 int count = maxnest - nest;
2358 for (i=0; i <= HvMAX(hv); i++) {
2360 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2367 if (count-- <= 0) goto DONEHV;
2370 keysv = hv_iterkeysv(he);
2371 keypv = SvPV_const(keysv, len);
2374 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display_for_dump(d, keypv, len, 0, pvlim));
2376 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2377 if (HvEITER_get(hv) == he)
2378 PerlIO_printf(file, "[CURRENT] ");
2379 PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
2381 if (sv == (SV*)PL_strtab)
2382 PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
2383 (UV)he->he_valu.hent_refcount );
2385 (void)PerlIO_putc(file, '\n');
2386 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2394 } /* case SVt_PVHV */
2397 if (CvAUTOLOAD(sv)) {
2398 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2400 const char *const name = SvPV_const(sv, len);
2401 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2402 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2405 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2406 const char *const proto = CvPROTO(sv);
2407 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2408 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2413 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2414 if (!CvISXSUB(sv)) {
2417 Perl_dump_indent(aTHX_ level, file,
2418 " SLAB = 0x%" UVxf "\n",
2419 PTR2UV(CvSTART(sv)));
2421 Perl_dump_indent(aTHX_ level, file,
2422 " START = 0x%" UVxf " ===> %" IVdf "\n",
2423 PTR2UV(CvSTART(sv)),
2424 (IV)sequence_num(CvSTART(sv)));
2426 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2427 PTR2UV(CvROOT(sv)));
2428 if (CvROOT(sv) && dumpops) {
2429 do_op_dump(level+1, file, CvROOT(sv));
2432 SV * const constant = cv_const_sv((const CV *)sv);
2434 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2437 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2439 PTR2UV(CvXSUBANY(sv).any_ptr));
2440 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2443 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2444 (IV)CvXSUBANY(sv).any_i32);
2448 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2449 HEK_KEY(CvNAME_HEK((CV *)sv)));
2450 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2451 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2452 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2453 IVdf "\n", (IV)CvDEPTH(sv));
2454 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2456 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2457 if (!CvISXSUB(sv)) {
2458 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2459 if (nest < maxnest) {
2460 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2464 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2466 const CV * const outside = CvOUTSIDE(sv);
2467 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2470 : CvANON(outside) ? "ANON"
2471 : (outside == PL_main_cv) ? "MAIN"
2472 : CvUNIQUE(outside) ? "UNIQUE"
2475 newSVpvs_flags("", SVs_TEMP),
2476 GvNAME(CvGV(outside)),
2477 GvNAMELEN(CvGV(outside)),
2478 GvNAMEUTF8(CvGV(outside)))
2482 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2483 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2488 if (type == SVt_PVLV) {
2489 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2490 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2491 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2492 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2493 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2494 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2495 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2498 if (isREGEXP(sv)) goto dumpregexp;
2499 if (!isGV_with_GP(sv))
2502 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2503 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2504 generic_pv_escape(tmpsv, GvNAME(sv),
2508 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2509 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2510 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2511 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2514 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2515 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2516 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2517 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2518 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2519 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2520 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2521 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2522 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2526 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2527 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2528 do_gv_dump (level, file, " EGV", GvEGV(sv));
2531 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2532 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2533 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2534 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2535 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2536 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2537 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2539 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2540 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2541 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2543 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2544 PTR2UV(IoTOP_GV(sv)));
2545 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2546 maxnest, dumpops, pvlim);
2548 /* Source filters hide things that are not GVs in these three, so let's
2549 be careful out there. */
2551 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2552 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2553 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2555 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2556 PTR2UV(IoFMT_GV(sv)));
2557 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2558 maxnest, dumpops, pvlim);
2560 if (IoBOTTOM_NAME(sv))
2561 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2562 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2563 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2565 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2566 PTR2UV(IoBOTTOM_GV(sv)));
2567 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2568 maxnest, dumpops, pvlim);
2570 if (isPRINT(IoTYPE(sv)))
2571 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2573 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2574 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2579 struct regexp * const r = ReANY((REGEXP*)sv);
2581 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2583 append_flags(d, flags, names); \
2584 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2585 SvCUR_set(d, SvCUR(d) - 1); \
2586 SvPVX(d)[SvCUR(d)] = '\0'; \
2589 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2590 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2591 (UV)(r->compflags), SvPVX_const(d));
2593 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2594 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2595 (UV)(r->extflags), SvPVX_const(d));
2597 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2598 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2599 if (r->engine == &PL_core_reg_engine) {
2600 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2601 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2602 (UV)(r->intflags), SvPVX_const(d));
2604 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2607 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2608 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2610 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2611 (UV)(r->lastparen));
2612 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2613 (UV)(r->lastcloseparen));
2614 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2616 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2617 (IV)(r->minlenret));
2618 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2620 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2621 (UV)(r->pre_prefix));
2622 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2624 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2625 (IV)(r->suboffset));
2626 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2627 (IV)(r->subcoffset));
2629 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2631 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2633 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2634 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2635 PTR2UV(r->mother_re));
2636 if (nest < maxnest && r->mother_re)
2637 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2638 maxnest, dumpops, pvlim);
2639 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2640 PTR2UV(r->paren_names));
2641 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2642 PTR2UV(r->substrs));
2643 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2644 PTR2UV(r->pprivate));
2645 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2647 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2648 PTR2UV(r->qr_anoncv));
2650 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2651 PTR2UV(r->saved_copy));
2662 Dumps the contents of an SV to the C<STDERR> filehandle.
2664 For an example of its output, see L<Devel::Peek>.
2670 Perl_sv_dump(pTHX_ SV *sv)
2672 if (sv && SvROK(sv))
2673 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2675 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2679 Perl_runops_debug(pTHX)
2681 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2682 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2684 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2688 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2691 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2693 #ifdef PERL_TRACE_OPS
2694 ++PL_op_exec_cnt[PL_op->op_type];
2696 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2697 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2698 Perl_croak_nocontext(
2699 "panic: previous op failed to extend arg stack: "
2700 "base=%p, sp=%p, hwm=%p\n",
2701 PL_stack_base, PL_stack_sp,
2702 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2703 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2708 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2709 PerlIO_printf(Perl_debug_log,
2710 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2711 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2712 PTR2UV(*PL_watchaddr));
2713 if (DEBUG_s_TEST_) {
2714 if (DEBUG_v_TEST_) {
2715 PerlIO_printf(Perl_debug_log, "\n");
2723 if (DEBUG_t_TEST_) debop(PL_op);
2724 if (DEBUG_P_TEST_) debprof(PL_op);
2729 PERL_DTRACE_PROBE_OP(PL_op);
2730 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2731 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2734 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2735 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2736 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2743 /* print the names of the n lexical vars starting at pad offset off */
2746 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2749 CV * const cv = deb_curcv(cxstack_ix);
2750 PADNAMELIST *comppad = NULL;
2754 PADLIST * const padlist = CvPADLIST(cv);
2755 comppad = PadlistNAMES(padlist);
2758 PerlIO_printf(Perl_debug_log, "(");
2759 for (i = 0; i < n; i++) {
2760 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2761 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2763 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2766 PerlIO_printf(Perl_debug_log, ",");
2769 PerlIO_printf(Perl_debug_log, ")");
2773 /* append to the out SV, the name of the lexical at offset off in the CV
2777 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2778 bool paren, bool is_scalar)
2781 PADNAMELIST *namepad = NULL;
2785 PADLIST * const padlist = CvPADLIST(cv);
2786 namepad = PadlistNAMES(padlist);
2790 sv_catpvs_nomg(out, "(");
2791 for (i = 0; i < n; i++) {
2792 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2794 STRLEN cur = SvCUR(out);
2795 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2796 UTF8fARG(1, PadnameLEN(sv) - 1,
2797 PadnamePV(sv) + 1));
2799 SvPVX(out)[cur] = '$';
2802 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2804 sv_catpvs_nomg(out, ",");
2807 sv_catpvs_nomg(out, "(");
2812 S_append_gv_name(pTHX_ GV *gv, SV *out)
2816 sv_catpvs_nomg(out, "<NULLGV>");
2819 sv = newSV_type(SVt_NULL);
2820 gv_fullname4(sv, gv, NULL, FALSE);
2821 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2822 SvREFCNT_dec_NN(sv);
2826 # define ITEM_SV(item) (comppad ? \
2827 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2829 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2833 /* return a temporary SV containing a stringified representation of
2834 * the op_aux field of a MULTIDEREF op, associated with CV cv
2838 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2840 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2841 UV actions = items->uv;
2844 bool is_hash = FALSE;
2846 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2851 PADLIST *padlist = CvPADLIST(cv);
2852 comppad = PadlistARRAY(padlist)[1];
2858 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2861 switch (actions & MDEREF_ACTION_MASK) {
2864 actions = (++items)->uv;
2866 NOT_REACHED; /* NOTREACHED */
2868 case MDEREF_HV_padhv_helem:
2871 case MDEREF_AV_padav_aelem:
2873 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2875 NOT_REACHED; /* NOTREACHED */
2877 case MDEREF_HV_gvhv_helem:
2880 case MDEREF_AV_gvav_aelem:
2883 sv = ITEM_SV(items);
2884 S_append_gv_name(aTHX_ (GV*)sv, out);
2886 NOT_REACHED; /* NOTREACHED */
2888 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2891 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2893 sv = ITEM_SV(items);
2894 S_append_gv_name(aTHX_ (GV*)sv, out);
2895 goto do_vivify_rv2xv_elem;
2896 NOT_REACHED; /* NOTREACHED */
2898 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2901 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2902 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2903 goto do_vivify_rv2xv_elem;
2904 NOT_REACHED; /* NOTREACHED */
2906 case MDEREF_HV_pop_rv2hv_helem:
2907 case MDEREF_HV_vivify_rv2hv_helem:
2910 do_vivify_rv2xv_elem:
2911 case MDEREF_AV_pop_rv2av_aelem:
2912 case MDEREF_AV_vivify_rv2av_aelem:
2914 sv_catpvs_nomg(out, "->");
2916 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2917 sv_catpvs_nomg(out, "->");
2922 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2923 switch (actions & MDEREF_INDEX_MASK) {
2924 case MDEREF_INDEX_const:
2927 sv = ITEM_SV(items);
2929 sv_catpvs_nomg(out, "???");
2934 pv_pretty(out, s, cur, 30,
2936 (PERL_PV_PRETTY_NOCLEAR
2937 |PERL_PV_PRETTY_QUOTE
2938 |PERL_PV_PRETTY_ELLIPSES));
2942 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2944 case MDEREF_INDEX_padsv:
2945 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2947 case MDEREF_INDEX_gvsv:
2949 sv = ITEM_SV(items);
2950 S_append_gv_name(aTHX_ (GV*)sv, out);
2953 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2955 if (actions & MDEREF_FLAG_last)
2962 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2963 (int)(actions & MDEREF_ACTION_MASK));
2969 actions >>= MDEREF_SHIFT;
2975 /* Return a temporary SV containing a stringified representation of
2976 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2977 * both plain and utf8 versions of the const string and indices, only
2978 * the first is displayed.
2982 Perl_multiconcat_stringify(pTHX_ const OP *o)
2984 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2985 UNOP_AUX_item *lens;
2989 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2991 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2993 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2994 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2995 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2997 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2998 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2999 sv_catpvs(out, "UTF8 ");
3001 pv_pretty(out, s, len, 50,
3003 (PERL_PV_PRETTY_NOCLEAR
3004 |PERL_PV_PRETTY_QUOTE
3005 |PERL_PV_PRETTY_ELLIPSES));
3007 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3008 while (nargs-- >= 0) {
3009 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
3019 Implements B<-Dt> perl command line option on OP C<o>.
3025 Perl_debop(pTHX_ const OP *o)
3027 PERL_ARGS_ASSERT_DEBOP;
3029 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
3032 Perl_deb(aTHX_ "%s", OP_NAME(o));
3033 switch (o->op_type) {
3036 /* With ITHREADS, consts are stored in the pad, and the right pad
3037 * may not be active here, so check.
3038 * Looks like only during compiling the pads are illegal.
3041 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
3043 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
3047 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3048 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
3055 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
3059 S_deb_padvar(aTHX_ o->op_targ,
3060 o->op_private & OPpPADRANGE_COUNTMASK, 1);
3064 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3065 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
3068 case OP_MULTICONCAT:
3069 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3070 SVfARG(multiconcat_stringify(o)));
3076 PerlIO_printf(Perl_debug_log, "\n");
3082 =for apidoc op_class
3084 Given an op, determine what type of struct it has been allocated as.
3085 Returns one of the OPclass enums, such as OPclass_LISTOP.
3092 Perl_op_class(pTHX_ const OP *o)
3097 return OPclass_NULL;
3099 if (o->op_type == 0) {
3100 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
3102 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3105 if (o->op_type == OP_SASSIGN)
3106 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
3108 if (o->op_type == OP_AELEMFAST) {
3110 return OPclass_PADOP;
3112 return OPclass_SVOP;
3117 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
3118 o->op_type == OP_RCATLINE)
3119 return OPclass_PADOP;
3122 if (o->op_type == OP_CUSTOM)
3125 switch (OP_CLASS(o)) {
3127 return OPclass_BASEOP;
3130 return OPclass_UNOP;
3133 return OPclass_BINOP;
3136 return OPclass_LOGOP;
3139 return OPclass_LISTOP;
3142 return OPclass_PMOP;
3145 return OPclass_SVOP;
3148 return OPclass_PADOP;
3150 case OA_PVOP_OR_SVOP:
3152 * Character translations (tr///) are usually a PVOP, keeping a
3153 * pointer to a table of shorts used to look up translations.
3154 * Under utf8, however, a simple table isn't practical; instead,
3155 * the OP is an SVOP (or, under threads, a PADOP),
3156 * and the SV is an AV.
3159 (o->op_private & OPpTRANS_USE_SVOP)
3161 #if defined(USE_ITHREADS)
3162 ? OPclass_PADOP : OPclass_PVOP;
3164 ? OPclass_SVOP : OPclass_PVOP;
3168 return OPclass_LOOP;
3173 case OA_BASEOP_OR_UNOP:
3175 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3176 * whether parens were seen. perly.y uses OPf_SPECIAL to
3177 * signal whether a BASEOP had empty parens or none.
3178 * Some other UNOPs are created later, though, so the best
3179 * test is OPf_KIDS, which is set in newUNOP.
3181 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3185 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3186 * the OPf_REF flag to distinguish between OP types instead of the
3187 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3188 * return OPclass_UNOP so that walkoptree can find our children. If
3189 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3190 * (no argument to the operator) it's an OP; with OPf_REF set it's
3191 * an SVOP (and op_sv is the GV for the filehandle argument).
3193 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
3195 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
3197 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3201 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3202 * label was omitted (in which case it's a BASEOP) or else a term was
3203 * seen. In this last case, all except goto are definitely PVOP but
3204 * goto is either a PVOP (with an ordinary constant label), an UNOP
3205 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3206 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3209 if (o->op_flags & OPf_STACKED)
3210 return OPclass_UNOP;
3211 else if (o->op_flags & OPf_SPECIAL)
3212 return OPclass_BASEOP;
3214 return OPclass_PVOP;
3216 return OPclass_METHOP;
3218 return OPclass_UNOP_AUX;
3220 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3222 return OPclass_BASEOP;
3228 S_deb_curcv(pTHX_ I32 ix)
3230 PERL_SI *si = PL_curstackinfo;
3231 for (; ix >=0; ix--) {
3232 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3234 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3235 return cx->blk_sub.cv;
3236 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3237 return cx->blk_eval.cv;
3238 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3240 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3241 && si->si_type == PERLSI_SORT)
3243 /* fake sort sub; use CV of caller */
3245 ix = si->si_cxix + 1;
3252 Perl_watch(pTHX_ char **addr)
3254 PERL_ARGS_ASSERT_WATCH;
3256 PL_watchaddr = addr;
3258 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3259 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3265 Called to indicate that C<o> was executed, for profiling purposes under the
3266 C<-DP> command line option.
3272 S_debprof(pTHX_ const OP *o)
3274 PERL_ARGS_ASSERT_DEBPROF;
3276 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3278 if (!PL_profiledata)
3279 Newxz(PL_profiledata, MAXO, U32);
3280 ++PL_profiledata[o->op_type];
3284 =for apidoc debprofdump
3286 Dumps the contents of the data collected by the C<-DP> perl command line
3293 Perl_debprofdump(pTHX)
3296 if (!PL_profiledata)
3298 for (i = 0; i < MAXO; i++) {
3299 if (PL_profiledata[i])
3300 PerlIO_printf(Perl_debug_log,
3301 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3308 * ex: set ts=8 sts=4 sw=4 et: