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) )
97 Escapes at most the first C<count> chars of C<pv> and puts the results into
98 C<dsv> such that the size of the escaped string will not exceed C<max> chars
99 and will not contain any incomplete escape sequences. The number of bytes
100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101 When the C<dsv> parameter is null no escaping actually occurs, but the number
102 of bytes that would be escaped were it not null will be calculated.
104 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
105 will also be escaped.
107 Normally the SV will be cleared before the escaped string is prepared,
108 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111 if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
112 using C<is_utf8_string()> to determine if it is UTF-8.
114 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
116 non-ASCII chars will be escaped using this style; otherwise, only chars above
117 255 will be so escaped; other non printable chars will use octal or
118 common escaped patterns like C<\n>.
119 Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
120 then all chars below 255 will be treated as printable and
121 will be output as literals.
123 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
124 string will be escaped, regardless of max. If the output is to be in hex,
125 then it will be returned as a plain hex
126 sequence. Thus the output will either be a single char,
127 an octal escape sequence, a special escape like C<\n> or a hex value.
129 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130 not a C<"\\">. This is because regexes very often contain backslashed
131 sequences, whereas C<"%"> is not a particularly common character in patterns.
133 Returns a pointer to the escaped text as held by C<dsv>.
135 =for apidoc Amnh||PERL_PV_ESCAPE_ALL
136 =for apidoc Amnh||PERL_PV_ESCAPE_FIRSTCHAR
137 =for apidoc Amnh||PERL_PV_ESCAPE_NOBACKSLASH
138 =for apidoc Amnh||PERL_PV_ESCAPE_NOCLEAR
139 =for apidoc Amnh||PERL_PV_ESCAPE_NONASCII
140 =for apidoc Amnh||PERL_PV_ESCAPE_QUOTE
141 =for apidoc Amnh||PERL_PV_ESCAPE_RE
142 =for apidoc Amnh||PERL_PV_ESCAPE_UNI
143 =for apidoc Amnh||PERL_PV_ESCAPE_UNI_DETECT
147 Unused or not for public use
148 =for apidoc Cmnh||PERL_PV_PRETTY_REGPROP
149 =for apidoc Cmnh||PERL_PV_PRETTY_DUMP
150 =for apidoc Cmnh||PERL_PV_PRETTY_NOCLEAR
154 #define PV_ESCAPE_OCTBUFSIZE 32
157 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
158 const STRLEN count, const STRLEN max,
159 STRLEN * const escaped, const U32 flags )
161 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
162 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
163 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
164 STRLEN wrote = 0; /* chars written so far */
165 STRLEN chsize = 0; /* size of data to be written */
166 STRLEN readsize = 1; /* size of data just read */
167 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
168 const char *pv = str;
169 const char * const end = pv + count; /* end of string */
172 PERL_ARGS_ASSERT_PV_ESCAPE;
174 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
175 /* This won't alter the UTF-8 flag */
179 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
182 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
183 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
184 const U8 c = (U8)u & 0xFF;
187 || (flags & PERL_PV_ESCAPE_ALL)
188 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
190 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
191 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
194 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
195 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
197 : "%cx{%02" UVxf "}", esc, u);
199 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
202 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
206 case '\\' : /* FALLTHROUGH */
207 case '%' : if ( c == esc ) {
213 case '\v' : octbuf[1] = 'v'; break;
214 case '\t' : octbuf[1] = 't'; break;
215 case '\r' : octbuf[1] = 'r'; break;
216 case '\n' : octbuf[1] = 'n'; break;
217 case '\f' : octbuf[1] = 'f'; break;
225 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
226 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
227 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
230 else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
231 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
234 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
241 if ( max && (wrote + chsize > max) ) {
243 } else if (chsize > 1) {
245 sv_catpvn(dsv, octbuf, chsize);
248 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
249 can be appended raw to the dsv. If dsv happens to be
250 UTF-8 then we need catpvf to upgrade them for us.
251 Or add a new API call sv_catpvc(). Think about that name, and
252 how to keep it clear that it's unlike the s of catpvs, which is
253 really an array of octets, not a string. */
255 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
258 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
263 return dsv ? SvPVX(dsv) : NULL;
266 =for apidoc pv_pretty
268 Converts a string into something presentable, handling escaping via
269 C<pv_escape()> and supporting quoting and ellipses.
271 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
272 double quoted with any double quotes in the string escaped. Otherwise
273 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
276 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
277 string were output then an ellipsis C<...> will be appended to the
278 string. Note that this happens AFTER it has been quoted.
280 If C<start_color> is non-null then it will be inserted after the opening
281 quote (if there is one) but before the escaped text. If C<end_color>
282 is non-null then it will be inserted after the escaped text but before
283 any quotes or ellipses.
285 Returns a pointer to the prettified text as held by C<dsv>.
287 =for apidoc Amnh||PERL_PV_PRETTY_QUOTE
288 =for apidoc Amnh||PERL_PV_PRETTY_LTGT
289 =for apidoc Amnh||PERL_PV_PRETTY_ELLIPSES
295 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
296 const STRLEN max, char const * const start_color, char const * const end_color,
299 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
300 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
302 STRLEN max_adjust= 0;
305 PERL_ARGS_ASSERT_PV_PRETTY;
307 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
308 /* This won't alter the UTF-8 flag */
311 orig_cur= SvCUR(dsv);
314 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
316 if ( start_color != NULL )
317 sv_catpv(dsv, start_color);
319 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
322 assert(max > max_adjust);
323 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
324 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
326 assert(max > max_adjust);
329 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
331 if ( end_color != NULL )
332 sv_catpv(dsv, end_color);
335 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
337 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
338 sv_catpvs(dsv, "...");
340 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
341 while( SvCUR(dsv) - orig_cur < max )
349 =for apidoc pv_display
353 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
355 except that an additional "\0" will be appended to the string when
356 len > cur and pv[cur] is "\0".
358 Note that the final string may be up to 7 chars longer than pvlim.
364 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
366 PERL_ARGS_ASSERT_PV_DISPLAY;
368 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
369 if (len > cur && pv[cur] == '\0')
370 sv_catpvs( dsv, "\\0");
375 Perl_sv_peek(pTHX_ SV *sv)
377 SV * const t = sv_newmortal();
384 sv_catpvs(t, "VOID");
387 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
388 /* detect data corruption under memory poisoning */
389 sv_catpvs(t, "WILD");
392 else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
393 || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
395 if (sv == &PL_sv_undef) {
396 sv_catpvs(t, "SV_UNDEF");
397 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
398 SVs_GMG|SVs_SMG|SVs_RMG)) &&
402 else if (sv == &PL_sv_no) {
403 sv_catpvs(t, "SV_NO");
404 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
405 SVs_GMG|SVs_SMG|SVs_RMG)) &&
406 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
412 else if (sv == &PL_sv_yes) {
413 sv_catpvs(t, "SV_YES");
414 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
415 SVs_GMG|SVs_SMG|SVs_RMG)) &&
416 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
419 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
423 else if (sv == &PL_sv_zero) {
424 sv_catpvs(t, "SV_ZERO");
425 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
426 SVs_GMG|SVs_SMG|SVs_RMG)) &&
427 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
430 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
435 sv_catpvs(t, "SV_PLACEHOLDER");
436 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
437 SVs_GMG|SVs_SMG|SVs_RMG)) &&
443 else if (SvREFCNT(sv) == 0) {
447 else if (DEBUG_R_TEST_) {
450 /* is this SV on the tmps stack? */
451 for (ix=PL_tmps_ix; ix>=0; ix--) {
452 if (PL_tmps_stack[ix] == sv) {
457 if (is_tmp || SvREFCNT(sv) > 1) {
458 Perl_sv_catpvf(aTHX_ t, "<");
459 if (SvREFCNT(sv) > 1)
460 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
462 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
463 Perl_sv_catpvf(aTHX_ t, ">");
469 if (SvCUR(t) + unref > 10) {
470 SvCUR_set(t, unref + 3);
479 if (type == SVt_PVCV) {
480 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
482 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
483 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
486 } else if (type < SVt_LAST) {
487 sv_catpv(t, svshorttypenames[type]);
489 if (type == SVt_NULL)
492 sv_catpvs(t, "FREED");
497 if (!SvPVX_const(sv))
498 sv_catpvs(t, "(null)");
500 SV * const tmp = newSVpvs("");
504 SvOOK_offset(sv, delta);
505 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
507 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
509 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
510 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
512 SvREFCNT_dec_NN(tmp);
515 else if (SvNOKp(sv)) {
516 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
517 STORE_LC_NUMERIC_SET_STANDARD();
518 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
519 RESTORE_LC_NUMERIC();
521 else if (SvIOKp(sv)) {
523 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
525 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
533 if (TAINTING_get && sv && SvTAINTED(sv))
534 sv_catpvs(t, " [tainted]");
535 return SvPV_nolen(t);
539 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
542 PERL_ARGS_ASSERT_DUMP_INDENT;
544 dump_vindent(level, file, pat, &args);
549 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
551 PERL_ARGS_ASSERT_DUMP_VINDENT;
552 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
553 PerlIO_vprintf(file, pat, *args);
557 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
558 * for each indent level as appropriate.
560 * bar contains bits indicating which indent columns should have a
561 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
562 * levels than bits in bar, then the first few indents are displayed
565 * The start of a new op is signalled by passing a value for level which
566 * has been negated and offset by 1 (so that level 0 is passed as -1 and
567 * can thus be distinguished from -0); in this case, emit a suitably
568 * indented blank line, then on the next line, display the op's sequence
569 * number, and make the final indent an '+----'.
573 * | FOO # level = 1, bar = 0b1
574 * | | # level =-2-1, bar = 0b11
576 * | BAZ # level = 2, bar = 0b10
580 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
581 const char* pat, ...)
585 bool newop = (level < 0);
589 /* start displaying a new op? */
591 UV seq = sequence_num(o);
595 /* output preceding blank line */
596 PerlIO_puts(file, " ");
597 for (i = level-1; i >= 0; i--)
598 PerlIO_puts(file, ( i == 0
599 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
602 PerlIO_puts(file, "\n");
604 /* output sequence number */
606 PerlIO_printf(file, "%-4" UVuf " ", seq);
608 PerlIO_puts(file, "???? ");
612 PerlIO_printf(file, " ");
614 for (i = level-1; i >= 0; i--)
616 (i == 0 && newop) ? "+--"
617 : (bar & (1 << i)) ? "| "
619 PerlIO_vprintf(file, pat, args);
624 /* display a link field (e.g. op_next) in the format
625 * ====> sequence_number [opname 0x123456]
629 S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file)
631 PerlIO_puts(file, " ===> ");
633 PerlIO_puts(file, "[SELF]\n");
635 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
636 sequence_num(o), OP_NAME(o), PTR2UV(o));
638 PerlIO_puts(file, "[0x0]\n");
642 =for apidoc_section $debugging
645 Dumps the entire optree of the current program starting at C<PL_main_root> to
646 C<STDERR>. Also dumps the optrees for all visible subroutines in
655 dump_all_perl(FALSE);
659 Perl_dump_all_perl(pTHX_ bool justperl)
661 PerlIO_setlinebuf(Perl_debug_log);
663 op_dump(PL_main_root);
664 dump_packsubs_perl(PL_defstash, justperl);
668 =for apidoc dump_packsubs
670 Dumps the optrees for all visible subroutines in C<stash>.
676 Perl_dump_packsubs(pTHX_ const HV *stash)
678 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
679 dump_packsubs_perl(stash, FALSE);
683 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
687 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
691 for (i = 0; i <= (I32) HvMAX(stash); i++) {
693 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
694 GV * gv = (GV *)HeVAL(entry);
695 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
696 /* unfake a fake GV */
697 (void)CvGV(SvRV(gv));
698 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
701 dump_sub_perl(gv, justperl);
704 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
705 const HV * const hv = GvHV(gv);
706 if (hv && (hv != PL_defstash))
707 dump_packsubs_perl(hv, justperl); /* nested package */
714 Perl_dump_sub(pTHX_ const GV *gv)
716 PERL_ARGS_ASSERT_DUMP_SUB;
717 dump_sub_perl(gv, FALSE);
721 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
725 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
727 cv = isGV_with_GP(gv) ? GvCV(gv) :
728 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
729 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
732 if (isGV_with_GP(gv)) {
733 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
734 SV *escsv = newSVpvs_flags("", SVs_TEMP);
737 gv_fullname3(namesv, gv, NULL);
738 namepv = SvPV_const(namesv, namelen);
739 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
740 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
742 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
745 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
747 (int)CvXSUBANY(cv).any_i32);
751 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
755 Perl_dump_form(pTHX_ const GV *gv)
757 SV * const sv = sv_newmortal();
759 PERL_ARGS_ASSERT_DUMP_FORM;
761 gv_fullname3(sv, gv, NULL);
762 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
763 if (CvROOT(GvFORM(gv)))
764 op_dump(CvROOT(GvFORM(gv)));
766 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
772 op_dump(PL_eval_root);
776 /* returns a temp SV displaying the name of a GV. Handles the case where
777 * a GV is in fact a ref to a CV */
780 S_gv_display(pTHX_ GV *gv)
782 SV * const name = newSVpvs_flags("", SVs_TEMP);
784 SV * const raw = newSVpvs_flags("", SVs_TEMP);
788 if (isGV_with_GP(gv))
789 gv_fullname3(raw, gv, NULL);
792 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
793 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
794 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
796 rawpv = SvPV_const(raw, len);
797 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
800 sv_catpvs(name, "(NULL)");
809 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
813 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
820 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
823 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
824 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
825 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
828 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
830 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
831 SV * const tmpsv = pm_description(pm);
832 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
833 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
834 SvREFCNT_dec_NN(tmpsv);
837 if (pm->op_type == OP_SPLIT)
838 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
839 "TARGOFF/GV = 0x%" UVxf "\n",
840 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
842 if (pm->op_pmreplrootu.op_pmreplroot) {
843 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
844 S_do_op_dump_bar(aTHX_ level + 2,
845 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
846 file, pm->op_pmreplrootu.op_pmreplroot);
850 if (pm->op_code_list) {
851 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
852 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
853 S_do_op_dump_bar(aTHX_ level + 2,
854 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
855 file, pm->op_code_list);
858 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
859 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
865 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
867 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
868 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
872 const struct flag_to_name pmflags_flags_names[] = {
873 {PMf_CONST, ",CONST"},
875 {PMf_GLOBAL, ",GLOBAL"},
876 {PMf_CONTINUE, ",CONTINUE"},
877 {PMf_RETAINT, ",RETAINT"},
879 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
880 {PMf_HAS_CV, ",HAS_CV"},
881 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
882 {PMf_IS_QR, ",IS_QR"}
886 S_pm_description(pTHX_ const PMOP *pm)
888 SV * const desc = newSVpvs("");
889 const REGEXP * const regex = PM_GETRE(pm);
890 const U32 pmflags = pm->op_pmflags;
892 PERL_ARGS_ASSERT_PM_DESCRIPTION;
894 if (pmflags & PMf_ONCE)
895 sv_catpvs(desc, ",ONCE");
897 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
898 sv_catpvs(desc, ":USED");
900 if (pmflags & PMf_USED)
901 sv_catpvs(desc, ":USED");
905 if (RX_ISTAINTED(regex))
906 sv_catpvs(desc, ",TAINTED");
907 if (RX_CHECK_SUBSTR(regex)) {
908 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
909 sv_catpvs(desc, ",SCANFIRST");
910 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
911 sv_catpvs(desc, ",ALL");
913 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
914 sv_catpvs(desc, ",SKIPWHITE");
917 append_flags(desc, pmflags, pmflags_flags_names);
922 Perl_pmop_dump(pTHX_ PMOP *pm)
924 do_pmop_dump(0, Perl_debug_log, pm);
927 /* Return a unique integer to represent the address of op o.
928 * If it already exists in PL_op_sequence, just return it;
930 * *** Note that this isn't thread-safe */
933 S_sequence_num(pTHX_ const OP *o)
941 op = newSVuv(PTR2UV(o));
943 key = SvPV_const(op, len);
945 PL_op_sequence = newHV();
946 seq = hv_fetch(PL_op_sequence, key, len, 0);
949 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
957 const struct flag_to_name op_flags_names[] = {
959 {OPf_PARENS, ",PARENS"},
962 {OPf_STACKED, ",STACKED"},
963 {OPf_SPECIAL, ",SPECIAL"}
967 /* indexed by enum OPclass */
968 const char * const op_class_names[] = {
986 /* dump an op and any children. level indicates the initial indent.
987 * The bits of bar indicate which indents should receive a vertical bar.
988 * For example if level == 5 and bar == 0b01101, then the indent prefix
989 * emitted will be (not including the <>'s):
992 * 55554444333322221111
994 * For heavily nested output, the level may exceed the number of bits
995 * in bar; in this case the first few columns in the output will simply
996 * not have a bar, which is harmless.
1000 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
1002 const OPCODE optype = o->op_type;
1004 PERL_ARGS_ASSERT_DO_OP_DUMP;
1006 /* print op header line */
1008 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
1010 if (optype == OP_NULL && o->op_targ)
1011 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
1013 PerlIO_printf(file, " %s(0x%" UVxf ")",
1014 op_class_names[op_class(o)], PTR2UV(o));
1015 S_opdump_link(aTHX_ o, o->op_next, file);
1017 /* print op common fields */
1020 S_opdump_indent(aTHX_ o, level, bar, file, "PARENT");
1021 S_opdump_link(aTHX_ o, op_parent((OP*)o), file);
1023 else if (!OpHAS_SIBLING(o)) {
1025 OP *p = o->op_sibparent;
1026 if (!p || !(p->op_flags & OPf_KIDS))
1029 OP *kid = cUNOPx(p)->op_first;
1031 kid = OpSIBLING(kid);
1039 S_opdump_indent(aTHX_ o, level, bar, file,
1040 "*** WILD PARENT 0x%p\n", p);
1044 if (o->op_targ && optype != OP_NULL)
1045 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1048 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1049 SV * const tmpsv = newSVpvs("");
1050 switch (o->op_flags & OPf_WANT) {
1052 sv_catpvs(tmpsv, ",VOID");
1054 case OPf_WANT_SCALAR:
1055 sv_catpvs(tmpsv, ",SCALAR");
1058 sv_catpvs(tmpsv, ",LIST");
1061 sv_catpvs(tmpsv, ",UNKNOWN");
1064 append_flags(tmpsv, o->op_flags, op_flags_names);
1065 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1066 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1067 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1068 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1069 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1070 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1071 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1074 if (o->op_private) {
1075 U16 oppriv = o->op_private;
1076 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1081 tmpsv = newSVpvs("");
1082 for (; !stop; op_ix++) {
1083 U16 entry = PL_op_private_bitdefs[op_ix];
1084 U16 bit = (entry >> 2) & 7;
1085 U16 ix = entry >> 5;
1091 I16 const *p = &PL_op_private_bitfields[ix];
1092 U16 bitmin = (U16) *p++;
1099 for (i = bitmin; i<= bit; i++)
1102 val = (oppriv & mask);
1105 && PL_op_private_labels[label] == '-'
1106 && PL_op_private_labels[label+1] == '\0'
1108 /* display as raw number */
1121 if (val == 0 && enum_label == -1)
1122 /* don't display anonymous zero values */
1125 sv_catpvs(tmpsv, ",");
1127 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1128 sv_catpvs(tmpsv, "=");
1130 if (enum_label == -1)
1131 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1133 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1138 if ( oppriv & (1<<bit)
1139 && !(PL_op_private_labels[ix] == '-'
1140 && PL_op_private_labels[ix+1] == '\0'))
1143 sv_catpvs(tmpsv, ",");
1144 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1149 sv_catpvs(tmpsv, ",");
1150 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1153 if (tmpsv && SvCUR(tmpsv)) {
1154 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1155 SvPVX_const(tmpsv) + 1);
1157 S_opdump_indent(aTHX_ o, level, bar, file,
1158 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1166 S_opdump_indent(aTHX_ o, level, bar, file,
1167 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1169 S_opdump_indent(aTHX_ o, level, bar, file,
1170 "GV = %" SVf " (0x%" UVxf ")\n",
1171 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1177 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1178 UV i, count = items[-1].uv;
1180 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1181 for (i=0; i < count; i++)
1182 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1183 "%" UVuf " => 0x%" UVxf "\n",
1188 case OP_MULTICONCAT:
1189 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
1190 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
1191 /* XXX really ought to dump each field individually,
1192 * but that's too much like hard work */
1193 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1194 SVfARG(multiconcat_stringify(o)));
1199 case OP_METHOD_NAMED:
1200 case OP_METHOD_SUPER:
1201 case OP_METHOD_REDIR:
1202 case OP_METHOD_REDIR_SUPER:
1203 #ifndef USE_ITHREADS
1204 /* with ITHREADS, consts are stored in the pad, and the right pad
1205 * may not be active here, so skip */
1206 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1207 SvPEEK(cMETHOPx_meth(o)));
1211 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1217 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1218 (UV)CopLINE(cCOPo));
1220 if (CopSTASHPV(cCOPo)) {
1221 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1222 HV *stash = CopSTASH(cCOPo);
1223 const char * const hvname = HvNAME_get(stash);
1225 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1226 generic_pv_escape(tmpsv, hvname,
1227 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1230 if (CopLABEL(cCOPo)) {
1231 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1234 const char *label = CopLABEL_len_flags(cCOPo,
1235 &label_len, &label_flags);
1236 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1237 generic_pv_escape( tmpsv, label, label_len,
1238 (label_flags & SVf_UTF8)));
1241 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1242 (unsigned int)cCOPo->cop_seq);
1247 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1248 S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file);
1249 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1250 S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file);
1251 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1252 S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file);
1272 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1273 S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
1279 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1287 if (o->op_private & OPpREFCOUNTED)
1288 S_opdump_indent(aTHX_ o, level, bar, file,
1289 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1297 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1300 SV * const label = newSVpvs_flags("", SVs_TEMP);
1301 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1302 S_opdump_indent(aTHX_ o, level, bar, file,
1303 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1304 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1310 if (o->op_private & OPpTRANS_USE_SVOP) {
1311 /* utf8: table stored as an inversion map */
1312 #ifndef USE_ITHREADS
1313 /* with ITHREADS, it is stored in the pad, and the right pad
1314 * may not be active here, so skip */
1315 S_opdump_indent(aTHX_ o, level, bar, file,
1316 "INVMAP = 0x%" UVxf "\n",
1317 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1321 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1322 SSize_t i, size = tbl->size;
1324 S_opdump_indent(aTHX_ o, level, bar, file,
1325 "TABLE = 0x%" UVxf "\n",
1327 S_opdump_indent(aTHX_ o, level, bar, file,
1328 " SIZE: 0x%" UVxf "\n", (UV)size);
1330 /* dump size+1 values, to include the extra slot at the end */
1331 for (i = 0; i <= size; i++) {
1332 short val = tbl->map[i];
1334 S_opdump_indent(aTHX_ o, level, bar, file,
1335 " %4" UVxf ":", (UV)i);
1337 PerlIO_printf(file, " %2" IVdf, (IV)val);
1339 PerlIO_printf(file, " %02" UVxf, (UV)val);
1341 if ( i == size || (i & 0xf) == 0xf)
1342 PerlIO_printf(file, "\n");
1351 if (o->op_flags & OPf_KIDS) {
1355 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1356 S_do_op_dump_bar(aTHX_ level,
1357 (bar | cBOOL(OpHAS_SIBLING(kid))),
1364 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1366 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1373 Dumps the optree starting at OP C<o> to C<STDERR>.
1379 Perl_op_dump(pTHX_ const OP *o)
1381 PERL_ARGS_ASSERT_OP_DUMP;
1382 do_op_dump(0, Perl_debug_log, o);
1386 Perl_gv_dump(pTHX_ GV *gv)
1390 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1393 PerlIO_printf(Perl_debug_log, "{}\n");
1396 sv = sv_newmortal();
1397 PerlIO_printf(Perl_debug_log, "{\n");
1398 gv_fullname3(sv, gv, NULL);
1399 name = SvPV_const(sv, len);
1400 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1401 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1402 if (gv != GvEGV(gv)) {
1403 gv_efullname3(sv, GvEGV(gv), NULL);
1404 name = SvPV_const(sv, len);
1405 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1406 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1408 (void)PerlIO_putc(Perl_debug_log, '\n');
1409 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1413 /* map magic types to the symbolic names
1414 * (with the PERL_MAGIC_ prefixed stripped)
1417 static const struct { const char type; const char *name; } magic_names[] = {
1418 #include "mg_names.inc"
1419 /* this null string terminates the list */
1424 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1426 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1428 for (; mg; mg = mg->mg_moremagic) {
1429 Perl_dump_indent(aTHX_ level, file,
1430 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1431 if (mg->mg_virtual) {
1432 const MGVTBL * const v = mg->mg_virtual;
1433 if (v >= PL_magic_vtables
1434 && v < PL_magic_vtables + magic_vtable_max) {
1435 const U32 i = v - PL_magic_vtables;
1436 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1439 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1440 UVxf "\n", PTR2UV(v));
1443 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1446 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1450 const char *name = NULL;
1451 for (n = 0; magic_names[n].name; n++) {
1452 if (mg->mg_type == magic_names[n].type) {
1453 name = magic_names[n].name;
1458 Perl_dump_indent(aTHX_ level, file,
1459 " MG_TYPE = PERL_MAGIC_%s\n", name);
1461 Perl_dump_indent(aTHX_ level, file,
1462 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1466 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1467 if (mg->mg_type == PERL_MAGIC_envelem &&
1468 mg->mg_flags & MGf_TAINTEDDIR)
1469 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1470 if (mg->mg_type == PERL_MAGIC_regex_global &&
1471 mg->mg_flags & MGf_MINMATCH)
1472 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1473 if (mg->mg_flags & MGf_REFCOUNTED)
1474 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1475 if (mg->mg_flags & MGf_GSKIP)
1476 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1477 if (mg->mg_flags & MGf_COPY)
1478 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1479 if (mg->mg_flags & MGf_DUP)
1480 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1481 if (mg->mg_flags & MGf_LOCAL)
1482 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1483 if (mg->mg_type == PERL_MAGIC_regex_global &&
1484 mg->mg_flags & MGf_BYTES)
1485 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1488 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1489 PTR2UV(mg->mg_obj));
1490 if (mg->mg_type == PERL_MAGIC_qr) {
1491 REGEXP* const re = (REGEXP *)mg->mg_obj;
1492 SV * const dsv = sv_newmortal();
1493 const char * const s
1494 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1496 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1497 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1499 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1500 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1503 if (mg->mg_flags & MGf_REFCOUNTED)
1504 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1507 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1509 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1510 if (mg->mg_len >= 0) {
1511 if (mg->mg_type != PERL_MAGIC_utf8) {
1512 SV * const sv = newSVpvs("");
1513 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1514 SvREFCNT_dec_NN(sv);
1517 else if (mg->mg_len == HEf_SVKEY) {
1518 PerlIO_puts(file, " => HEf_SVKEY\n");
1519 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1520 maxnest, dumpops, pvlim); /* MG is already +1 */
1523 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1528 " does not know how to handle this MG_LEN"
1530 (void)PerlIO_putc(file, '\n');
1532 if (mg->mg_type == PERL_MAGIC_utf8) {
1533 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1536 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1537 Perl_dump_indent(aTHX_ level, file,
1538 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1541 (UV)cache[i * 2 + 1]);
1548 Perl_magic_dump(pTHX_ const MAGIC *mg)
1550 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1554 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1558 PERL_ARGS_ASSERT_DO_HV_DUMP;
1560 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1561 if (sv && (hvname = HvNAME_get(sv)))
1563 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1564 name which quite legally could contain insane things like tabs, newlines, nulls or
1565 other scary crap - this should produce sane results - except maybe for unicode package
1566 names - but we will wait for someone to file a bug on that - demerphq */
1567 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1568 PerlIO_printf(file, "\t\"%s\"\n",
1569 generic_pv_escape( tmpsv, hvname,
1570 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1573 (void)PerlIO_putc(file, '\n');
1577 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1579 PERL_ARGS_ASSERT_DO_GV_DUMP;
1581 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1582 if (sv && GvNAME(sv)) {
1583 SV * const tmpsv = newSVpvs("");
1584 PerlIO_printf(file, "\t\"%s\"\n",
1585 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1588 (void)PerlIO_putc(file, '\n');
1592 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1594 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1596 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1597 if (sv && GvNAME(sv)) {
1598 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1600 HV * const stash = GvSTASH(sv);
1601 PerlIO_printf(file, "\t");
1602 /* TODO might have an extra \" here */
1603 if (stash && (hvname = HvNAME_get(stash))) {
1604 PerlIO_printf(file, "\"%s\" :: \"",
1605 generic_pv_escape(tmp, hvname,
1606 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1608 PerlIO_printf(file, "%s\"\n",
1609 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1612 (void)PerlIO_putc(file, '\n');
1615 const struct flag_to_name first_sv_flags_names[] = {
1616 {SVs_TEMP, "TEMP,"},
1617 {SVs_OBJECT, "OBJECT,"},
1626 const struct flag_to_name second_sv_flags_names[] = {
1628 {SVf_FAKE, "FAKE,"},
1629 {SVf_READONLY, "READONLY,"},
1630 {SVf_PROTECT, "PROTECT,"},
1631 {SVf_BREAK, "BREAK,"},
1637 const struct flag_to_name cv_flags_names[] = {
1638 {CVf_ANON, "ANON,"},
1639 {CVf_UNIQUE, "UNIQUE,"},
1640 {CVf_CLONE, "CLONE,"},
1641 {CVf_CLONED, "CLONED,"},
1642 {CVf_CONST, "CONST,"},
1643 {CVf_NODEBUG, "NODEBUG,"},
1644 {CVf_LVALUE, "LVALUE,"},
1645 {CVf_METHOD, "METHOD,"},
1646 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1647 {CVf_CVGV_RC, "CVGV_RC,"},
1648 {CVf_DYNFILE, "DYNFILE,"},
1649 {CVf_AUTOLOAD, "AUTOLOAD,"},
1650 {CVf_HASEVAL, "HASEVAL,"},
1651 {CVf_SLABBED, "SLABBED,"},
1652 {CVf_NAMED, "NAMED,"},
1653 {CVf_LEXICAL, "LEXICAL,"},
1654 {CVf_ISXSUB, "ISXSUB,"}
1657 const struct flag_to_name hv_flags_names[] = {
1658 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1659 {SVphv_LAZYDEL, "LAZYDEL,"},
1660 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1661 {SVf_AMAGIC, "OVERLOAD,"},
1662 {SVphv_CLONEABLE, "CLONEABLE,"}
1665 const struct flag_to_name gp_flags_names[] = {
1666 {GVf_INTRO, "INTRO,"},
1667 {GVf_MULTI, "MULTI,"},
1668 {GVf_ASSUMECV, "ASSUMECV,"},
1671 const struct flag_to_name gp_flags_imported_names[] = {
1672 {GVf_IMPORTED_SV, " SV"},
1673 {GVf_IMPORTED_AV, " AV"},
1674 {GVf_IMPORTED_HV, " HV"},
1675 {GVf_IMPORTED_CV, " CV"},
1678 /* NOTE: this structure is mostly duplicative of one generated by
1679 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1680 * the two. - Yves */
1681 const struct flag_to_name regexp_extflags_names[] = {
1682 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1683 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1684 {RXf_PMf_FOLD, "PMf_FOLD,"},
1685 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1686 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1687 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1688 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1689 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1690 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1691 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1692 {RXf_CHECK_ALL, "CHECK_ALL,"},
1693 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1694 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1695 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1696 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1697 {RXf_SPLIT, "SPLIT,"},
1698 {RXf_COPY_DONE, "COPY_DONE,"},
1699 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1700 {RXf_TAINTED, "TAINTED,"},
1701 {RXf_START_ONLY, "START_ONLY,"},
1702 {RXf_SKIPWHITE, "SKIPWHITE,"},
1703 {RXf_WHITE, "WHITE,"},
1704 {RXf_NULL, "NULL,"},
1707 /* NOTE: this structure is mostly duplicative of one generated by
1708 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1709 * the two. - Yves */
1710 const struct flag_to_name regexp_core_intflags_names[] = {
1711 {PREGf_SKIP, "SKIP,"},
1712 {PREGf_IMPLICIT, "IMPLICIT,"},
1713 {PREGf_NAUGHTY, "NAUGHTY,"},
1714 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1715 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1716 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1717 {PREGf_NOSCAN, "NOSCAN,"},
1718 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1719 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1720 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1721 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1722 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1725 /* Perl_do_sv_dump():
1727 * level: amount to indent the output
1728 * sv: the object to dump
1729 * nest: the current level of recursion
1730 * maxnest: the maximum allowed level of recursion
1731 * dumpops: if true, also dump the ops associated with a CV
1732 * pvlim: limit on the length of any strings that are output
1736 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1743 PERL_ARGS_ASSERT_DO_SV_DUMP;
1746 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1750 flags = SvFLAGS(sv);
1753 /* process general SV flags */
1755 d = Perl_newSVpvf(aTHX_
1756 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1757 PTR2UV(SvANY(sv)), PTR2UV(sv),
1758 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1759 (int)(PL_dumpindent*level), "");
1761 if ((flags & SVs_PADSTALE))
1762 sv_catpvs(d, "PADSTALE,");
1763 if ((flags & SVs_PADTMP))
1764 sv_catpvs(d, "PADTMP,");
1765 append_flags(d, flags, first_sv_flags_names);
1766 if (flags & SVf_ROK) {
1767 sv_catpvs(d, "ROK,");
1768 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
1770 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1771 append_flags(d, flags, second_sv_flags_names);
1772 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1773 && type != SVt_PVAV) {
1774 if (SvPCS_IMPORTED(sv))
1775 sv_catpvs(d, "PCS_IMPORTED,");
1777 sv_catpvs(d, "SCREAM,");
1780 /* process type-specific SV flags */
1785 append_flags(d, CvFLAGS(sv), cv_flags_names);
1788 append_flags(d, flags, hv_flags_names);
1792 if (isGV_with_GP(sv)) {
1793 append_flags(d, GvFLAGS(sv), gp_flags_names);
1795 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1796 sv_catpvs(d, "IMPORT");
1797 if (GvIMPORTED(sv) == GVf_IMPORTED)
1798 sv_catpvs(d, "ALL,");
1801 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1802 sv_catpvs(d, " ),");
1808 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1814 /* SVphv_SHAREKEYS is also 0x20000000 */
1815 if ((type != SVt_PVHV) && SvUTF8(sv))
1816 sv_catpvs(d, "UTF8");
1818 if (*(SvEND(d) - 1) == ',') {
1819 SvCUR_set(d, SvCUR(d) - 1);
1820 SvPVX(d)[SvCUR(d)] = '\0';
1825 /* dump initial SV details */
1827 #ifdef DEBUG_LEAKING_SCALARS
1828 Perl_dump_indent(aTHX_ level, file,
1829 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1830 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1832 sv->sv_debug_inpad ? "for" : "by",
1833 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1834 PTR2UV(sv->sv_debug_parent),
1838 Perl_dump_indent(aTHX_ level, file, "SV = ");
1842 if (type < SVt_LAST) {
1843 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1845 if (type == SVt_NULL) {
1850 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1855 /* Dump general SV fields */
1857 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1858 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1859 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1860 || (type == SVt_IV && !SvROK(sv))) {
1863 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1865 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1866 (void)PerlIO_putc(file, '\n');
1869 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1870 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1871 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1872 || type == SVt_NV) {
1873 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1874 STORE_LC_NUMERIC_SET_STANDARD();
1875 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1876 RESTORE_LC_NUMERIC();
1880 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1883 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1886 if (type < SVt_PV) {
1891 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1892 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1893 const bool re = isREGEXP(sv);
1894 const char * const ptr =
1895 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1899 SvOOK_offset(sv, delta);
1900 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1905 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1908 PerlIO_printf(file, "( %s . ) ",
1909 pv_display(d, ptr - delta, delta, 0,
1912 if (type == SVt_INVLIST) {
1913 PerlIO_printf(file, "\n");
1914 /* 4 blanks indents 2 beyond the PV, etc */
1915 _invlist_dump(file, level, " ", sv);
1918 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1921 if (SvUTF8(sv)) /* the 6? \x{....} */
1922 PerlIO_printf(file, " [UTF8 \"%s\"]",
1923 sv_uni_display(d, sv, 6 * SvCUR(sv),
1925 PerlIO_printf(file, "\n");
1927 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1928 if (re && type == SVt_PVLV)
1929 /* LV-as-REGEXP usurps len field to store pointer to
1931 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1932 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1934 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1936 #ifdef PERL_COPY_ON_WRITE
1937 if (SvIsCOW(sv) && SvLEN(sv))
1938 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1943 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1946 if (type >= SVt_PVMG) {
1948 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1950 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1952 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1953 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1958 /* Dump type-specific SV fields */
1962 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1963 PTR2UV(AvARRAY(sv)));
1964 if (AvARRAY(sv) != AvALLOC(sv)) {
1965 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1966 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1967 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1968 PTR2UV(AvALLOC(sv)));
1971 (void)PerlIO_putc(file, '\n');
1972 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1974 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1977 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1978 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
1979 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1980 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1981 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1983 SV **svp = AvARRAY(MUTABLE_AV(sv));
1985 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1988 SV* const elt = *svp;
1989 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1991 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1998 struct xpvhv_aux *const aux = HvAUX(sv);
1999 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
2000 (UV)aux->xhv_aux_flags);
2002 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
2003 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
2004 if (HvARRAY(sv) && usedkeys) {
2005 /* Show distribution of HEs in the ARRAY */
2007 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
2010 U32 pow2 = 2, keys = usedkeys;
2011 NV theoret, sum = 0;
2013 PerlIO_printf(file, " (");
2014 Zero(freq, FREQ_MAX + 1, int);
2015 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2018 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
2020 if (count > FREQ_MAX)
2026 for (i = 0; i <= max; i++) {
2028 PerlIO_printf(file, "%d%s:%d", i,
2029 (i == FREQ_MAX) ? "+" : "",
2032 PerlIO_printf(file, ", ");
2035 (void)PerlIO_putc(file, ')');
2036 /* The "quality" of a hash is defined as the total number of
2037 comparisons needed to access every element once, relative
2038 to the expected number needed for a random hash.
2040 The total number of comparisons is equal to the sum of
2041 the squares of the number of entries in each bucket.
2042 For a random hash of n keys into k buckets, the expected
2047 for (i = max; i > 0; i--) { /* Precision: count down. */
2048 sum += freq[i] * i * i;
2050 while ((keys = keys >> 1))
2053 theoret += theoret * (theoret-1)/pow2;
2054 (void)PerlIO_putc(file, '\n');
2055 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2056 NVff "%%", theoret/sum*100);
2058 (void)PerlIO_putc(file, '\n');
2059 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2063 HE **ents = HvARRAY(sv);
2066 HE *const *const last = ents + HvMAX(sv);
2067 count = last + 1 - ents;
2072 } while (++ents <= last);
2075 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2078 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2081 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2082 (IV)HvRITER_get(sv));
2083 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2084 PTR2UV(HvEITER_get(sv)));
2085 #ifdef PERL_HASH_RANDOMIZE_KEYS
2086 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2087 (UV)HvRAND_get(sv));
2088 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2089 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2090 (UV)HvLASTRAND_get(sv));
2093 (void)PerlIO_putc(file, '\n');
2096 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2097 if (mg && mg->mg_obj) {
2098 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2102 const char * const hvname = HvNAME_get(sv);
2104 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2105 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2106 generic_pv_escape( tmpsv, hvname,
2107 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2112 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2113 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2114 if (HvAUX(sv)->xhv_name_count)
2115 Perl_dump_indent(aTHX_
2116 level, file, " NAMECOUNT = %" IVdf "\n",
2117 (IV)HvAUX(sv)->xhv_name_count
2119 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2120 const I32 count = HvAUX(sv)->xhv_name_count;
2122 SV * const names = newSVpvs_flags("", SVs_TEMP);
2123 /* The starting point is the first element if count is
2124 positive and the second element if count is negative. */
2125 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2126 + (count < 0 ? 1 : 0);
2127 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2128 + (count < 0 ? -count : count);
2129 while (hekp < endp) {
2131 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2132 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2133 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2135 /* This should never happen. */
2136 sv_catpvs(names, ", (null)");
2140 Perl_dump_indent(aTHX_
2141 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2145 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2146 const char *const hvename = HvENAME_get(sv);
2147 Perl_dump_indent(aTHX_
2148 level, file, " ENAME = \"%s\"\n",
2149 generic_pv_escape(tmp, hvename,
2150 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2154 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2156 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2160 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2161 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2163 generic_pv_escape( tmpsv, meta->mro_which->name,
2164 meta->mro_which->length,
2165 (meta->mro_which->kflags & HVhek_UTF8)),
2166 PTR2UV(meta->mro_which));
2167 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2169 (UV)meta->cache_gen);
2170 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2172 if (meta->mro_linear_all) {
2173 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2175 PTR2UV(meta->mro_linear_all));
2176 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2179 if (meta->mro_linear_current) {
2180 Perl_dump_indent(aTHX_ level, file,
2181 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2182 PTR2UV(meta->mro_linear_current));
2183 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2186 if (meta->mro_nextmethod) {
2187 Perl_dump_indent(aTHX_ level, file,
2188 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2189 PTR2UV(meta->mro_nextmethod));
2190 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2194 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2196 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2201 if (nest < maxnest) {
2202 HV * const hv = MUTABLE_HV(sv);
2207 int count = maxnest - nest;
2208 for (i=0; i <= HvMAX(hv); i++) {
2209 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2216 if (count-- <= 0) goto DONEHV;
2219 keysv = hv_iterkeysv(he);
2220 keypv = SvPV_const(keysv, len);
2223 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2225 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2226 if (HvEITER_get(hv) == he)
2227 PerlIO_printf(file, "[CURRENT] ");
2228 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2229 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2236 } /* case SVt_PVHV */
2239 if (CvAUTOLOAD(sv)) {
2240 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2242 const char *const name = SvPV_const(sv, len);
2243 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2244 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2247 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2248 const char *const proto = CvPROTO(sv);
2249 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2250 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2255 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2256 if (!CvISXSUB(sv)) {
2259 Perl_dump_indent(aTHX_ level, file,
2260 " SLAB = 0x%" UVxf "\n",
2261 PTR2UV(CvSTART(sv)));
2263 Perl_dump_indent(aTHX_ level, file,
2264 " START = 0x%" UVxf " ===> %" IVdf "\n",
2265 PTR2UV(CvSTART(sv)),
2266 (IV)sequence_num(CvSTART(sv)));
2268 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2269 PTR2UV(CvROOT(sv)));
2270 if (CvROOT(sv) && dumpops) {
2271 do_op_dump(level+1, file, CvROOT(sv));
2274 SV * const constant = cv_const_sv((const CV *)sv);
2276 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2279 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2281 PTR2UV(CvXSUBANY(sv).any_ptr));
2282 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2285 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2286 (IV)CvXSUBANY(sv).any_i32);
2290 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2291 HEK_KEY(CvNAME_HEK((CV *)sv)));
2292 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2293 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2294 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2295 IVdf "\n", (IV)CvDEPTH(sv));
2296 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2298 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2299 if (!CvISXSUB(sv)) {
2300 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2301 if (nest < maxnest) {
2302 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2306 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2308 const CV * const outside = CvOUTSIDE(sv);
2309 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2312 : CvANON(outside) ? "ANON"
2313 : (outside == PL_main_cv) ? "MAIN"
2314 : CvUNIQUE(outside) ? "UNIQUE"
2317 newSVpvs_flags("", SVs_TEMP),
2318 GvNAME(CvGV(outside)),
2319 GvNAMELEN(CvGV(outside)),
2320 GvNAMEUTF8(CvGV(outside)))
2324 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2325 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2330 if (type == SVt_PVLV) {
2331 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2332 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2333 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2334 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2335 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2336 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2337 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2340 if (isREGEXP(sv)) goto dumpregexp;
2341 if (!isGV_with_GP(sv))
2344 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2345 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2346 generic_pv_escape(tmpsv, GvNAME(sv),
2350 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2351 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2352 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2353 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2356 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2357 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2358 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2359 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2360 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2361 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2362 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2363 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2364 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2368 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2369 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2370 do_gv_dump (level, file, " EGV", GvEGV(sv));
2373 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2374 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2375 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2376 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2377 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2378 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2379 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2381 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2382 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2383 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2385 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2386 PTR2UV(IoTOP_GV(sv)));
2387 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2388 maxnest, dumpops, pvlim);
2390 /* Source filters hide things that are not GVs in these three, so let's
2391 be careful out there. */
2393 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2394 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2395 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2397 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2398 PTR2UV(IoFMT_GV(sv)));
2399 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2400 maxnest, dumpops, pvlim);
2402 if (IoBOTTOM_NAME(sv))
2403 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2404 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2405 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2407 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2408 PTR2UV(IoBOTTOM_GV(sv)));
2409 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2410 maxnest, dumpops, pvlim);
2412 if (isPRINT(IoTYPE(sv)))
2413 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2415 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2416 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2421 struct regexp * const r = ReANY((REGEXP*)sv);
2423 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2425 append_flags(d, flags, names); \
2426 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2427 SvCUR_set(d, SvCUR(d) - 1); \
2428 SvPVX(d)[SvCUR(d)] = '\0'; \
2431 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2432 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2433 (UV)(r->compflags), SvPVX_const(d));
2435 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2436 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2437 (UV)(r->extflags), SvPVX_const(d));
2439 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2440 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2441 if (r->engine == &PL_core_reg_engine) {
2442 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2443 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2444 (UV)(r->intflags), SvPVX_const(d));
2446 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2449 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2450 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2452 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2453 (UV)(r->lastparen));
2454 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2455 (UV)(r->lastcloseparen));
2456 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2458 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2459 (IV)(r->minlenret));
2460 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2462 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2463 (UV)(r->pre_prefix));
2464 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2466 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2467 (IV)(r->suboffset));
2468 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2469 (IV)(r->subcoffset));
2471 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2473 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2475 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2476 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2477 PTR2UV(r->mother_re));
2478 if (nest < maxnest && r->mother_re)
2479 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2480 maxnest, dumpops, pvlim);
2481 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2482 PTR2UV(r->paren_names));
2483 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2484 PTR2UV(r->substrs));
2485 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2486 PTR2UV(r->pprivate));
2487 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2489 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2490 PTR2UV(r->qr_anoncv));
2492 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2493 PTR2UV(r->saved_copy));
2504 Dumps the contents of an SV to the C<STDERR> filehandle.
2506 For an example of its output, see L<Devel::Peek>.
2512 Perl_sv_dump(pTHX_ SV *sv)
2514 if (sv && SvROK(sv))
2515 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2517 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2521 Perl_runops_debug(pTHX)
2523 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2524 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2526 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2530 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2533 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2535 #ifdef PERL_TRACE_OPS
2536 ++PL_op_exec_cnt[PL_op->op_type];
2538 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2539 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2540 Perl_croak_nocontext(
2541 "panic: previous op failed to extend arg stack: "
2542 "base=%p, sp=%p, hwm=%p\n",
2543 PL_stack_base, PL_stack_sp,
2544 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2545 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2550 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2551 PerlIO_printf(Perl_debug_log,
2552 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2553 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2554 PTR2UV(*PL_watchaddr));
2555 if (DEBUG_s_TEST_) {
2556 if (DEBUG_v_TEST_) {
2557 PerlIO_printf(Perl_debug_log, "\n");
2565 if (DEBUG_t_TEST_) debop(PL_op);
2566 if (DEBUG_P_TEST_) debprof(PL_op);
2571 PERL_DTRACE_PROBE_OP(PL_op);
2572 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2573 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2576 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2577 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2578 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2585 /* print the names of the n lexical vars starting at pad offset off */
2588 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2591 CV * const cv = deb_curcv(cxstack_ix);
2592 PADNAMELIST *comppad = NULL;
2596 PADLIST * const padlist = CvPADLIST(cv);
2597 comppad = PadlistNAMES(padlist);
2600 PerlIO_printf(Perl_debug_log, "(");
2601 for (i = 0; i < n; i++) {
2602 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2603 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2605 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2608 PerlIO_printf(Perl_debug_log, ",");
2611 PerlIO_printf(Perl_debug_log, ")");
2615 /* append to the out SV, the name of the lexical at offset off in the CV
2619 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2620 bool paren, bool is_scalar)
2623 PADNAMELIST *namepad = NULL;
2627 PADLIST * const padlist = CvPADLIST(cv);
2628 namepad = PadlistNAMES(padlist);
2632 sv_catpvs_nomg(out, "(");
2633 for (i = 0; i < n; i++) {
2634 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2636 STRLEN cur = SvCUR(out);
2637 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2638 UTF8fARG(1, PadnameLEN(sv) - 1,
2639 PadnamePV(sv) + 1));
2641 SvPVX(out)[cur] = '$';
2644 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2646 sv_catpvs_nomg(out, ",");
2649 sv_catpvs_nomg(out, "(");
2654 S_append_gv_name(pTHX_ GV *gv, SV *out)
2658 sv_catpvs_nomg(out, "<NULLGV>");
2662 gv_fullname4(sv, gv, NULL, FALSE);
2663 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2664 SvREFCNT_dec_NN(sv);
2668 # define ITEM_SV(item) (comppad ? \
2669 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2671 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2675 /* return a temporary SV containing a stringified representation of
2676 * the op_aux field of a MULTIDEREF op, associated with CV cv
2680 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2682 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2683 UV actions = items->uv;
2686 bool is_hash = FALSE;
2688 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2693 PADLIST *padlist = CvPADLIST(cv);
2694 comppad = PadlistARRAY(padlist)[1];
2700 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2703 switch (actions & MDEREF_ACTION_MASK) {
2706 actions = (++items)->uv;
2708 NOT_REACHED; /* NOTREACHED */
2710 case MDEREF_HV_padhv_helem:
2713 case MDEREF_AV_padav_aelem:
2715 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2717 NOT_REACHED; /* NOTREACHED */
2719 case MDEREF_HV_gvhv_helem:
2722 case MDEREF_AV_gvav_aelem:
2725 sv = ITEM_SV(items);
2726 S_append_gv_name(aTHX_ (GV*)sv, out);
2728 NOT_REACHED; /* NOTREACHED */
2730 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2733 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2735 sv = ITEM_SV(items);
2736 S_append_gv_name(aTHX_ (GV*)sv, out);
2737 goto do_vivify_rv2xv_elem;
2738 NOT_REACHED; /* NOTREACHED */
2740 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2743 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2744 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2745 goto do_vivify_rv2xv_elem;
2746 NOT_REACHED; /* NOTREACHED */
2748 case MDEREF_HV_pop_rv2hv_helem:
2749 case MDEREF_HV_vivify_rv2hv_helem:
2752 do_vivify_rv2xv_elem:
2753 case MDEREF_AV_pop_rv2av_aelem:
2754 case MDEREF_AV_vivify_rv2av_aelem:
2756 sv_catpvs_nomg(out, "->");
2758 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2759 sv_catpvs_nomg(out, "->");
2764 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2765 switch (actions & MDEREF_INDEX_MASK) {
2766 case MDEREF_INDEX_const:
2769 sv = ITEM_SV(items);
2771 sv_catpvs_nomg(out, "???");
2776 pv_pretty(out, s, cur, 30,
2778 (PERL_PV_PRETTY_NOCLEAR
2779 |PERL_PV_PRETTY_QUOTE
2780 |PERL_PV_PRETTY_ELLIPSES));
2784 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2786 case MDEREF_INDEX_padsv:
2787 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2789 case MDEREF_INDEX_gvsv:
2791 sv = ITEM_SV(items);
2792 S_append_gv_name(aTHX_ (GV*)sv, out);
2795 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2797 if (actions & MDEREF_FLAG_last)
2804 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2805 (int)(actions & MDEREF_ACTION_MASK));
2811 actions >>= MDEREF_SHIFT;
2817 /* Return a temporary SV containing a stringified representation of
2818 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2819 * both plain and utf8 versions of the const string and indices, only
2820 * the first is displayed.
2824 Perl_multiconcat_stringify(pTHX_ const OP *o)
2826 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2827 UNOP_AUX_item *lens;
2831 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2833 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2835 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2836 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2837 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2839 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2840 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2841 sv_catpvs(out, "UTF8 ");
2843 pv_pretty(out, s, len, 50,
2845 (PERL_PV_PRETTY_NOCLEAR
2846 |PERL_PV_PRETTY_QUOTE
2847 |PERL_PV_PRETTY_ELLIPSES));
2849 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2850 while (nargs-- >= 0) {
2851 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
2859 Perl_debop(pTHX_ const OP *o)
2861 PERL_ARGS_ASSERT_DEBOP;
2863 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2866 Perl_deb(aTHX_ "%s", OP_NAME(o));
2867 switch (o->op_type) {
2870 /* With ITHREADS, consts are stored in the pad, and the right pad
2871 * may not be active here, so check.
2872 * Looks like only during compiling the pads are illegal.
2875 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2877 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2881 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2882 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2889 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2893 S_deb_padvar(aTHX_ o->op_targ,
2894 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2898 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2899 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2902 case OP_MULTICONCAT:
2903 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2904 SVfARG(multiconcat_stringify(o)));
2910 PerlIO_printf(Perl_debug_log, "\n");
2916 =for apidoc op_class
2918 Given an op, determine what type of struct it has been allocated as.
2919 Returns one of the OPclass enums, such as OPclass_LISTOP.
2926 Perl_op_class(pTHX_ const OP *o)
2931 return OPclass_NULL;
2933 if (o->op_type == 0) {
2934 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2936 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2939 if (o->op_type == OP_SASSIGN)
2940 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2942 if (o->op_type == OP_AELEMFAST) {
2944 return OPclass_PADOP;
2946 return OPclass_SVOP;
2951 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2952 o->op_type == OP_RCATLINE)
2953 return OPclass_PADOP;
2956 if (o->op_type == OP_CUSTOM)
2959 switch (OP_CLASS(o)) {
2961 return OPclass_BASEOP;
2964 return OPclass_UNOP;
2967 return OPclass_BINOP;
2970 return OPclass_LOGOP;
2973 return OPclass_LISTOP;
2976 return OPclass_PMOP;
2979 return OPclass_SVOP;
2982 return OPclass_PADOP;
2984 case OA_PVOP_OR_SVOP:
2986 * Character translations (tr///) are usually a PVOP, keeping a
2987 * pointer to a table of shorts used to look up translations.
2988 * Under utf8, however, a simple table isn't practical; instead,
2989 * the OP is an SVOP (or, under threads, a PADOP),
2990 * and the SV is an AV.
2993 (o->op_private & OPpTRANS_USE_SVOP)
2995 #if defined(USE_ITHREADS)
2996 ? OPclass_PADOP : OPclass_PVOP;
2998 ? OPclass_SVOP : OPclass_PVOP;
3002 return OPclass_LOOP;
3007 case OA_BASEOP_OR_UNOP:
3009 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3010 * whether parens were seen. perly.y uses OPf_SPECIAL to
3011 * signal whether a BASEOP had empty parens or none.
3012 * Some other UNOPs are created later, though, so the best
3013 * test is OPf_KIDS, which is set in newUNOP.
3015 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3019 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3020 * the OPf_REF flag to distinguish between OP types instead of the
3021 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3022 * return OPclass_UNOP so that walkoptree can find our children. If
3023 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3024 * (no argument to the operator) it's an OP; with OPf_REF set it's
3025 * an SVOP (and op_sv is the GV for the filehandle argument).
3027 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
3029 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
3031 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3035 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3036 * label was omitted (in which case it's a BASEOP) or else a term was
3037 * seen. In this last case, all except goto are definitely PVOP but
3038 * goto is either a PVOP (with an ordinary constant label), an UNOP
3039 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3040 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3043 if (o->op_flags & OPf_STACKED)
3044 return OPclass_UNOP;
3045 else if (o->op_flags & OPf_SPECIAL)
3046 return OPclass_BASEOP;
3048 return OPclass_PVOP;
3050 return OPclass_METHOP;
3052 return OPclass_UNOP_AUX;
3054 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3056 return OPclass_BASEOP;
3062 S_deb_curcv(pTHX_ I32 ix)
3064 PERL_SI *si = PL_curstackinfo;
3065 for (; ix >=0; ix--) {
3066 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3068 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3069 return cx->blk_sub.cv;
3070 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3071 return cx->blk_eval.cv;
3072 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3074 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3075 && si->si_type == PERLSI_SORT)
3077 /* fake sort sub; use CV of caller */
3079 ix = si->si_cxix + 1;
3086 Perl_watch(pTHX_ char **addr)
3088 PERL_ARGS_ASSERT_WATCH;
3090 PL_watchaddr = addr;
3092 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3093 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3097 S_debprof(pTHX_ const OP *o)
3099 PERL_ARGS_ASSERT_DEBPROF;
3101 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3103 if (!PL_profiledata)
3104 Newxz(PL_profiledata, MAXO, U32);
3105 ++PL_profiledata[o->op_type];
3109 Perl_debprofdump(pTHX)
3112 if (!PL_profiledata)
3114 for (i = 0; i < MAXO; i++) {
3115 if (PL_profiledata[i])
3116 PerlIO_printf(Perl_debug_log,
3117 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3124 * ex: set ts=8 sts=4 sw=4 et: