3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
24 =head1 Display and Dump functions
28 #define PERL_IN_DUMP_C
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
97 Escapes at most the first C<count> chars of C<pv> and puts the results into
98 C<dsv> such that the size of the escaped string will not exceed C<max> chars
99 and will not contain any incomplete escape sequences. The number of bytes
100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101 When the C<dsv> parameter is null no escaping actually occurs, but the number
102 of bytes that would be escaped were it not null will be calculated.
104 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
105 will also be escaped.
107 Normally the SV will be cleared before the escaped string is prepared,
108 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111 if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
112 using C<is_utf8_string()> to determine if it is UTF-8.
114 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
116 non-ASCII chars will be escaped using this style; otherwise, only chars above
117 255 will be so escaped; other non printable chars will use octal or
118 common escaped patterns like C<\n>.
119 Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
120 then all chars below 255 will be treated as printable and
121 will be output as literals.
123 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
124 string will be escaped, regardless of max. If the output is to be in hex,
125 then it will be returned as a plain hex
126 sequence. Thus the output will either be a single char,
127 an octal escape sequence, a special escape like C<\n> or a hex value.
129 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130 not a C<"\\">. This is because regexes very often contain backslashed
131 sequences, whereas C<"%"> is not a particularly common character in patterns.
133 Returns a pointer to the escaped text as held by C<dsv>.
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 #define PV_ESCAPE_OCTBUFSIZE 32
150 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
151 const STRLEN count, const STRLEN max,
152 STRLEN * const escaped, const U32 flags )
154 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
155 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
156 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
157 STRLEN wrote = 0; /* chars written so far */
158 STRLEN chsize = 0; /* size of data to be written */
159 STRLEN readsize = 1; /* size of data just read */
160 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
161 const char *pv = str;
162 const char * const end = pv + count; /* end of string */
165 PERL_ARGS_ASSERT_PV_ESCAPE;
167 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
168 /* This won't alter the UTF-8 flag */
172 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
175 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
176 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
177 const U8 c = (U8)u & 0xFF;
180 || (flags & PERL_PV_ESCAPE_ALL)
181 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
183 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
184 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
187 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
188 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
190 : "%cx{%02" UVxf "}", esc, u);
192 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
195 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
199 case '\\' : /* FALLTHROUGH */
200 case '%' : if ( c == esc ) {
206 case '\v' : octbuf[1] = 'v'; break;
207 case '\t' : octbuf[1] = 't'; break;
208 case '\r' : octbuf[1] = 'r'; break;
209 case '\n' : octbuf[1] = 'n'; break;
210 case '\f' : octbuf[1] = 'f'; break;
218 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
219 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
220 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
223 else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
224 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
227 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
234 if ( max && (wrote + chsize > max) ) {
236 } else if (chsize > 1) {
238 sv_catpvn(dsv, octbuf, chsize);
241 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
242 can be appended raw to the dsv. If dsv happens to be
243 UTF-8 then we need catpvf to upgrade them for us.
244 Or add a new API call sv_catpvc(). Think about that name, and
245 how to keep it clear that it's unlike the s of catpvs, which is
246 really an array of octets, not a string. */
248 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
251 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
256 return dsv ? SvPVX(dsv) : NULL;
259 =for apidoc pv_pretty
261 Converts a string into something presentable, handling escaping via
262 C<pv_escape()> and supporting quoting and ellipses.
264 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
265 double quoted with any double quotes in the string escaped. Otherwise
266 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
269 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
270 string were output then an ellipsis C<...> will be appended to the
271 string. Note that this happens AFTER it has been quoted.
273 If C<start_color> is non-null then it will be inserted after the opening
274 quote (if there is one) but before the escaped text. If C<end_color>
275 is non-null then it will be inserted after the escaped text but before
276 any quotes or ellipses.
278 Returns a pointer to the prettified text as held by C<dsv>.
280 =for apidoc Amnh||PERL_PV_PRETTY_QUOTE
281 =for apidoc Amnh||PERL_PV_PRETTY_LTGT
282 =for apidoc Amnh||PERL_PV_PRETTY_ELLIPSES
288 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
289 const STRLEN max, char const * const start_color, char const * const end_color,
292 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
293 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
295 STRLEN max_adjust= 0;
298 PERL_ARGS_ASSERT_PV_PRETTY;
300 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
301 /* This won't alter the UTF-8 flag */
304 orig_cur= SvCUR(dsv);
307 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
309 if ( start_color != NULL )
310 sv_catpv(dsv, start_color);
312 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
315 assert(max > max_adjust);
316 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
317 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
319 assert(max > max_adjust);
322 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
324 if ( end_color != NULL )
325 sv_catpv(dsv, end_color);
328 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
330 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
331 sv_catpvs(dsv, "...");
333 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
334 while( SvCUR(dsv) - orig_cur < max )
342 =for apidoc pv_display
346 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
348 except that an additional "\0" will be appended to the string when
349 len > cur and pv[cur] is "\0".
351 Note that the final string may be up to 7 chars longer than pvlim.
357 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
359 PERL_ARGS_ASSERT_PV_DISPLAY;
361 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
362 if (len > cur && pv[cur] == '\0')
363 sv_catpvs( dsv, "\\0");
368 Perl_sv_peek(pTHX_ SV *sv)
371 SV * const t = sv_newmortal();
378 sv_catpvs(t, "VOID");
381 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
382 /* detect data corruption under memory poisoning */
383 sv_catpvs(t, "WILD");
386 else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
387 || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
389 if (sv == &PL_sv_undef) {
390 sv_catpvs(t, "SV_UNDEF");
391 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
392 SVs_GMG|SVs_SMG|SVs_RMG)) &&
396 else if (sv == &PL_sv_no) {
397 sv_catpvs(t, "SV_NO");
398 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
399 SVs_GMG|SVs_SMG|SVs_RMG)) &&
400 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
406 else if (sv == &PL_sv_yes) {
407 sv_catpvs(t, "SV_YES");
408 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
409 SVs_GMG|SVs_SMG|SVs_RMG)) &&
410 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
413 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
417 else if (sv == &PL_sv_zero) {
418 sv_catpvs(t, "SV_ZERO");
419 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
420 SVs_GMG|SVs_SMG|SVs_RMG)) &&
421 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
424 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
429 sv_catpvs(t, "SV_PLACEHOLDER");
430 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
431 SVs_GMG|SVs_SMG|SVs_RMG)) &&
437 else if (SvREFCNT(sv) == 0) {
441 else if (DEBUG_R_TEST_) {
444 /* is this SV on the tmps stack? */
445 for (ix=PL_tmps_ix; ix>=0; ix--) {
446 if (PL_tmps_stack[ix] == sv) {
451 if (is_tmp || SvREFCNT(sv) > 1) {
452 Perl_sv_catpvf(aTHX_ t, "<");
453 if (SvREFCNT(sv) > 1)
454 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
456 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
457 Perl_sv_catpvf(aTHX_ t, ">");
463 if (SvCUR(t) + unref > 10) {
464 SvCUR_set(t, unref + 3);
473 if (type == SVt_PVCV) {
474 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
476 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
477 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
480 } else if (type < SVt_LAST) {
481 sv_catpv(t, svshorttypenames[type]);
483 if (type == SVt_NULL)
486 sv_catpvs(t, "FREED");
491 if (!SvPVX_const(sv))
492 sv_catpvs(t, "(null)");
494 SV * const tmp = newSVpvs("");
498 SvOOK_offset(sv, delta);
499 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
501 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
503 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
504 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
506 SvREFCNT_dec_NN(tmp);
509 else if (SvNOKp(sv)) {
510 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
511 STORE_LC_NUMERIC_SET_STANDARD();
512 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
513 RESTORE_LC_NUMERIC();
515 else if (SvIOKp(sv)) {
517 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
519 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
527 if (TAINTING_get && sv && SvTAINTED(sv))
528 sv_catpvs(t, " [tainted]");
529 return SvPV_nolen(t);
533 =head1 Debugging Utilities
537 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
540 PERL_ARGS_ASSERT_DUMP_INDENT;
542 dump_vindent(level, file, pat, &args);
547 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
549 PERL_ARGS_ASSERT_DUMP_VINDENT;
550 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
551 PerlIO_vprintf(file, pat, *args);
555 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
556 * for each indent level as appropriate.
558 * bar contains bits indicating which indent columns should have a
559 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
560 * levels than bits in bar, then the first few indents are displayed
563 * The start of a new op is signalled by passing a value for level which
564 * has been negated and offset by 1 (so that level 0 is passed as -1 and
565 * can thus be distinguished from -0); in this case, emit a suitably
566 * indented blank line, then on the next line, display the op's sequence
567 * number, and make the final indent an '+----'.
571 * | FOO # level = 1, bar = 0b1
572 * | | # level =-2-1, bar = 0b11
574 * | BAZ # level = 2, bar = 0b10
578 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
579 const char* pat, ...)
583 bool newop = (level < 0);
587 /* start displaying a new op? */
589 UV seq = sequence_num(o);
593 /* output preceding blank line */
594 PerlIO_puts(file, " ");
595 for (i = level-1; i >= 0; i--)
596 PerlIO_puts(file, ( i == 0
597 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
600 PerlIO_puts(file, "\n");
602 /* output sequence number */
604 PerlIO_printf(file, "%-4" UVuf " ", seq);
606 PerlIO_puts(file, "???? ");
610 PerlIO_printf(file, " ");
612 for (i = level-1; i >= 0; i--)
614 (i == 0 && newop) ? "+--"
615 : (bar & (1 << i)) ? "| "
617 PerlIO_vprintf(file, pat, args);
622 /* display a link field (e.g. op_next) in the format
623 * ====> sequence_number [opname 0x123456]
627 S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file)
629 PerlIO_puts(file, " ===> ");
631 PerlIO_puts(file, "[SELF]\n");
633 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
634 sequence_num(o), OP_NAME(o), PTR2UV(o));
636 PerlIO_puts(file, "[0x0]\n");
642 Dumps the entire optree of the current program starting at C<PL_main_root> to
643 C<STDERR>. Also dumps the optrees for all visible subroutines in
652 dump_all_perl(FALSE);
656 Perl_dump_all_perl(pTHX_ bool justperl)
658 PerlIO_setlinebuf(Perl_debug_log);
660 op_dump(PL_main_root);
661 dump_packsubs_perl(PL_defstash, justperl);
665 =for apidoc dump_packsubs
667 Dumps the optrees for all visible subroutines in C<stash>.
673 Perl_dump_packsubs(pTHX_ const HV *stash)
675 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
676 dump_packsubs_perl(stash, FALSE);
680 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
684 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
688 for (i = 0; i <= (I32) HvMAX(stash); i++) {
690 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
691 GV * gv = (GV *)HeVAL(entry);
692 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
693 /* unfake a fake GV */
694 (void)CvGV(SvRV(gv));
695 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
698 dump_sub_perl(gv, justperl);
701 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
702 const HV * const hv = GvHV(gv);
703 if (hv && (hv != PL_defstash))
704 dump_packsubs_perl(hv, justperl); /* nested package */
711 Perl_dump_sub(pTHX_ const GV *gv)
713 PERL_ARGS_ASSERT_DUMP_SUB;
714 dump_sub_perl(gv, FALSE);
718 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
722 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
724 cv = isGV_with_GP(gv) ? GvCV(gv) :
725 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
726 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
729 if (isGV_with_GP(gv)) {
730 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
731 SV *escsv = newSVpvs_flags("", SVs_TEMP);
734 gv_fullname3(namesv, gv, NULL);
735 namepv = SvPV_const(namesv, namelen);
736 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
737 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
739 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
742 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
744 (int)CvXSUBANY(cv).any_i32);
748 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
752 Perl_dump_form(pTHX_ const GV *gv)
754 SV * const sv = sv_newmortal();
756 PERL_ARGS_ASSERT_DUMP_FORM;
758 gv_fullname3(sv, gv, NULL);
759 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
760 if (CvROOT(GvFORM(gv)))
761 op_dump(CvROOT(GvFORM(gv)));
763 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
769 op_dump(PL_eval_root);
773 /* returns a temp SV displaying the name of a GV. Handles the case where
774 * a GV is in fact a ref to a CV */
777 S_gv_display(pTHX_ GV *gv)
779 SV * const name = newSVpvs_flags("", SVs_TEMP);
781 SV * const raw = newSVpvs_flags("", SVs_TEMP);
785 if (isGV_with_GP(gv))
786 gv_fullname3(raw, gv, NULL);
789 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
790 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
791 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
793 rawpv = SvPV_const(raw, len);
794 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
797 sv_catpvs(name, "(NULL)");
806 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
810 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
817 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
820 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
821 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
822 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
825 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
827 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
828 SV * const tmpsv = pm_description(pm);
829 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
830 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
831 SvREFCNT_dec_NN(tmpsv);
834 if (pm->op_type == OP_SPLIT)
835 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
836 "TARGOFF/GV = 0x%" UVxf "\n",
837 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
839 if (pm->op_pmreplrootu.op_pmreplroot) {
840 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
841 S_do_op_dump_bar(aTHX_ level + 2,
842 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
843 file, pm->op_pmreplrootu.op_pmreplroot);
847 if (pm->op_code_list) {
848 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
849 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
850 S_do_op_dump_bar(aTHX_ level + 2,
851 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
852 file, pm->op_code_list);
855 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
856 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
862 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
864 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
865 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
869 const struct flag_to_name pmflags_flags_names[] = {
870 {PMf_CONST, ",CONST"},
872 {PMf_GLOBAL, ",GLOBAL"},
873 {PMf_CONTINUE, ",CONTINUE"},
874 {PMf_RETAINT, ",RETAINT"},
876 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
877 {PMf_HAS_CV, ",HAS_CV"},
878 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
879 {PMf_IS_QR, ",IS_QR"}
883 S_pm_description(pTHX_ const PMOP *pm)
885 SV * const desc = newSVpvs("");
886 const REGEXP * const regex = PM_GETRE(pm);
887 const U32 pmflags = pm->op_pmflags;
889 PERL_ARGS_ASSERT_PM_DESCRIPTION;
891 if (pmflags & PMf_ONCE)
892 sv_catpvs(desc, ",ONCE");
894 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
895 sv_catpvs(desc, ":USED");
897 if (pmflags & PMf_USED)
898 sv_catpvs(desc, ":USED");
902 if (RX_ISTAINTED(regex))
903 sv_catpvs(desc, ",TAINTED");
904 if (RX_CHECK_SUBSTR(regex)) {
905 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
906 sv_catpvs(desc, ",SCANFIRST");
907 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
908 sv_catpvs(desc, ",ALL");
910 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
911 sv_catpvs(desc, ",SKIPWHITE");
914 append_flags(desc, pmflags, pmflags_flags_names);
919 Perl_pmop_dump(pTHX_ PMOP *pm)
921 do_pmop_dump(0, Perl_debug_log, pm);
924 /* Return a unique integer to represent the address of op o.
925 * If it already exists in PL_op_sequence, just return it;
927 * *** Note that this isn't thread-safe */
930 S_sequence_num(pTHX_ const OP *o)
939 op = newSVuv(PTR2UV(o));
941 key = SvPV_const(op, len);
943 PL_op_sequence = newHV();
944 seq = hv_fetch(PL_op_sequence, key, len, 0);
947 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
955 const struct flag_to_name op_flags_names[] = {
957 {OPf_PARENS, ",PARENS"},
960 {OPf_STACKED, ",STACKED"},
961 {OPf_SPECIAL, ",SPECIAL"}
965 /* indexed by enum OPclass */
966 const char * const op_class_names[] = {
984 /* dump an op and any children. level indicates the initial indent.
985 * The bits of bar indicate which indents should receive a vertical bar.
986 * For example if level == 5 and bar == 0b01101, then the indent prefix
987 * emitted will be (not including the <>'s):
990 * 55554444333322221111
992 * For heavily nested output, the level may exceed the number of bits
993 * in bar; in this case the first few columns in the output will simply
994 * not have a bar, which is harmless.
998 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
1000 const OPCODE optype = o->op_type;
1002 PERL_ARGS_ASSERT_DO_OP_DUMP;
1004 /* print op header line */
1006 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
1008 if (optype == OP_NULL && o->op_targ)
1009 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
1011 PerlIO_printf(file, " %s(0x%" UVxf ")",
1012 op_class_names[op_class(o)], PTR2UV(o));
1013 S_opdump_link(aTHX_ o, o->op_next, file);
1015 /* print op common fields */
1018 S_opdump_indent(aTHX_ o, level, bar, file, "PARENT");
1019 S_opdump_link(aTHX_ o, op_parent((OP*)o), file);
1021 else if (!OpHAS_SIBLING(o)) {
1023 OP *p = o->op_sibparent;
1024 if (!p || !(p->op_flags & OPf_KIDS))
1027 OP *kid = cUNOPx(p)->op_first;
1029 kid = OpSIBLING(kid);
1037 S_opdump_indent(aTHX_ o, level, bar, file,
1038 "*** WILD PARENT 0x%p\n", p);
1042 if (o->op_targ && optype != OP_NULL)
1043 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1046 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1047 SV * const tmpsv = newSVpvs("");
1048 switch (o->op_flags & OPf_WANT) {
1050 sv_catpvs(tmpsv, ",VOID");
1052 case OPf_WANT_SCALAR:
1053 sv_catpvs(tmpsv, ",SCALAR");
1056 sv_catpvs(tmpsv, ",LIST");
1059 sv_catpvs(tmpsv, ",UNKNOWN");
1062 append_flags(tmpsv, o->op_flags, op_flags_names);
1063 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1064 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1065 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1066 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1067 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1068 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1069 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1072 if (o->op_private) {
1073 U16 oppriv = o->op_private;
1074 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1079 tmpsv = newSVpvs("");
1080 for (; !stop; op_ix++) {
1081 U16 entry = PL_op_private_bitdefs[op_ix];
1082 U16 bit = (entry >> 2) & 7;
1083 U16 ix = entry >> 5;
1089 I16 const *p = &PL_op_private_bitfields[ix];
1090 U16 bitmin = (U16) *p++;
1097 for (i = bitmin; i<= bit; i++)
1100 val = (oppriv & mask);
1103 && PL_op_private_labels[label] == '-'
1104 && PL_op_private_labels[label+1] == '\0'
1106 /* display as raw number */
1119 if (val == 0 && enum_label == -1)
1120 /* don't display anonymous zero values */
1123 sv_catpvs(tmpsv, ",");
1125 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1126 sv_catpvs(tmpsv, "=");
1128 if (enum_label == -1)
1129 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1131 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1136 if ( oppriv & (1<<bit)
1137 && !(PL_op_private_labels[ix] == '-'
1138 && PL_op_private_labels[ix+1] == '\0'))
1141 sv_catpvs(tmpsv, ",");
1142 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1147 sv_catpvs(tmpsv, ",");
1148 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1151 if (tmpsv && SvCUR(tmpsv)) {
1152 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1153 SvPVX_const(tmpsv) + 1);
1155 S_opdump_indent(aTHX_ o, level, bar, file,
1156 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1164 S_opdump_indent(aTHX_ o, level, bar, file,
1165 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1167 S_opdump_indent(aTHX_ o, level, bar, file,
1168 "GV = %" SVf " (0x%" UVxf ")\n",
1169 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1175 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1176 UV i, count = items[-1].uv;
1178 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1179 for (i=0; i < count; i++)
1180 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1181 "%" UVuf " => 0x%" UVxf "\n",
1186 case OP_MULTICONCAT:
1187 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
1188 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
1189 /* XXX really ought to dump each field individually,
1190 * but that's too much like hard work */
1191 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1192 SVfARG(multiconcat_stringify(o)));
1197 case OP_METHOD_NAMED:
1198 case OP_METHOD_SUPER:
1199 case OP_METHOD_REDIR:
1200 case OP_METHOD_REDIR_SUPER:
1201 #ifndef USE_ITHREADS
1202 /* with ITHREADS, consts are stored in the pad, and the right pad
1203 * may not be active here, so skip */
1204 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1205 SvPEEK(cMETHOPx_meth(o)));
1209 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1215 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1216 (UV)CopLINE(cCOPo));
1218 if (CopSTASHPV(cCOPo)) {
1219 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1220 HV *stash = CopSTASH(cCOPo);
1221 const char * const hvname = HvNAME_get(stash);
1223 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1224 generic_pv_escape(tmpsv, hvname,
1225 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1228 if (CopLABEL(cCOPo)) {
1229 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1232 const char *label = CopLABEL_len_flags(cCOPo,
1233 &label_len, &label_flags);
1234 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1235 generic_pv_escape( tmpsv, label, label_len,
1236 (label_flags & SVf_UTF8)));
1239 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1240 (unsigned int)cCOPo->cop_seq);
1245 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1246 S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file);
1247 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1248 S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file);
1249 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1250 S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file);
1270 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1271 S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
1277 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1285 if (o->op_private & OPpREFCOUNTED)
1286 S_opdump_indent(aTHX_ o, level, bar, file,
1287 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1295 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1298 SV * const label = newSVpvs_flags("", SVs_TEMP);
1299 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1300 S_opdump_indent(aTHX_ o, level, bar, file,
1301 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1302 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1308 if (o->op_private & OPpTRANS_USE_SVOP) {
1309 /* utf8: table stored as an inversion map */
1310 #ifndef USE_ITHREADS
1311 /* with ITHREADS, it is stored in the pad, and the right pad
1312 * may not be active here, so skip */
1313 S_opdump_indent(aTHX_ o, level, bar, file,
1314 "INVMAP = 0x%" UVxf "\n",
1315 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1319 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1320 SSize_t i, size = tbl->size;
1322 S_opdump_indent(aTHX_ o, level, bar, file,
1323 "TABLE = 0x%" UVxf "\n",
1325 S_opdump_indent(aTHX_ o, level, bar, file,
1326 " SIZE: 0x%" UVxf "\n", (UV)size);
1328 /* dump size+1 values, to include the extra slot at the end */
1329 for (i = 0; i <= size; i++) {
1330 short val = tbl->map[i];
1332 S_opdump_indent(aTHX_ o, level, bar, file,
1333 " %4" UVxf ":", (UV)i);
1335 PerlIO_printf(file, " %2" IVdf, (IV)val);
1337 PerlIO_printf(file, " %02" UVxf, (UV)val);
1339 if ( i == size || (i & 0xf) == 0xf)
1340 PerlIO_printf(file, "\n");
1349 if (o->op_flags & OPf_KIDS) {
1353 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1354 S_do_op_dump_bar(aTHX_ level,
1355 (bar | cBOOL(OpHAS_SIBLING(kid))),
1362 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1364 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1371 Dumps the optree starting at OP C<o> to C<STDERR>.
1377 Perl_op_dump(pTHX_ const OP *o)
1379 PERL_ARGS_ASSERT_OP_DUMP;
1380 do_op_dump(0, Perl_debug_log, o);
1384 Perl_gv_dump(pTHX_ GV *gv)
1388 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1391 PerlIO_printf(Perl_debug_log, "{}\n");
1394 sv = sv_newmortal();
1395 PerlIO_printf(Perl_debug_log, "{\n");
1396 gv_fullname3(sv, gv, NULL);
1397 name = SvPV_const(sv, len);
1398 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1399 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1400 if (gv != GvEGV(gv)) {
1401 gv_efullname3(sv, GvEGV(gv), NULL);
1402 name = SvPV_const(sv, len);
1403 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1404 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1406 (void)PerlIO_putc(Perl_debug_log, '\n');
1407 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1411 /* map magic types to the symbolic names
1412 * (with the PERL_MAGIC_ prefixed stripped)
1415 static const struct { const char type; const char *name; } magic_names[] = {
1416 #include "mg_names.inc"
1417 /* this null string terminates the list */
1422 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1424 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1426 for (; mg; mg = mg->mg_moremagic) {
1427 Perl_dump_indent(aTHX_ level, file,
1428 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1429 if (mg->mg_virtual) {
1430 const MGVTBL * const v = mg->mg_virtual;
1431 if (v >= PL_magic_vtables
1432 && v < PL_magic_vtables + magic_vtable_max) {
1433 const U32 i = v - PL_magic_vtables;
1434 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1437 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1438 UVxf "\n", PTR2UV(v));
1441 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1444 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1448 const char *name = NULL;
1449 for (n = 0; magic_names[n].name; n++) {
1450 if (mg->mg_type == magic_names[n].type) {
1451 name = magic_names[n].name;
1456 Perl_dump_indent(aTHX_ level, file,
1457 " MG_TYPE = PERL_MAGIC_%s\n", name);
1459 Perl_dump_indent(aTHX_ level, file,
1460 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1464 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1465 if (mg->mg_type == PERL_MAGIC_envelem &&
1466 mg->mg_flags & MGf_TAINTEDDIR)
1467 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1468 if (mg->mg_type == PERL_MAGIC_regex_global &&
1469 mg->mg_flags & MGf_MINMATCH)
1470 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1471 if (mg->mg_flags & MGf_REFCOUNTED)
1472 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1473 if (mg->mg_flags & MGf_GSKIP)
1474 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1475 if (mg->mg_flags & MGf_COPY)
1476 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1477 if (mg->mg_flags & MGf_DUP)
1478 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1479 if (mg->mg_flags & MGf_LOCAL)
1480 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1481 if (mg->mg_type == PERL_MAGIC_regex_global &&
1482 mg->mg_flags & MGf_BYTES)
1483 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1486 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1487 PTR2UV(mg->mg_obj));
1488 if (mg->mg_type == PERL_MAGIC_qr) {
1489 REGEXP* const re = (REGEXP *)mg->mg_obj;
1490 SV * const dsv = sv_newmortal();
1491 const char * const s
1492 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1494 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1495 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1497 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1498 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1501 if (mg->mg_flags & MGf_REFCOUNTED)
1502 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1505 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1507 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1508 if (mg->mg_len >= 0) {
1509 if (mg->mg_type != PERL_MAGIC_utf8) {
1510 SV * const sv = newSVpvs("");
1511 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1512 SvREFCNT_dec_NN(sv);
1515 else if (mg->mg_len == HEf_SVKEY) {
1516 PerlIO_puts(file, " => HEf_SVKEY\n");
1517 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1518 maxnest, dumpops, pvlim); /* MG is already +1 */
1521 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1526 " does not know how to handle this MG_LEN"
1528 (void)PerlIO_putc(file, '\n');
1530 if (mg->mg_type == PERL_MAGIC_utf8) {
1531 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1534 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1535 Perl_dump_indent(aTHX_ level, file,
1536 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1539 (UV)cache[i * 2 + 1]);
1546 Perl_magic_dump(pTHX_ const MAGIC *mg)
1548 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1552 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1556 PERL_ARGS_ASSERT_DO_HV_DUMP;
1558 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1559 if (sv && (hvname = HvNAME_get(sv)))
1561 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1562 name which quite legally could contain insane things like tabs, newlines, nulls or
1563 other scary crap - this should produce sane results - except maybe for unicode package
1564 names - but we will wait for someone to file a bug on that - demerphq */
1565 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1566 PerlIO_printf(file, "\t\"%s\"\n",
1567 generic_pv_escape( tmpsv, hvname,
1568 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1571 (void)PerlIO_putc(file, '\n');
1575 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1577 PERL_ARGS_ASSERT_DO_GV_DUMP;
1579 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1580 if (sv && GvNAME(sv)) {
1581 SV * const tmpsv = newSVpvs("");
1582 PerlIO_printf(file, "\t\"%s\"\n",
1583 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1586 (void)PerlIO_putc(file, '\n');
1590 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1592 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1594 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1595 if (sv && GvNAME(sv)) {
1596 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1598 HV * const stash = GvSTASH(sv);
1599 PerlIO_printf(file, "\t");
1600 /* TODO might have an extra \" here */
1601 if (stash && (hvname = HvNAME_get(stash))) {
1602 PerlIO_printf(file, "\"%s\" :: \"",
1603 generic_pv_escape(tmp, hvname,
1604 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1606 PerlIO_printf(file, "%s\"\n",
1607 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1610 (void)PerlIO_putc(file, '\n');
1613 const struct flag_to_name first_sv_flags_names[] = {
1614 {SVs_TEMP, "TEMP,"},
1615 {SVs_OBJECT, "OBJECT,"},
1624 const struct flag_to_name second_sv_flags_names[] = {
1626 {SVf_FAKE, "FAKE,"},
1627 {SVf_READONLY, "READONLY,"},
1628 {SVf_PROTECT, "PROTECT,"},
1629 {SVf_BREAK, "BREAK,"},
1635 const struct flag_to_name cv_flags_names[] = {
1636 {CVf_ANON, "ANON,"},
1637 {CVf_UNIQUE, "UNIQUE,"},
1638 {CVf_CLONE, "CLONE,"},
1639 {CVf_CLONED, "CLONED,"},
1640 {CVf_CONST, "CONST,"},
1641 {CVf_NODEBUG, "NODEBUG,"},
1642 {CVf_LVALUE, "LVALUE,"},
1643 {CVf_METHOD, "METHOD,"},
1644 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1645 {CVf_CVGV_RC, "CVGV_RC,"},
1646 {CVf_DYNFILE, "DYNFILE,"},
1647 {CVf_AUTOLOAD, "AUTOLOAD,"},
1648 {CVf_HASEVAL, "HASEVAL,"},
1649 {CVf_SLABBED, "SLABBED,"},
1650 {CVf_NAMED, "NAMED,"},
1651 {CVf_LEXICAL, "LEXICAL,"},
1652 {CVf_ISXSUB, "ISXSUB,"}
1655 const struct flag_to_name hv_flags_names[] = {
1656 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1657 {SVphv_LAZYDEL, "LAZYDEL,"},
1658 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1659 {SVf_AMAGIC, "OVERLOAD,"},
1660 {SVphv_CLONEABLE, "CLONEABLE,"}
1663 const struct flag_to_name gp_flags_names[] = {
1664 {GVf_INTRO, "INTRO,"},
1665 {GVf_MULTI, "MULTI,"},
1666 {GVf_ASSUMECV, "ASSUMECV,"},
1669 const struct flag_to_name gp_flags_imported_names[] = {
1670 {GVf_IMPORTED_SV, " SV"},
1671 {GVf_IMPORTED_AV, " AV"},
1672 {GVf_IMPORTED_HV, " HV"},
1673 {GVf_IMPORTED_CV, " CV"},
1676 /* NOTE: this structure is mostly duplicative of one generated by
1677 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1678 * the two. - Yves */
1679 const struct flag_to_name regexp_extflags_names[] = {
1680 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1681 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1682 {RXf_PMf_FOLD, "PMf_FOLD,"},
1683 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1684 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1685 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1686 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1687 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1688 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1689 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1690 {RXf_CHECK_ALL, "CHECK_ALL,"},
1691 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1692 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1693 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1694 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1695 {RXf_SPLIT, "SPLIT,"},
1696 {RXf_COPY_DONE, "COPY_DONE,"},
1697 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1698 {RXf_TAINTED, "TAINTED,"},
1699 {RXf_START_ONLY, "START_ONLY,"},
1700 {RXf_SKIPWHITE, "SKIPWHITE,"},
1701 {RXf_WHITE, "WHITE,"},
1702 {RXf_NULL, "NULL,"},
1705 /* NOTE: this structure is mostly duplicative of one generated by
1706 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1707 * the two. - Yves */
1708 const struct flag_to_name regexp_core_intflags_names[] = {
1709 {PREGf_SKIP, "SKIP,"},
1710 {PREGf_IMPLICIT, "IMPLICIT,"},
1711 {PREGf_NAUGHTY, "NAUGHTY,"},
1712 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1713 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1714 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1715 {PREGf_NOSCAN, "NOSCAN,"},
1716 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1717 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1718 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1719 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1720 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1723 /* Perl_do_sv_dump():
1725 * level: amount to indent the output
1726 * sv: the object to dump
1727 * nest: the current level of recursion
1728 * maxnest: the maximum allowed level of recursion
1729 * dumpops: if true, also dump the ops associated with a CV
1730 * pvlim: limit on the length of any strings that are output
1734 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1742 PERL_ARGS_ASSERT_DO_SV_DUMP;
1745 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1749 flags = SvFLAGS(sv);
1752 /* process general SV flags */
1754 d = Perl_newSVpvf(aTHX_
1755 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1756 PTR2UV(SvANY(sv)), PTR2UV(sv),
1757 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1758 (int)(PL_dumpindent*level), "");
1760 if ((flags & SVs_PADSTALE))
1761 sv_catpvs(d, "PADSTALE,");
1762 if ((flags & SVs_PADTMP))
1763 sv_catpvs(d, "PADTMP,");
1764 append_flags(d, flags, first_sv_flags_names);
1765 if (flags & SVf_ROK) {
1766 sv_catpvs(d, "ROK,");
1767 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
1769 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1770 append_flags(d, flags, second_sv_flags_names);
1771 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1772 && type != SVt_PVAV) {
1773 if (SvPCS_IMPORTED(sv))
1774 sv_catpvs(d, "PCS_IMPORTED,");
1776 sv_catpvs(d, "SCREAM,");
1779 /* process type-specific SV flags */
1784 append_flags(d, CvFLAGS(sv), cv_flags_names);
1787 append_flags(d, flags, hv_flags_names);
1791 if (isGV_with_GP(sv)) {
1792 append_flags(d, GvFLAGS(sv), gp_flags_names);
1794 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1795 sv_catpvs(d, "IMPORT");
1796 if (GvIMPORTED(sv) == GVf_IMPORTED)
1797 sv_catpvs(d, "ALL,");
1800 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1801 sv_catpvs(d, " ),");
1807 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1813 /* SVphv_SHAREKEYS is also 0x20000000 */
1814 if ((type != SVt_PVHV) && SvUTF8(sv))
1815 sv_catpvs(d, "UTF8");
1817 if (*(SvEND(d) - 1) == ',') {
1818 SvCUR_set(d, SvCUR(d) - 1);
1819 SvPVX(d)[SvCUR(d)] = '\0';
1824 /* dump initial SV details */
1826 #ifdef DEBUG_LEAKING_SCALARS
1827 Perl_dump_indent(aTHX_ level, file,
1828 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1829 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1831 sv->sv_debug_inpad ? "for" : "by",
1832 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1833 PTR2UV(sv->sv_debug_parent),
1837 Perl_dump_indent(aTHX_ level, file, "SV = ");
1841 if (type < SVt_LAST) {
1842 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1844 if (type == SVt_NULL) {
1849 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1854 /* Dump general SV fields */
1856 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1857 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1858 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1859 || (type == SVt_IV && !SvROK(sv))) {
1862 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1864 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1865 (void)PerlIO_putc(file, '\n');
1868 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1869 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1870 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1871 || type == SVt_NV) {
1872 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1873 STORE_LC_NUMERIC_SET_STANDARD();
1874 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1875 RESTORE_LC_NUMERIC();
1879 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1882 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1885 if (type < SVt_PV) {
1890 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1891 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1892 const bool re = isREGEXP(sv);
1893 const char * const ptr =
1894 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1898 SvOOK_offset(sv, delta);
1899 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1904 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1907 PerlIO_printf(file, "( %s . ) ",
1908 pv_display(d, ptr - delta, delta, 0,
1911 if (type == SVt_INVLIST) {
1912 PerlIO_printf(file, "\n");
1913 /* 4 blanks indents 2 beyond the PV, etc */
1914 _invlist_dump(file, level, " ", sv);
1917 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1920 if (SvUTF8(sv)) /* the 6? \x{....} */
1921 PerlIO_printf(file, " [UTF8 \"%s\"]",
1922 sv_uni_display(d, sv, 6 * SvCUR(sv),
1924 PerlIO_printf(file, "\n");
1926 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1927 if (re && type == SVt_PVLV)
1928 /* LV-as-REGEXP usurps len field to store pointer to
1930 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1931 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1933 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1935 #ifdef PERL_COPY_ON_WRITE
1936 if (SvIsCOW(sv) && SvLEN(sv))
1937 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1942 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1945 if (type >= SVt_PVMG) {
1947 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1949 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1951 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1952 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1957 /* Dump type-specific SV fields */
1961 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1962 PTR2UV(AvARRAY(sv)));
1963 if (AvARRAY(sv) != AvALLOC(sv)) {
1964 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1965 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1966 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1967 PTR2UV(AvALLOC(sv)));
1970 (void)PerlIO_putc(file, '\n');
1971 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1973 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1976 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1977 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
1978 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1979 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1980 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1982 SV **svp = AvARRAY(MUTABLE_AV(sv));
1984 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1987 SV* const elt = *svp;
1988 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1990 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1997 struct xpvhv_aux *const aux = HvAUX(sv);
1998 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1999 (UV)aux->xhv_aux_flags);
2001 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
2002 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
2003 if (HvARRAY(sv) && usedkeys) {
2004 /* Show distribution of HEs in the ARRAY */
2006 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
2009 U32 pow2 = 2, keys = usedkeys;
2010 NV theoret, sum = 0;
2012 PerlIO_printf(file, " (");
2013 Zero(freq, FREQ_MAX + 1, int);
2014 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2017 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
2019 if (count > FREQ_MAX)
2025 for (i = 0; i <= max; i++) {
2027 PerlIO_printf(file, "%d%s:%d", i,
2028 (i == FREQ_MAX) ? "+" : "",
2031 PerlIO_printf(file, ", ");
2034 (void)PerlIO_putc(file, ')');
2035 /* The "quality" of a hash is defined as the total number of
2036 comparisons needed to access every element once, relative
2037 to the expected number needed for a random hash.
2039 The total number of comparisons is equal to the sum of
2040 the squares of the number of entries in each bucket.
2041 For a random hash of n keys into k buckets, the expected
2046 for (i = max; i > 0; i--) { /* Precision: count down. */
2047 sum += freq[i] * i * i;
2049 while ((keys = keys >> 1))
2052 theoret += theoret * (theoret-1)/pow2;
2053 (void)PerlIO_putc(file, '\n');
2054 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2055 NVff "%%", theoret/sum*100);
2057 (void)PerlIO_putc(file, '\n');
2058 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2062 HE **ents = HvARRAY(sv);
2065 HE *const *const last = ents + HvMAX(sv);
2066 count = last + 1 - ents;
2071 } while (++ents <= last);
2074 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2077 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2080 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2081 (IV)HvRITER_get(sv));
2082 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2083 PTR2UV(HvEITER_get(sv)));
2084 #ifdef PERL_HASH_RANDOMIZE_KEYS
2085 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2086 (UV)HvRAND_get(sv));
2087 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2088 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2089 (UV)HvLASTRAND_get(sv));
2092 (void)PerlIO_putc(file, '\n');
2095 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2096 if (mg && mg->mg_obj) {
2097 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2101 const char * const hvname = HvNAME_get(sv);
2103 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2104 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2105 generic_pv_escape( tmpsv, hvname,
2106 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2111 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2112 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2113 if (HvAUX(sv)->xhv_name_count)
2114 Perl_dump_indent(aTHX_
2115 level, file, " NAMECOUNT = %" IVdf "\n",
2116 (IV)HvAUX(sv)->xhv_name_count
2118 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2119 const I32 count = HvAUX(sv)->xhv_name_count;
2121 SV * const names = newSVpvs_flags("", SVs_TEMP);
2122 /* The starting point is the first element if count is
2123 positive and the second element if count is negative. */
2124 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2125 + (count < 0 ? 1 : 0);
2126 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2127 + (count < 0 ? -count : count);
2128 while (hekp < endp) {
2130 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2131 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2132 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2134 /* This should never happen. */
2135 sv_catpvs(names, ", (null)");
2139 Perl_dump_indent(aTHX_
2140 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2144 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2145 const char *const hvename = HvENAME_get(sv);
2146 Perl_dump_indent(aTHX_
2147 level, file, " ENAME = \"%s\"\n",
2148 generic_pv_escape(tmp, hvename,
2149 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2153 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2155 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2159 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2160 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2162 generic_pv_escape( tmpsv, meta->mro_which->name,
2163 meta->mro_which->length,
2164 (meta->mro_which->kflags & HVhek_UTF8)),
2165 PTR2UV(meta->mro_which));
2166 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2168 (UV)meta->cache_gen);
2169 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2171 if (meta->mro_linear_all) {
2172 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2174 PTR2UV(meta->mro_linear_all));
2175 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2178 if (meta->mro_linear_current) {
2179 Perl_dump_indent(aTHX_ level, file,
2180 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2181 PTR2UV(meta->mro_linear_current));
2182 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2185 if (meta->mro_nextmethod) {
2186 Perl_dump_indent(aTHX_ level, file,
2187 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2188 PTR2UV(meta->mro_nextmethod));
2189 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2193 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2195 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2200 if (nest < maxnest) {
2201 HV * const hv = MUTABLE_HV(sv);
2206 int count = maxnest - nest;
2207 for (i=0; i <= HvMAX(hv); i++) {
2208 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2215 if (count-- <= 0) goto DONEHV;
2218 keysv = hv_iterkeysv(he);
2219 keypv = SvPV_const(keysv, len);
2222 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2224 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2225 if (HvEITER_get(hv) == he)
2226 PerlIO_printf(file, "[CURRENT] ");
2227 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2228 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2235 } /* case SVt_PVHV */
2238 if (CvAUTOLOAD(sv)) {
2239 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2241 const char *const name = SvPV_const(sv, len);
2242 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2243 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2246 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2247 const char *const proto = CvPROTO(sv);
2248 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2249 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2254 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2255 if (!CvISXSUB(sv)) {
2258 Perl_dump_indent(aTHX_ level, file,
2259 " SLAB = 0x%" UVxf "\n",
2260 PTR2UV(CvSTART(sv)));
2262 Perl_dump_indent(aTHX_ level, file,
2263 " START = 0x%" UVxf " ===> %" IVdf "\n",
2264 PTR2UV(CvSTART(sv)),
2265 (IV)sequence_num(CvSTART(sv)));
2267 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2268 PTR2UV(CvROOT(sv)));
2269 if (CvROOT(sv) && dumpops) {
2270 do_op_dump(level+1, file, CvROOT(sv));
2273 SV * const constant = cv_const_sv((const CV *)sv);
2275 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2278 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2280 PTR2UV(CvXSUBANY(sv).any_ptr));
2281 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2284 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2285 (IV)CvXSUBANY(sv).any_i32);
2289 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2290 HEK_KEY(CvNAME_HEK((CV *)sv)));
2291 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2292 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2293 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2294 IVdf "\n", (IV)CvDEPTH(sv));
2295 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2297 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2298 if (!CvISXSUB(sv)) {
2299 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2300 if (nest < maxnest) {
2301 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2305 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2307 const CV * const outside = CvOUTSIDE(sv);
2308 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2311 : CvANON(outside) ? "ANON"
2312 : (outside == PL_main_cv) ? "MAIN"
2313 : CvUNIQUE(outside) ? "UNIQUE"
2316 newSVpvs_flags("", SVs_TEMP),
2317 GvNAME(CvGV(outside)),
2318 GvNAMELEN(CvGV(outside)),
2319 GvNAMEUTF8(CvGV(outside)))
2323 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2324 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2329 if (type == SVt_PVLV) {
2330 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2331 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2332 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2333 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2334 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2335 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2336 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2339 if (isREGEXP(sv)) goto dumpregexp;
2340 if (!isGV_with_GP(sv))
2343 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2344 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2345 generic_pv_escape(tmpsv, GvNAME(sv),
2349 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2350 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2351 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2352 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2355 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2356 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2357 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2358 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2359 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2360 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2361 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2362 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2363 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2367 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2368 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2369 do_gv_dump (level, file, " EGV", GvEGV(sv));
2372 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2373 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2374 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2375 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2376 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2377 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2378 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2380 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2381 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2382 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2384 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2385 PTR2UV(IoTOP_GV(sv)));
2386 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2387 maxnest, dumpops, pvlim);
2389 /* Source filters hide things that are not GVs in these three, so let's
2390 be careful out there. */
2392 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2393 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2394 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2396 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2397 PTR2UV(IoFMT_GV(sv)));
2398 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2399 maxnest, dumpops, pvlim);
2401 if (IoBOTTOM_NAME(sv))
2402 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2403 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2404 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2406 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2407 PTR2UV(IoBOTTOM_GV(sv)));
2408 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2409 maxnest, dumpops, pvlim);
2411 if (isPRINT(IoTYPE(sv)))
2412 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2414 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2415 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2420 struct regexp * const r = ReANY((REGEXP*)sv);
2422 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2424 append_flags(d, flags, names); \
2425 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2426 SvCUR_set(d, SvCUR(d) - 1); \
2427 SvPVX(d)[SvCUR(d)] = '\0'; \
2430 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2431 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2432 (UV)(r->compflags), SvPVX_const(d));
2434 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2435 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2436 (UV)(r->extflags), SvPVX_const(d));
2438 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2439 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2440 if (r->engine == &PL_core_reg_engine) {
2441 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2442 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2443 (UV)(r->intflags), SvPVX_const(d));
2445 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2448 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2449 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2451 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2452 (UV)(r->lastparen));
2453 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2454 (UV)(r->lastcloseparen));
2455 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2457 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2458 (IV)(r->minlenret));
2459 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2461 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2462 (UV)(r->pre_prefix));
2463 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2465 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2466 (IV)(r->suboffset));
2467 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2468 (IV)(r->subcoffset));
2470 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2472 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2474 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2475 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2476 PTR2UV(r->mother_re));
2477 if (nest < maxnest && r->mother_re)
2478 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2479 maxnest, dumpops, pvlim);
2480 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2481 PTR2UV(r->paren_names));
2482 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2483 PTR2UV(r->substrs));
2484 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2485 PTR2UV(r->pprivate));
2486 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2488 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2489 PTR2UV(r->qr_anoncv));
2491 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2492 PTR2UV(r->saved_copy));
2503 Dumps the contents of an SV to the C<STDERR> filehandle.
2505 For an example of its output, see L<Devel::Peek>.
2511 Perl_sv_dump(pTHX_ SV *sv)
2513 if (sv && SvROK(sv))
2514 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2516 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2520 Perl_runops_debug(pTHX)
2522 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2523 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2525 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2529 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2532 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2534 #ifdef PERL_TRACE_OPS
2535 ++PL_op_exec_cnt[PL_op->op_type];
2537 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2538 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2539 Perl_croak_nocontext(
2540 "panic: previous op failed to extend arg stack: "
2541 "base=%p, sp=%p, hwm=%p\n",
2542 PL_stack_base, PL_stack_sp,
2543 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2544 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2549 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2550 PerlIO_printf(Perl_debug_log,
2551 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2552 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2553 PTR2UV(*PL_watchaddr));
2554 if (DEBUG_s_TEST_) {
2555 if (DEBUG_v_TEST_) {
2556 PerlIO_printf(Perl_debug_log, "\n");
2564 if (DEBUG_t_TEST_) debop(PL_op);
2565 if (DEBUG_P_TEST_) debprof(PL_op);
2570 PERL_DTRACE_PROBE_OP(PL_op);
2571 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2572 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2575 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2576 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2577 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2584 /* print the names of the n lexical vars starting at pad offset off */
2587 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2590 CV * const cv = deb_curcv(cxstack_ix);
2591 PADNAMELIST *comppad = NULL;
2595 PADLIST * const padlist = CvPADLIST(cv);
2596 comppad = PadlistNAMES(padlist);
2599 PerlIO_printf(Perl_debug_log, "(");
2600 for (i = 0; i < n; i++) {
2601 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2602 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2604 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2607 PerlIO_printf(Perl_debug_log, ",");
2610 PerlIO_printf(Perl_debug_log, ")");
2614 /* append to the out SV, the name of the lexical at offset off in the CV
2618 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2619 bool paren, bool is_scalar)
2622 PADNAMELIST *namepad = NULL;
2626 PADLIST * const padlist = CvPADLIST(cv);
2627 namepad = PadlistNAMES(padlist);
2631 sv_catpvs_nomg(out, "(");
2632 for (i = 0; i < n; i++) {
2633 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2635 STRLEN cur = SvCUR(out);
2636 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2637 UTF8fARG(1, PadnameLEN(sv) - 1,
2638 PadnamePV(sv) + 1));
2640 SvPVX(out)[cur] = '$';
2643 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2645 sv_catpvs_nomg(out, ",");
2648 sv_catpvs_nomg(out, "(");
2653 S_append_gv_name(pTHX_ GV *gv, SV *out)
2657 sv_catpvs_nomg(out, "<NULLGV>");
2661 gv_fullname4(sv, gv, NULL, FALSE);
2662 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2663 SvREFCNT_dec_NN(sv);
2667 # define ITEM_SV(item) (comppad ? \
2668 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2670 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2674 /* return a temporary SV containing a stringified representation of
2675 * the op_aux field of a MULTIDEREF op, associated with CV cv
2679 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2681 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2682 UV actions = items->uv;
2685 bool is_hash = FALSE;
2687 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2692 PADLIST *padlist = CvPADLIST(cv);
2693 comppad = PadlistARRAY(padlist)[1];
2699 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2702 switch (actions & MDEREF_ACTION_MASK) {
2705 actions = (++items)->uv;
2707 NOT_REACHED; /* NOTREACHED */
2709 case MDEREF_HV_padhv_helem:
2712 case MDEREF_AV_padav_aelem:
2714 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2716 NOT_REACHED; /* NOTREACHED */
2718 case MDEREF_HV_gvhv_helem:
2721 case MDEREF_AV_gvav_aelem:
2724 sv = ITEM_SV(items);
2725 S_append_gv_name(aTHX_ (GV*)sv, out);
2727 NOT_REACHED; /* NOTREACHED */
2729 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2732 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2734 sv = ITEM_SV(items);
2735 S_append_gv_name(aTHX_ (GV*)sv, out);
2736 goto do_vivify_rv2xv_elem;
2737 NOT_REACHED; /* NOTREACHED */
2739 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2742 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2743 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2744 goto do_vivify_rv2xv_elem;
2745 NOT_REACHED; /* NOTREACHED */
2747 case MDEREF_HV_pop_rv2hv_helem:
2748 case MDEREF_HV_vivify_rv2hv_helem:
2751 do_vivify_rv2xv_elem:
2752 case MDEREF_AV_pop_rv2av_aelem:
2753 case MDEREF_AV_vivify_rv2av_aelem:
2755 sv_catpvs_nomg(out, "->");
2757 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2758 sv_catpvs_nomg(out, "->");
2763 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2764 switch (actions & MDEREF_INDEX_MASK) {
2765 case MDEREF_INDEX_const:
2768 sv = ITEM_SV(items);
2770 sv_catpvs_nomg(out, "???");
2775 pv_pretty(out, s, cur, 30,
2777 (PERL_PV_PRETTY_NOCLEAR
2778 |PERL_PV_PRETTY_QUOTE
2779 |PERL_PV_PRETTY_ELLIPSES));
2783 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2785 case MDEREF_INDEX_padsv:
2786 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2788 case MDEREF_INDEX_gvsv:
2790 sv = ITEM_SV(items);
2791 S_append_gv_name(aTHX_ (GV*)sv, out);
2794 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2796 if (actions & MDEREF_FLAG_last)
2803 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2804 (int)(actions & MDEREF_ACTION_MASK));
2810 actions >>= MDEREF_SHIFT;
2816 /* Return a temporary SV containing a stringified representation of
2817 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2818 * both plain and utf8 versions of the const string and indices, only
2819 * the first is displayed.
2823 Perl_multiconcat_stringify(pTHX_ const OP *o)
2825 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2826 UNOP_AUX_item *lens;
2830 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2832 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2834 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2835 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2836 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2838 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2839 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2840 sv_catpvs(out, "UTF8 ");
2842 pv_pretty(out, s, len, 50,
2844 (PERL_PV_PRETTY_NOCLEAR
2845 |PERL_PV_PRETTY_QUOTE
2846 |PERL_PV_PRETTY_ELLIPSES));
2848 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2849 while (nargs-- >= 0) {
2850 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
2858 Perl_debop(pTHX_ const OP *o)
2860 PERL_ARGS_ASSERT_DEBOP;
2862 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2865 Perl_deb(aTHX_ "%s", OP_NAME(o));
2866 switch (o->op_type) {
2869 /* With ITHREADS, consts are stored in the pad, and the right pad
2870 * may not be active here, so check.
2871 * Looks like only during compiling the pads are illegal.
2874 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2876 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2880 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2881 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2888 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2892 S_deb_padvar(aTHX_ o->op_targ,
2893 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2897 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2898 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2901 case OP_MULTICONCAT:
2902 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2903 SVfARG(multiconcat_stringify(o)));
2909 PerlIO_printf(Perl_debug_log, "\n");
2915 =for apidoc op_class
2917 Given an op, determine what type of struct it has been allocated as.
2918 Returns one of the OPclass enums, such as OPclass_LISTOP.
2925 Perl_op_class(pTHX_ const OP *o)
2930 return OPclass_NULL;
2932 if (o->op_type == 0) {
2933 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2935 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2938 if (o->op_type == OP_SASSIGN)
2939 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2941 if (o->op_type == OP_AELEMFAST) {
2943 return OPclass_PADOP;
2945 return OPclass_SVOP;
2950 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2951 o->op_type == OP_RCATLINE)
2952 return OPclass_PADOP;
2955 if (o->op_type == OP_CUSTOM)
2958 switch (OP_CLASS(o)) {
2960 return OPclass_BASEOP;
2963 return OPclass_UNOP;
2966 return OPclass_BINOP;
2969 return OPclass_LOGOP;
2972 return OPclass_LISTOP;
2975 return OPclass_PMOP;
2978 return OPclass_SVOP;
2981 return OPclass_PADOP;
2983 case OA_PVOP_OR_SVOP:
2985 * Character translations (tr///) are usually a PVOP, keeping a
2986 * pointer to a table of shorts used to look up translations.
2987 * Under utf8, however, a simple table isn't practical; instead,
2988 * the OP is an SVOP (or, under threads, a PADOP),
2989 * and the SV is an AV.
2992 (o->op_private & OPpTRANS_USE_SVOP)
2994 #if defined(USE_ITHREADS)
2995 ? OPclass_PADOP : OPclass_PVOP;
2997 ? OPclass_SVOP : OPclass_PVOP;
3001 return OPclass_LOOP;
3006 case OA_BASEOP_OR_UNOP:
3008 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3009 * whether parens were seen. perly.y uses OPf_SPECIAL to
3010 * signal whether a BASEOP had empty parens or none.
3011 * Some other UNOPs are created later, though, so the best
3012 * test is OPf_KIDS, which is set in newUNOP.
3014 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3018 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3019 * the OPf_REF flag to distinguish between OP types instead of the
3020 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3021 * return OPclass_UNOP so that walkoptree can find our children. If
3022 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3023 * (no argument to the operator) it's an OP; with OPf_REF set it's
3024 * an SVOP (and op_sv is the GV for the filehandle argument).
3026 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
3028 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
3030 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3034 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3035 * label was omitted (in which case it's a BASEOP) or else a term was
3036 * seen. In this last case, all except goto are definitely PVOP but
3037 * goto is either a PVOP (with an ordinary constant label), an UNOP
3038 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3039 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3042 if (o->op_flags & OPf_STACKED)
3043 return OPclass_UNOP;
3044 else if (o->op_flags & OPf_SPECIAL)
3045 return OPclass_BASEOP;
3047 return OPclass_PVOP;
3049 return OPclass_METHOP;
3051 return OPclass_UNOP_AUX;
3053 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3055 return OPclass_BASEOP;
3061 S_deb_curcv(pTHX_ I32 ix)
3063 PERL_SI *si = PL_curstackinfo;
3064 for (; ix >=0; ix--) {
3065 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3067 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3068 return cx->blk_sub.cv;
3069 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3070 return cx->blk_eval.cv;
3071 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3073 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3074 && si->si_type == PERLSI_SORT)
3076 /* fake sort sub; use CV of caller */
3078 ix = si->si_cxix + 1;
3085 Perl_watch(pTHX_ char **addr)
3087 PERL_ARGS_ASSERT_WATCH;
3089 PL_watchaddr = addr;
3091 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3092 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3096 S_debprof(pTHX_ const OP *o)
3098 PERL_ARGS_ASSERT_DEBPROF;
3100 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3102 if (!PL_profiledata)
3103 Newxz(PL_profiledata, MAXO, U32);
3104 ++PL_profiledata[o->op_type];
3108 Perl_debprofdump(pTHX)
3111 if (!PL_profiledata)
3113 for (i = 0; i < MAXO; i++) {
3114 if (PL_profiledata[i])
3115 PerlIO_printf(Perl_debug_log,
3116 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3123 * ex: set ts=8 sts=4 sw=4 et: