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>.
137 #define PV_ESCAPE_OCTBUFSIZE 32
140 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
141 const STRLEN count, const STRLEN max,
142 STRLEN * const escaped, const U32 flags )
144 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
145 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
146 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
147 STRLEN wrote = 0; /* chars written so far */
148 STRLEN chsize = 0; /* size of data to be written */
149 STRLEN readsize = 1; /* size of data just read */
150 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
151 const char *pv = str;
152 const char * const end = pv + count; /* end of string */
155 PERL_ARGS_ASSERT_PV_ESCAPE;
157 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
158 /* This won't alter the UTF-8 flag */
162 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
165 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
166 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
167 const U8 c = (U8)u & 0xFF;
170 || (flags & PERL_PV_ESCAPE_ALL)
171 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
173 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
174 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
177 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
178 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
180 : "%cx{%02" UVxf "}", esc, u);
182 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
185 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
189 case '\\' : /* FALLTHROUGH */
190 case '%' : if ( c == esc ) {
196 case '\v' : octbuf[1] = 'v'; break;
197 case '\t' : octbuf[1] = 't'; break;
198 case '\r' : octbuf[1] = 'r'; break;
199 case '\n' : octbuf[1] = 'n'; break;
200 case '\f' : octbuf[1] = 'f'; break;
208 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
210 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
213 else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
217 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
224 if ( max && (wrote + chsize > max) ) {
226 } else if (chsize > 1) {
228 sv_catpvn(dsv, octbuf, chsize);
231 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
232 can be appended raw to the dsv. If dsv happens to be
233 UTF-8 then we need catpvf to upgrade them for us.
234 Or add a new API call sv_catpvc(). Think about that name, and
235 how to keep it clear that it's unlike the s of catpvs, which is
236 really an array of octets, not a string. */
238 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
241 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
246 return dsv ? SvPVX(dsv) : NULL;
249 =for apidoc pv_pretty
251 Converts a string into something presentable, handling escaping via
252 C<pv_escape()> and supporting quoting and ellipses.
254 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
255 double quoted with any double quotes in the string escaped. Otherwise
256 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
259 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
260 string were output then an ellipsis C<...> will be appended to the
261 string. Note that this happens AFTER it has been quoted.
263 If C<start_color> is non-null then it will be inserted after the opening
264 quote (if there is one) but before the escaped text. If C<end_color>
265 is non-null then it will be inserted after the escaped text but before
266 any quotes or ellipses.
268 Returns a pointer to the prettified text as held by C<dsv>.
274 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
275 const STRLEN max, char const * const start_color, char const * const end_color,
278 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
279 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
281 STRLEN max_adjust= 0;
284 PERL_ARGS_ASSERT_PV_PRETTY;
286 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
287 /* This won't alter the UTF-8 flag */
290 orig_cur= SvCUR(dsv);
293 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
295 if ( start_color != NULL )
296 sv_catpv(dsv, start_color);
298 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
301 assert(max > max_adjust);
302 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
303 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
305 assert(max > max_adjust);
308 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
310 if ( end_color != NULL )
311 sv_catpv(dsv, end_color);
314 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
316 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
317 sv_catpvs(dsv, "...");
319 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
320 while( SvCUR(dsv) - orig_cur < max )
328 =for apidoc pv_display
332 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
334 except that an additional "\0" will be appended to the string when
335 len > cur and pv[cur] is "\0".
337 Note that the final string may be up to 7 chars longer than pvlim.
343 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
345 PERL_ARGS_ASSERT_PV_DISPLAY;
347 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
348 if (len > cur && pv[cur] == '\0')
349 sv_catpvs( dsv, "\\0");
354 Perl_sv_peek(pTHX_ SV *sv)
357 SV * const t = sv_newmortal();
364 sv_catpvs(t, "VOID");
367 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
368 /* detect data corruption under memory poisoning */
369 sv_catpvs(t, "WILD");
372 else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
373 || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
375 if (sv == &PL_sv_undef) {
376 sv_catpvs(t, "SV_UNDEF");
377 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
378 SVs_GMG|SVs_SMG|SVs_RMG)) &&
382 else if (sv == &PL_sv_no) {
383 sv_catpvs(t, "SV_NO");
384 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
385 SVs_GMG|SVs_SMG|SVs_RMG)) &&
386 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
392 else if (sv == &PL_sv_yes) {
393 sv_catpvs(t, "SV_YES");
394 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
395 SVs_GMG|SVs_SMG|SVs_RMG)) &&
396 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
399 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
403 else if (sv == &PL_sv_zero) {
404 sv_catpvs(t, "SV_ZERO");
405 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
406 SVs_GMG|SVs_SMG|SVs_RMG)) &&
407 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
410 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
415 sv_catpvs(t, "SV_PLACEHOLDER");
416 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
417 SVs_GMG|SVs_SMG|SVs_RMG)) &&
423 else if (SvREFCNT(sv) == 0) {
427 else if (DEBUG_R_TEST_) {
430 /* is this SV on the tmps stack? */
431 for (ix=PL_tmps_ix; ix>=0; ix--) {
432 if (PL_tmps_stack[ix] == sv) {
437 if (is_tmp || SvREFCNT(sv) > 1) {
438 Perl_sv_catpvf(aTHX_ t, "<");
439 if (SvREFCNT(sv) > 1)
440 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
442 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
443 Perl_sv_catpvf(aTHX_ t, ">");
449 if (SvCUR(t) + unref > 10) {
450 SvCUR_set(t, unref + 3);
459 if (type == SVt_PVCV) {
460 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
462 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
463 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
466 } else if (type < SVt_LAST) {
467 sv_catpv(t, svshorttypenames[type]);
469 if (type == SVt_NULL)
472 sv_catpvs(t, "FREED");
477 if (!SvPVX_const(sv))
478 sv_catpvs(t, "(null)");
480 SV * const tmp = newSVpvs("");
484 SvOOK_offset(sv, delta);
485 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
487 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
489 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
490 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
492 SvREFCNT_dec_NN(tmp);
495 else if (SvNOKp(sv)) {
496 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
497 STORE_LC_NUMERIC_SET_STANDARD();
498 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
499 RESTORE_LC_NUMERIC();
501 else if (SvIOKp(sv)) {
503 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
505 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
513 if (TAINTING_get && sv && SvTAINTED(sv))
514 sv_catpvs(t, " [tainted]");
515 return SvPV_nolen(t);
519 =head1 Debugging Utilities
523 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
526 PERL_ARGS_ASSERT_DUMP_INDENT;
528 dump_vindent(level, file, pat, &args);
533 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
535 PERL_ARGS_ASSERT_DUMP_VINDENT;
536 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
537 PerlIO_vprintf(file, pat, *args);
541 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
542 * for each indent level as appropriate.
544 * bar contains bits indicating which indent columns should have a
545 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
546 * levels than bits in bar, then the first few indents are displayed
549 * The start of a new op is signalled by passing a value for level which
550 * has been negated and offset by 1 (so that level 0 is passed as -1 and
551 * can thus be distinguished from -0); in this case, emit a suitably
552 * indented blank line, then on the next line, display the op's sequence
553 * number, and make the final indent an '+----'.
557 * | FOO # level = 1, bar = 0b1
558 * | | # level =-2-1, bar = 0b11
560 * | BAZ # level = 2, bar = 0b10
564 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
565 const char* pat, ...)
569 bool newop = (level < 0);
573 /* start displaying a new op? */
575 UV seq = sequence_num(o);
579 /* output preceding blank line */
580 PerlIO_puts(file, " ");
581 for (i = level-1; i >= 0; i--)
582 PerlIO_puts(file, ( i == 0
583 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
586 PerlIO_puts(file, "\n");
588 /* output sequence number */
590 PerlIO_printf(file, "%-4" UVuf " ", seq);
592 PerlIO_puts(file, "???? ");
596 PerlIO_printf(file, " ");
598 for (i = level-1; i >= 0; i--)
600 (i == 0 && newop) ? "+--"
601 : (bar & (1 << i)) ? "| "
603 PerlIO_vprintf(file, pat, args);
608 /* display a link field (e.g. op_next) in the format
609 * ====> sequence_number [opname 0x123456]
613 S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file)
615 PerlIO_puts(file, " ===> ");
617 PerlIO_puts(file, "[SELF]\n");
619 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
620 sequence_num(o), OP_NAME(o), PTR2UV(o));
622 PerlIO_puts(file, "[0x0]\n");
628 Dumps the entire optree of the current program starting at C<PL_main_root> to
629 C<STDERR>. Also dumps the optrees for all visible subroutines in
638 dump_all_perl(FALSE);
642 Perl_dump_all_perl(pTHX_ bool justperl)
644 PerlIO_setlinebuf(Perl_debug_log);
646 op_dump(PL_main_root);
647 dump_packsubs_perl(PL_defstash, justperl);
651 =for apidoc dump_packsubs
653 Dumps the optrees for all visible subroutines in C<stash>.
659 Perl_dump_packsubs(pTHX_ const HV *stash)
661 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
662 dump_packsubs_perl(stash, FALSE);
666 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
670 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
674 for (i = 0; i <= (I32) HvMAX(stash); i++) {
676 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
677 GV * gv = (GV *)HeVAL(entry);
678 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
679 /* unfake a fake GV */
680 (void)CvGV(SvRV(gv));
681 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
684 dump_sub_perl(gv, justperl);
687 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
688 const HV * const hv = GvHV(gv);
689 if (hv && (hv != PL_defstash))
690 dump_packsubs_perl(hv, justperl); /* nested package */
697 Perl_dump_sub(pTHX_ const GV *gv)
699 PERL_ARGS_ASSERT_DUMP_SUB;
700 dump_sub_perl(gv, FALSE);
704 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
708 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
710 cv = isGV_with_GP(gv) ? GvCV(gv) :
711 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
712 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
715 if (isGV_with_GP(gv)) {
716 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
717 SV *escsv = newSVpvs_flags("", SVs_TEMP);
720 gv_fullname3(namesv, gv, NULL);
721 namepv = SvPV_const(namesv, namelen);
722 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
723 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
725 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
728 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
730 (int)CvXSUBANY(cv).any_i32);
734 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
738 Perl_dump_form(pTHX_ const GV *gv)
740 SV * const sv = sv_newmortal();
742 PERL_ARGS_ASSERT_DUMP_FORM;
744 gv_fullname3(sv, gv, NULL);
745 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
746 if (CvROOT(GvFORM(gv)))
747 op_dump(CvROOT(GvFORM(gv)));
749 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
755 op_dump(PL_eval_root);
759 /* returns a temp SV displaying the name of a GV. Handles the case where
760 * a GV is in fact a ref to a CV */
763 S_gv_display(pTHX_ GV *gv)
765 SV * const name = newSVpvs_flags("", SVs_TEMP);
767 SV * const raw = newSVpvs_flags("", SVs_TEMP);
771 if (isGV_with_GP(gv))
772 gv_fullname3(raw, gv, NULL);
775 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
776 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
777 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
779 rawpv = SvPV_const(raw, len);
780 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
783 sv_catpvs(name, "(NULL)");
792 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
796 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
803 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
806 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
807 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
808 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
811 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
813 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
814 SV * const tmpsv = pm_description(pm);
815 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
816 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
817 SvREFCNT_dec_NN(tmpsv);
820 if (pm->op_type == OP_SPLIT)
821 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
822 "TARGOFF/GV = 0x%" UVxf "\n",
823 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
825 if (pm->op_pmreplrootu.op_pmreplroot) {
826 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
827 S_do_op_dump_bar(aTHX_ level + 2,
828 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
829 file, pm->op_pmreplrootu.op_pmreplroot);
833 if (pm->op_code_list) {
834 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
835 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
836 S_do_op_dump_bar(aTHX_ level + 2,
837 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
838 file, pm->op_code_list);
841 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
842 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
848 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
850 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
851 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
855 const struct flag_to_name pmflags_flags_names[] = {
856 {PMf_CONST, ",CONST"},
858 {PMf_GLOBAL, ",GLOBAL"},
859 {PMf_CONTINUE, ",CONTINUE"},
860 {PMf_RETAINT, ",RETAINT"},
862 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
863 {PMf_HAS_CV, ",HAS_CV"},
864 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
865 {PMf_IS_QR, ",IS_QR"}
869 S_pm_description(pTHX_ const PMOP *pm)
871 SV * const desc = newSVpvs("");
872 const REGEXP * const regex = PM_GETRE(pm);
873 const U32 pmflags = pm->op_pmflags;
875 PERL_ARGS_ASSERT_PM_DESCRIPTION;
877 if (pmflags & PMf_ONCE)
878 sv_catpvs(desc, ",ONCE");
880 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
881 sv_catpvs(desc, ":USED");
883 if (pmflags & PMf_USED)
884 sv_catpvs(desc, ":USED");
888 if (RX_ISTAINTED(regex))
889 sv_catpvs(desc, ",TAINTED");
890 if (RX_CHECK_SUBSTR(regex)) {
891 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
892 sv_catpvs(desc, ",SCANFIRST");
893 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
894 sv_catpvs(desc, ",ALL");
896 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
897 sv_catpvs(desc, ",SKIPWHITE");
900 append_flags(desc, pmflags, pmflags_flags_names);
905 Perl_pmop_dump(pTHX_ PMOP *pm)
907 do_pmop_dump(0, Perl_debug_log, pm);
910 /* Return a unique integer to represent the address of op o.
911 * If it already exists in PL_op_sequence, just return it;
913 * *** Note that this isn't thread-safe */
916 S_sequence_num(pTHX_ const OP *o)
925 op = newSVuv(PTR2UV(o));
927 key = SvPV_const(op, len);
929 PL_op_sequence = newHV();
930 seq = hv_fetch(PL_op_sequence, key, len, 0);
933 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
941 const struct flag_to_name op_flags_names[] = {
943 {OPf_PARENS, ",PARENS"},
946 {OPf_STACKED, ",STACKED"},
947 {OPf_SPECIAL, ",SPECIAL"}
951 /* indexed by enum OPclass */
952 const char * const op_class_names[] = {
970 /* dump an op and any children. level indicates the initial indent.
971 * The bits of bar indicate which indents should receive a vertical bar.
972 * For example if level == 5 and bar == 0b01101, then the indent prefix
973 * emitted will be (not including the <>'s):
976 * 55554444333322221111
978 * For heavily nested output, the level may exceed the number of bits
979 * in bar; in this case the first few columns in the output will simply
980 * not have a bar, which is harmless.
984 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
986 const OPCODE optype = o->op_type;
988 PERL_ARGS_ASSERT_DO_OP_DUMP;
990 /* print op header line */
992 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
994 if (optype == OP_NULL && o->op_targ)
995 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
997 PerlIO_printf(file, " %s(0x%" UVxf ")",
998 op_class_names[op_class(o)], PTR2UV(o));
999 S_opdump_link(aTHX_ o, o->op_next, file);
1001 /* print op common fields */
1004 S_opdump_indent(aTHX_ o, level, bar, file, "PARENT");
1005 S_opdump_link(aTHX_ o, op_parent((OP*)o), file);
1008 if (o->op_targ && optype != OP_NULL)
1009 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1012 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1013 SV * const tmpsv = newSVpvs("");
1014 switch (o->op_flags & OPf_WANT) {
1016 sv_catpvs(tmpsv, ",VOID");
1018 case OPf_WANT_SCALAR:
1019 sv_catpvs(tmpsv, ",SCALAR");
1022 sv_catpvs(tmpsv, ",LIST");
1025 sv_catpvs(tmpsv, ",UNKNOWN");
1028 append_flags(tmpsv, o->op_flags, op_flags_names);
1029 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1030 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1031 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1032 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1033 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1034 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1035 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1038 if (o->op_private) {
1039 U16 oppriv = o->op_private;
1040 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1045 tmpsv = newSVpvs("");
1046 for (; !stop; op_ix++) {
1047 U16 entry = PL_op_private_bitdefs[op_ix];
1048 U16 bit = (entry >> 2) & 7;
1049 U16 ix = entry >> 5;
1055 I16 const *p = &PL_op_private_bitfields[ix];
1056 U16 bitmin = (U16) *p++;
1063 for (i = bitmin; i<= bit; i++)
1066 val = (oppriv & mask);
1069 && PL_op_private_labels[label] == '-'
1070 && PL_op_private_labels[label+1] == '\0'
1072 /* display as raw number */
1085 if (val == 0 && enum_label == -1)
1086 /* don't display anonymous zero values */
1089 sv_catpvs(tmpsv, ",");
1091 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1092 sv_catpvs(tmpsv, "=");
1094 if (enum_label == -1)
1095 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1097 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1102 if ( oppriv & (1<<bit)
1103 && !(PL_op_private_labels[ix] == '-'
1104 && PL_op_private_labels[ix+1] == '\0'))
1107 sv_catpvs(tmpsv, ",");
1108 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1113 sv_catpvs(tmpsv, ",");
1114 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1117 if (tmpsv && SvCUR(tmpsv)) {
1118 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1119 SvPVX_const(tmpsv) + 1);
1121 S_opdump_indent(aTHX_ o, level, bar, file,
1122 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1130 S_opdump_indent(aTHX_ o, level, bar, file,
1131 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1133 S_opdump_indent(aTHX_ o, level, bar, file,
1134 "GV = %" SVf " (0x%" UVxf ")\n",
1135 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1141 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1142 UV i, count = items[-1].uv;
1144 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1145 for (i=0; i < count; i++)
1146 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1147 "%" UVuf " => 0x%" UVxf "\n",
1152 case OP_MULTICONCAT:
1153 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
1154 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
1155 /* XXX really ought to dump each field individually,
1156 * but that's too much like hard work */
1157 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1158 SVfARG(multiconcat_stringify(o)));
1163 case OP_METHOD_NAMED:
1164 case OP_METHOD_SUPER:
1165 case OP_METHOD_REDIR:
1166 case OP_METHOD_REDIR_SUPER:
1167 #ifndef USE_ITHREADS
1168 /* with ITHREADS, consts are stored in the pad, and the right pad
1169 * may not be active here, so skip */
1170 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1171 SvPEEK(cMETHOPx_meth(o)));
1175 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1181 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1182 (UV)CopLINE(cCOPo));
1184 if (CopSTASHPV(cCOPo)) {
1185 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1186 HV *stash = CopSTASH(cCOPo);
1187 const char * const hvname = HvNAME_get(stash);
1189 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1190 generic_pv_escape(tmpsv, hvname,
1191 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1194 if (CopLABEL(cCOPo)) {
1195 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1198 const char *label = CopLABEL_len_flags(cCOPo,
1199 &label_len, &label_flags);
1200 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1201 generic_pv_escape( tmpsv, label, label_len,
1202 (label_flags & SVf_UTF8)));
1205 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1206 (unsigned int)cCOPo->cop_seq);
1211 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1212 S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file);
1213 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1214 S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file);
1215 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1216 S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file);
1236 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1237 S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
1243 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1251 if (o->op_private & OPpREFCOUNTED)
1252 S_opdump_indent(aTHX_ o, level, bar, file,
1253 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1261 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1264 SV * const label = newSVpvs_flags("", SVs_TEMP);
1265 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1266 S_opdump_indent(aTHX_ o, level, bar, file,
1267 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1268 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1274 if (o->op_private & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF)) {
1275 /* utf8: table stored as a swash */
1276 #ifndef USE_ITHREADS
1277 /* with ITHREADS, swash is stored in the pad, and the right pad
1278 * may not be active here, so skip */
1279 S_opdump_indent(aTHX_ o, level, bar, file,
1280 "SWASH = 0x%" UVxf "\n",
1281 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1285 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1286 SSize_t i, size = tbl->size;
1288 S_opdump_indent(aTHX_ o, level, bar, file,
1289 "TABLE = 0x%" UVxf "\n",
1291 S_opdump_indent(aTHX_ o, level, bar, file,
1292 " SIZE: 0x%" UVxf "\n", (UV)size);
1294 /* dump size+1 values, to include the extra slot at the end */
1295 for (i = 0; i <= size; i++) {
1296 short val = tbl->map[i];
1298 S_opdump_indent(aTHX_ o, level, bar, file,
1299 " %4" UVxf ":", (UV)i);
1301 PerlIO_printf(file, " %2" IVdf, (IV)val);
1303 PerlIO_printf(file, " %02" UVxf, (UV)val);
1305 if ( i == size || (i & 0xf) == 0xf)
1306 PerlIO_printf(file, "\n");
1315 if (o->op_flags & OPf_KIDS) {
1319 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1320 S_do_op_dump_bar(aTHX_ level,
1321 (bar | cBOOL(OpHAS_SIBLING(kid))),
1328 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1330 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1337 Dumps the optree starting at OP C<o> to C<STDERR>.
1343 Perl_op_dump(pTHX_ const OP *o)
1345 PERL_ARGS_ASSERT_OP_DUMP;
1346 do_op_dump(0, Perl_debug_log, o);
1350 Perl_gv_dump(pTHX_ GV *gv)
1354 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1357 PerlIO_printf(Perl_debug_log, "{}\n");
1360 sv = sv_newmortal();
1361 PerlIO_printf(Perl_debug_log, "{\n");
1362 gv_fullname3(sv, gv, NULL);
1363 name = SvPV_const(sv, len);
1364 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1365 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1366 if (gv != GvEGV(gv)) {
1367 gv_efullname3(sv, GvEGV(gv), NULL);
1368 name = SvPV_const(sv, len);
1369 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1370 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1372 (void)PerlIO_putc(Perl_debug_log, '\n');
1373 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1377 /* map magic types to the symbolic names
1378 * (with the PERL_MAGIC_ prefixed stripped)
1381 static const struct { const char type; const char *name; } magic_names[] = {
1382 #include "mg_names.inc"
1383 /* this null string terminates the list */
1388 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1390 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1392 for (; mg; mg = mg->mg_moremagic) {
1393 Perl_dump_indent(aTHX_ level, file,
1394 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1395 if (mg->mg_virtual) {
1396 const MGVTBL * const v = mg->mg_virtual;
1397 if (v >= PL_magic_vtables
1398 && v < PL_magic_vtables + magic_vtable_max) {
1399 const U32 i = v - PL_magic_vtables;
1400 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1403 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1404 UVxf "\n", PTR2UV(v));
1407 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1410 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1414 const char *name = NULL;
1415 for (n = 0; magic_names[n].name; n++) {
1416 if (mg->mg_type == magic_names[n].type) {
1417 name = magic_names[n].name;
1422 Perl_dump_indent(aTHX_ level, file,
1423 " MG_TYPE = PERL_MAGIC_%s\n", name);
1425 Perl_dump_indent(aTHX_ level, file,
1426 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1430 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1431 if (mg->mg_type == PERL_MAGIC_envelem &&
1432 mg->mg_flags & MGf_TAINTEDDIR)
1433 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1434 if (mg->mg_type == PERL_MAGIC_regex_global &&
1435 mg->mg_flags & MGf_MINMATCH)
1436 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1437 if (mg->mg_flags & MGf_REFCOUNTED)
1438 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1439 if (mg->mg_flags & MGf_GSKIP)
1440 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1441 if (mg->mg_flags & MGf_COPY)
1442 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1443 if (mg->mg_flags & MGf_DUP)
1444 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1445 if (mg->mg_flags & MGf_LOCAL)
1446 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1447 if (mg->mg_type == PERL_MAGIC_regex_global &&
1448 mg->mg_flags & MGf_BYTES)
1449 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1452 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1453 PTR2UV(mg->mg_obj));
1454 if (mg->mg_type == PERL_MAGIC_qr) {
1455 REGEXP* const re = (REGEXP *)mg->mg_obj;
1456 SV * const dsv = sv_newmortal();
1457 const char * const s
1458 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1460 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1461 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1463 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1464 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1467 if (mg->mg_flags & MGf_REFCOUNTED)
1468 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1471 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1473 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1474 if (mg->mg_len >= 0) {
1475 if (mg->mg_type != PERL_MAGIC_utf8) {
1476 SV * const sv = newSVpvs("");
1477 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1478 SvREFCNT_dec_NN(sv);
1481 else if (mg->mg_len == HEf_SVKEY) {
1482 PerlIO_puts(file, " => HEf_SVKEY\n");
1483 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1484 maxnest, dumpops, pvlim); /* MG is already +1 */
1487 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1492 " does not know how to handle this MG_LEN"
1494 (void)PerlIO_putc(file, '\n');
1496 if (mg->mg_type == PERL_MAGIC_utf8) {
1497 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1500 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1501 Perl_dump_indent(aTHX_ level, file,
1502 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1505 (UV)cache[i * 2 + 1]);
1512 Perl_magic_dump(pTHX_ const MAGIC *mg)
1514 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1518 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1522 PERL_ARGS_ASSERT_DO_HV_DUMP;
1524 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1525 if (sv && (hvname = HvNAME_get(sv)))
1527 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1528 name which quite legally could contain insane things like tabs, newlines, nulls or
1529 other scary crap - this should produce sane results - except maybe for unicode package
1530 names - but we will wait for someone to file a bug on that - demerphq */
1531 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1532 PerlIO_printf(file, "\t\"%s\"\n",
1533 generic_pv_escape( tmpsv, hvname,
1534 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1537 (void)PerlIO_putc(file, '\n');
1541 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1543 PERL_ARGS_ASSERT_DO_GV_DUMP;
1545 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1546 if (sv && GvNAME(sv)) {
1547 SV * const tmpsv = newSVpvs("");
1548 PerlIO_printf(file, "\t\"%s\"\n",
1549 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1552 (void)PerlIO_putc(file, '\n');
1556 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1558 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1560 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1561 if (sv && GvNAME(sv)) {
1562 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1564 HV * const stash = GvSTASH(sv);
1565 PerlIO_printf(file, "\t");
1566 /* TODO might have an extra \" here */
1567 if (stash && (hvname = HvNAME_get(stash))) {
1568 PerlIO_printf(file, "\"%s\" :: \"",
1569 generic_pv_escape(tmp, hvname,
1570 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1572 PerlIO_printf(file, "%s\"\n",
1573 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1576 (void)PerlIO_putc(file, '\n');
1579 const struct flag_to_name first_sv_flags_names[] = {
1580 {SVs_TEMP, "TEMP,"},
1581 {SVs_OBJECT, "OBJECT,"},
1590 const struct flag_to_name second_sv_flags_names[] = {
1592 {SVf_FAKE, "FAKE,"},
1593 {SVf_READONLY, "READONLY,"},
1594 {SVf_PROTECT, "PROTECT,"},
1595 {SVf_BREAK, "BREAK,"},
1601 const struct flag_to_name cv_flags_names[] = {
1602 {CVf_ANON, "ANON,"},
1603 {CVf_UNIQUE, "UNIQUE,"},
1604 {CVf_CLONE, "CLONE,"},
1605 {CVf_CLONED, "CLONED,"},
1606 {CVf_CONST, "CONST,"},
1607 {CVf_NODEBUG, "NODEBUG,"},
1608 {CVf_LVALUE, "LVALUE,"},
1609 {CVf_METHOD, "METHOD,"},
1610 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1611 {CVf_CVGV_RC, "CVGV_RC,"},
1612 {CVf_DYNFILE, "DYNFILE,"},
1613 {CVf_AUTOLOAD, "AUTOLOAD,"},
1614 {CVf_HASEVAL, "HASEVAL,"},
1615 {CVf_SLABBED, "SLABBED,"},
1616 {CVf_NAMED, "NAMED,"},
1617 {CVf_LEXICAL, "LEXICAL,"},
1618 {CVf_ISXSUB, "ISXSUB,"}
1621 const struct flag_to_name hv_flags_names[] = {
1622 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1623 {SVphv_LAZYDEL, "LAZYDEL,"},
1624 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1625 {SVf_AMAGIC, "OVERLOAD,"},
1626 {SVphv_CLONEABLE, "CLONEABLE,"}
1629 const struct flag_to_name gp_flags_names[] = {
1630 {GVf_INTRO, "INTRO,"},
1631 {GVf_MULTI, "MULTI,"},
1632 {GVf_ASSUMECV, "ASSUMECV,"},
1635 const struct flag_to_name gp_flags_imported_names[] = {
1636 {GVf_IMPORTED_SV, " SV"},
1637 {GVf_IMPORTED_AV, " AV"},
1638 {GVf_IMPORTED_HV, " HV"},
1639 {GVf_IMPORTED_CV, " CV"},
1642 /* NOTE: this structure is mostly duplicative of one generated by
1643 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1644 * the two. - Yves */
1645 const struct flag_to_name regexp_extflags_names[] = {
1646 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1647 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1648 {RXf_PMf_FOLD, "PMf_FOLD,"},
1649 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1650 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1651 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1652 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1653 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1654 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1655 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1656 {RXf_CHECK_ALL, "CHECK_ALL,"},
1657 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1658 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1659 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1660 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1661 {RXf_SPLIT, "SPLIT,"},
1662 {RXf_COPY_DONE, "COPY_DONE,"},
1663 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1664 {RXf_TAINTED, "TAINTED,"},
1665 {RXf_START_ONLY, "START_ONLY,"},
1666 {RXf_SKIPWHITE, "SKIPWHITE,"},
1667 {RXf_WHITE, "WHITE,"},
1668 {RXf_NULL, "NULL,"},
1671 /* NOTE: this structure is mostly duplicative of one generated by
1672 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1673 * the two. - Yves */
1674 const struct flag_to_name regexp_core_intflags_names[] = {
1675 {PREGf_SKIP, "SKIP,"},
1676 {PREGf_IMPLICIT, "IMPLICIT,"},
1677 {PREGf_NAUGHTY, "NAUGHTY,"},
1678 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1679 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1680 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1681 {PREGf_NOSCAN, "NOSCAN,"},
1682 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1683 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1684 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1685 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1686 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1689 /* Perl_do_sv_dump():
1691 * level: amount to indent the output
1692 * sv: the object to dump
1693 * nest: the current level of recursion
1694 * maxnest: the maximum allowed level of recursion
1695 * dumpops: if true, also dump the ops associated with a CV
1696 * pvlim: limit on the length of any strings that are output
1700 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1708 PERL_ARGS_ASSERT_DO_SV_DUMP;
1711 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1715 flags = SvFLAGS(sv);
1718 /* process general SV flags */
1720 d = Perl_newSVpvf(aTHX_
1721 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1722 PTR2UV(SvANY(sv)), PTR2UV(sv),
1723 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1724 (int)(PL_dumpindent*level), "");
1726 if ((flags & SVs_PADSTALE))
1727 sv_catpvs(d, "PADSTALE,");
1728 if ((flags & SVs_PADTMP))
1729 sv_catpvs(d, "PADTMP,");
1730 append_flags(d, flags, first_sv_flags_names);
1731 if (flags & SVf_ROK) {
1732 sv_catpvs(d, "ROK,");
1733 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
1735 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1736 append_flags(d, flags, second_sv_flags_names);
1737 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1738 && type != SVt_PVAV) {
1739 if (SvPCS_IMPORTED(sv))
1740 sv_catpvs(d, "PCS_IMPORTED,");
1742 sv_catpvs(d, "SCREAM,");
1745 /* process type-specific SV flags */
1750 append_flags(d, CvFLAGS(sv), cv_flags_names);
1753 append_flags(d, flags, hv_flags_names);
1757 if (isGV_with_GP(sv)) {
1758 append_flags(d, GvFLAGS(sv), gp_flags_names);
1760 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1761 sv_catpvs(d, "IMPORT");
1762 if (GvIMPORTED(sv) == GVf_IMPORTED)
1763 sv_catpvs(d, "ALL,");
1766 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1767 sv_catpvs(d, " ),");
1773 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1779 /* SVphv_SHAREKEYS is also 0x20000000 */
1780 if ((type != SVt_PVHV) && SvUTF8(sv))
1781 sv_catpvs(d, "UTF8");
1783 if (*(SvEND(d) - 1) == ',') {
1784 SvCUR_set(d, SvCUR(d) - 1);
1785 SvPVX(d)[SvCUR(d)] = '\0';
1790 /* dump initial SV details */
1792 #ifdef DEBUG_LEAKING_SCALARS
1793 Perl_dump_indent(aTHX_ level, file,
1794 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1795 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1797 sv->sv_debug_inpad ? "for" : "by",
1798 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1799 PTR2UV(sv->sv_debug_parent),
1803 Perl_dump_indent(aTHX_ level, file, "SV = ");
1807 if (type < SVt_LAST) {
1808 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1810 if (type == SVt_NULL) {
1815 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1820 /* Dump general SV fields */
1822 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1823 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1824 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1825 || (type == SVt_IV && !SvROK(sv))) {
1828 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1830 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1831 (void)PerlIO_putc(file, '\n');
1834 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1835 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1836 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1837 || type == SVt_NV) {
1838 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1839 STORE_LC_NUMERIC_SET_STANDARD();
1840 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1841 RESTORE_LC_NUMERIC();
1845 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1848 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1851 if (type < SVt_PV) {
1856 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1857 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1858 const bool re = isREGEXP(sv);
1859 const char * const ptr =
1860 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1864 SvOOK_offset(sv, delta);
1865 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1870 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1873 PerlIO_printf(file, "( %s . ) ",
1874 pv_display(d, ptr - delta, delta, 0,
1877 if (type == SVt_INVLIST) {
1878 PerlIO_printf(file, "\n");
1879 /* 4 blanks indents 2 beyond the PV, etc */
1880 _invlist_dump(file, level, " ", sv);
1883 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1886 if (SvUTF8(sv)) /* the 6? \x{....} */
1887 PerlIO_printf(file, " [UTF8 \"%s\"]",
1888 sv_uni_display(d, sv, 6 * SvCUR(sv),
1890 PerlIO_printf(file, "\n");
1892 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1893 if (re && type == SVt_PVLV)
1894 /* LV-as-REGEXP usurps len field to store pointer to
1896 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1897 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1899 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1901 #ifdef PERL_COPY_ON_WRITE
1902 if (SvIsCOW(sv) && SvLEN(sv))
1903 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1908 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1911 if (type >= SVt_PVMG) {
1913 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1915 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1917 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1918 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1923 /* Dump type-specific SV fields */
1927 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1928 PTR2UV(AvARRAY(sv)));
1929 if (AvARRAY(sv) != AvALLOC(sv)) {
1930 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1931 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1932 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1933 PTR2UV(AvALLOC(sv)));
1936 (void)PerlIO_putc(file, '\n');
1937 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1939 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1942 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1943 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
1944 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1945 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1946 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1948 SV **svp = AvARRAY(MUTABLE_AV(sv));
1950 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1953 SV* const elt = *svp;
1954 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1956 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1963 struct xpvhv_aux *const aux = HvAUX(sv);
1964 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1965 (UV)aux->xhv_aux_flags);
1967 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1968 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1969 if (HvARRAY(sv) && usedkeys) {
1970 /* Show distribution of HEs in the ARRAY */
1972 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1975 U32 pow2 = 2, keys = usedkeys;
1976 NV theoret, sum = 0;
1978 PerlIO_printf(file, " (");
1979 Zero(freq, FREQ_MAX + 1, int);
1980 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1983 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1985 if (count > FREQ_MAX)
1991 for (i = 0; i <= max; i++) {
1993 PerlIO_printf(file, "%d%s:%d", i,
1994 (i == FREQ_MAX) ? "+" : "",
1997 PerlIO_printf(file, ", ");
2000 (void)PerlIO_putc(file, ')');
2001 /* The "quality" of a hash is defined as the total number of
2002 comparisons needed to access every element once, relative
2003 to the expected number needed for a random hash.
2005 The total number of comparisons is equal to the sum of
2006 the squares of the number of entries in each bucket.
2007 For a random hash of n keys into k buckets, the expected
2012 for (i = max; i > 0; i--) { /* Precision: count down. */
2013 sum += freq[i] * i * i;
2015 while ((keys = keys >> 1))
2018 theoret += theoret * (theoret-1)/pow2;
2019 (void)PerlIO_putc(file, '\n');
2020 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2021 NVff "%%", theoret/sum*100);
2023 (void)PerlIO_putc(file, '\n');
2024 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2028 HE **ents = HvARRAY(sv);
2031 HE *const *const last = ents + HvMAX(sv);
2032 count = last + 1 - ents;
2037 } while (++ents <= last);
2040 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2043 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2046 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2047 (IV)HvRITER_get(sv));
2048 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2049 PTR2UV(HvEITER_get(sv)));
2050 #ifdef PERL_HASH_RANDOMIZE_KEYS
2051 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2052 (UV)HvRAND_get(sv));
2053 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2054 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2055 (UV)HvLASTRAND_get(sv));
2058 (void)PerlIO_putc(file, '\n');
2061 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2062 if (mg && mg->mg_obj) {
2063 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2067 const char * const hvname = HvNAME_get(sv);
2069 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2070 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2071 generic_pv_escape( tmpsv, hvname,
2072 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2077 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2078 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2079 if (HvAUX(sv)->xhv_name_count)
2080 Perl_dump_indent(aTHX_
2081 level, file, " NAMECOUNT = %" IVdf "\n",
2082 (IV)HvAUX(sv)->xhv_name_count
2084 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2085 const I32 count = HvAUX(sv)->xhv_name_count;
2087 SV * const names = newSVpvs_flags("", SVs_TEMP);
2088 /* The starting point is the first element if count is
2089 positive and the second element if count is negative. */
2090 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2091 + (count < 0 ? 1 : 0);
2092 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2093 + (count < 0 ? -count : count);
2094 while (hekp < endp) {
2096 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2097 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2098 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2100 /* This should never happen. */
2101 sv_catpvs(names, ", (null)");
2105 Perl_dump_indent(aTHX_
2106 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2110 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2111 const char *const hvename = HvENAME_get(sv);
2112 Perl_dump_indent(aTHX_
2113 level, file, " ENAME = \"%s\"\n",
2114 generic_pv_escape(tmp, hvename,
2115 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2119 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2121 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2125 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2126 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2128 generic_pv_escape( tmpsv, meta->mro_which->name,
2129 meta->mro_which->length,
2130 (meta->mro_which->kflags & HVhek_UTF8)),
2131 PTR2UV(meta->mro_which));
2132 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2134 (UV)meta->cache_gen);
2135 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2137 if (meta->mro_linear_all) {
2138 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2140 PTR2UV(meta->mro_linear_all));
2141 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2144 if (meta->mro_linear_current) {
2145 Perl_dump_indent(aTHX_ level, file,
2146 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2147 PTR2UV(meta->mro_linear_current));
2148 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2151 if (meta->mro_nextmethod) {
2152 Perl_dump_indent(aTHX_ level, file,
2153 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2154 PTR2UV(meta->mro_nextmethod));
2155 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2159 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2161 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2166 if (nest < maxnest) {
2167 HV * const hv = MUTABLE_HV(sv);
2172 int count = maxnest - nest;
2173 for (i=0; i <= HvMAX(hv); i++) {
2174 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2181 if (count-- <= 0) goto DONEHV;
2184 keysv = hv_iterkeysv(he);
2185 keypv = SvPV_const(keysv, len);
2188 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2190 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2191 if (HvEITER_get(hv) == he)
2192 PerlIO_printf(file, "[CURRENT] ");
2193 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2194 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2201 } /* case SVt_PVHV */
2204 if (CvAUTOLOAD(sv)) {
2205 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2207 const char *const name = SvPV_const(sv, len);
2208 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2209 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2212 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2213 const char *const proto = CvPROTO(sv);
2214 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2215 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2220 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2221 if (!CvISXSUB(sv)) {
2224 Perl_dump_indent(aTHX_ level, file,
2225 " SLAB = 0x%" UVxf "\n",
2226 PTR2UV(CvSTART(sv)));
2228 Perl_dump_indent(aTHX_ level, file,
2229 " START = 0x%" UVxf " ===> %" IVdf "\n",
2230 PTR2UV(CvSTART(sv)),
2231 (IV)sequence_num(CvSTART(sv)));
2233 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2234 PTR2UV(CvROOT(sv)));
2235 if (CvROOT(sv) && dumpops) {
2236 do_op_dump(level+1, file, CvROOT(sv));
2239 SV * const constant = cv_const_sv((const CV *)sv);
2241 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2244 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2246 PTR2UV(CvXSUBANY(sv).any_ptr));
2247 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2250 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2251 (IV)CvXSUBANY(sv).any_i32);
2255 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2256 HEK_KEY(CvNAME_HEK((CV *)sv)));
2257 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2258 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2259 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2260 IVdf "\n", (IV)CvDEPTH(sv));
2261 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2263 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2264 if (!CvISXSUB(sv)) {
2265 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2266 if (nest < maxnest) {
2267 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2271 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2273 const CV * const outside = CvOUTSIDE(sv);
2274 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2277 : CvANON(outside) ? "ANON"
2278 : (outside == PL_main_cv) ? "MAIN"
2279 : CvUNIQUE(outside) ? "UNIQUE"
2282 newSVpvs_flags("", SVs_TEMP),
2283 GvNAME(CvGV(outside)),
2284 GvNAMELEN(CvGV(outside)),
2285 GvNAMEUTF8(CvGV(outside)))
2289 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2290 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2295 if (type == SVt_PVLV) {
2296 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2297 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2298 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2299 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2300 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2301 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2302 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2305 if (isREGEXP(sv)) goto dumpregexp;
2306 if (!isGV_with_GP(sv))
2309 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2310 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2311 generic_pv_escape(tmpsv, GvNAME(sv),
2315 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2316 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2317 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2318 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2321 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2322 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2323 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2324 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2325 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2326 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2327 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2328 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2329 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2333 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2334 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2335 do_gv_dump (level, file, " EGV", GvEGV(sv));
2338 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2339 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2340 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2341 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2342 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2343 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2344 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2346 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2347 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2348 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2350 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2351 PTR2UV(IoTOP_GV(sv)));
2352 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2353 maxnest, dumpops, pvlim);
2355 /* Source filters hide things that are not GVs in these three, so let's
2356 be careful out there. */
2358 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2359 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2360 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2362 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2363 PTR2UV(IoFMT_GV(sv)));
2364 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2365 maxnest, dumpops, pvlim);
2367 if (IoBOTTOM_NAME(sv))
2368 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2369 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2370 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2372 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2373 PTR2UV(IoBOTTOM_GV(sv)));
2374 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2375 maxnest, dumpops, pvlim);
2377 if (isPRINT(IoTYPE(sv)))
2378 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2380 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2381 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2386 struct regexp * const r = ReANY((REGEXP*)sv);
2388 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2390 append_flags(d, flags, names); \
2391 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2392 SvCUR_set(d, SvCUR(d) - 1); \
2393 SvPVX(d)[SvCUR(d)] = '\0'; \
2396 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2397 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2398 (UV)(r->compflags), SvPVX_const(d));
2400 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2401 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2402 (UV)(r->extflags), SvPVX_const(d));
2404 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2405 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2406 if (r->engine == &PL_core_reg_engine) {
2407 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2408 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2409 (UV)(r->intflags), SvPVX_const(d));
2411 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2414 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2415 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2417 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2418 (UV)(r->lastparen));
2419 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2420 (UV)(r->lastcloseparen));
2421 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2423 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2424 (IV)(r->minlenret));
2425 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2427 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2428 (UV)(r->pre_prefix));
2429 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2431 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2432 (IV)(r->suboffset));
2433 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2434 (IV)(r->subcoffset));
2436 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2438 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2440 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2441 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2442 PTR2UV(r->mother_re));
2443 if (nest < maxnest && r->mother_re)
2444 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2445 maxnest, dumpops, pvlim);
2446 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2447 PTR2UV(r->paren_names));
2448 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2449 PTR2UV(r->substrs));
2450 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2451 PTR2UV(r->pprivate));
2452 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2454 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2455 PTR2UV(r->qr_anoncv));
2457 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2458 PTR2UV(r->saved_copy));
2469 Dumps the contents of an SV to the C<STDERR> filehandle.
2471 For an example of its output, see L<Devel::Peek>.
2477 Perl_sv_dump(pTHX_ SV *sv)
2479 if (sv && SvROK(sv))
2480 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2482 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2486 Perl_runops_debug(pTHX)
2488 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2489 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2491 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2495 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2498 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2500 #ifdef PERL_TRACE_OPS
2501 ++PL_op_exec_cnt[PL_op->op_type];
2503 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2504 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2505 Perl_croak_nocontext(
2506 "panic: previous op failed to extend arg stack: "
2507 "base=%p, sp=%p, hwm=%p\n",
2508 PL_stack_base, PL_stack_sp,
2509 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2510 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2515 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2516 PerlIO_printf(Perl_debug_log,
2517 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2518 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2519 PTR2UV(*PL_watchaddr));
2520 if (DEBUG_s_TEST_) {
2521 if (DEBUG_v_TEST_) {
2522 PerlIO_printf(Perl_debug_log, "\n");
2530 if (DEBUG_t_TEST_) debop(PL_op);
2531 if (DEBUG_P_TEST_) debprof(PL_op);
2536 PERL_DTRACE_PROBE_OP(PL_op);
2537 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2538 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2541 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2542 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2543 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2550 /* print the names of the n lexical vars starting at pad offset off */
2553 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2556 CV * const cv = deb_curcv(cxstack_ix);
2557 PADNAMELIST *comppad = NULL;
2561 PADLIST * const padlist = CvPADLIST(cv);
2562 comppad = PadlistNAMES(padlist);
2565 PerlIO_printf(Perl_debug_log, "(");
2566 for (i = 0; i < n; i++) {
2567 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2568 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2570 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2573 PerlIO_printf(Perl_debug_log, ",");
2576 PerlIO_printf(Perl_debug_log, ")");
2580 /* append to the out SV, the name of the lexical at offset off in the CV
2584 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2585 bool paren, bool is_scalar)
2588 PADNAMELIST *namepad = NULL;
2592 PADLIST * const padlist = CvPADLIST(cv);
2593 namepad = PadlistNAMES(padlist);
2597 sv_catpvs_nomg(out, "(");
2598 for (i = 0; i < n; i++) {
2599 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2601 STRLEN cur = SvCUR(out);
2602 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2603 UTF8fARG(1, PadnameLEN(sv) - 1,
2604 PadnamePV(sv) + 1));
2606 SvPVX(out)[cur] = '$';
2609 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2611 sv_catpvs_nomg(out, ",");
2614 sv_catpvs_nomg(out, "(");
2619 S_append_gv_name(pTHX_ GV *gv, SV *out)
2623 sv_catpvs_nomg(out, "<NULLGV>");
2627 gv_fullname4(sv, gv, NULL, FALSE);
2628 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2629 SvREFCNT_dec_NN(sv);
2633 # define ITEM_SV(item) (comppad ? \
2634 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2636 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2640 /* return a temporary SV containing a stringified representation of
2641 * the op_aux field of a MULTIDEREF op, associated with CV cv
2645 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2647 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2648 UV actions = items->uv;
2651 bool is_hash = FALSE;
2653 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2658 PADLIST *padlist = CvPADLIST(cv);
2659 comppad = PadlistARRAY(padlist)[1];
2665 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2668 switch (actions & MDEREF_ACTION_MASK) {
2671 actions = (++items)->uv;
2673 NOT_REACHED; /* NOTREACHED */
2675 case MDEREF_HV_padhv_helem:
2678 case MDEREF_AV_padav_aelem:
2680 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2682 NOT_REACHED; /* NOTREACHED */
2684 case MDEREF_HV_gvhv_helem:
2687 case MDEREF_AV_gvav_aelem:
2690 sv = ITEM_SV(items);
2691 S_append_gv_name(aTHX_ (GV*)sv, out);
2693 NOT_REACHED; /* NOTREACHED */
2695 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2698 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2700 sv = ITEM_SV(items);
2701 S_append_gv_name(aTHX_ (GV*)sv, out);
2702 goto do_vivify_rv2xv_elem;
2703 NOT_REACHED; /* NOTREACHED */
2705 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2708 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2709 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2710 goto do_vivify_rv2xv_elem;
2711 NOT_REACHED; /* NOTREACHED */
2713 case MDEREF_HV_pop_rv2hv_helem:
2714 case MDEREF_HV_vivify_rv2hv_helem:
2717 do_vivify_rv2xv_elem:
2718 case MDEREF_AV_pop_rv2av_aelem:
2719 case MDEREF_AV_vivify_rv2av_aelem:
2721 sv_catpvs_nomg(out, "->");
2723 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2724 sv_catpvs_nomg(out, "->");
2729 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2730 switch (actions & MDEREF_INDEX_MASK) {
2731 case MDEREF_INDEX_const:
2734 sv = ITEM_SV(items);
2736 sv_catpvs_nomg(out, "???");
2741 pv_pretty(out, s, cur, 30,
2743 (PERL_PV_PRETTY_NOCLEAR
2744 |PERL_PV_PRETTY_QUOTE
2745 |PERL_PV_PRETTY_ELLIPSES));
2749 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2751 case MDEREF_INDEX_padsv:
2752 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2754 case MDEREF_INDEX_gvsv:
2756 sv = ITEM_SV(items);
2757 S_append_gv_name(aTHX_ (GV*)sv, out);
2760 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2762 if (actions & MDEREF_FLAG_last)
2769 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2770 (int)(actions & MDEREF_ACTION_MASK));
2776 actions >>= MDEREF_SHIFT;
2782 /* Return a temporary SV containing a stringified representation of
2783 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2784 * both plain and utf8 versions of the const string and indices, only
2785 * the first is displayed.
2789 Perl_multiconcat_stringify(pTHX_ const OP *o)
2791 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2792 UNOP_AUX_item *lens;
2796 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2798 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2800 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2801 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2802 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2804 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2805 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2806 sv_catpvs(out, "UTF8 ");
2808 pv_pretty(out, s, len, 50,
2810 (PERL_PV_PRETTY_NOCLEAR
2811 |PERL_PV_PRETTY_QUOTE
2812 |PERL_PV_PRETTY_ELLIPSES));
2814 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2815 while (nargs-- >= 0) {
2816 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
2824 Perl_debop(pTHX_ const OP *o)
2826 PERL_ARGS_ASSERT_DEBOP;
2828 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2831 Perl_deb(aTHX_ "%s", OP_NAME(o));
2832 switch (o->op_type) {
2835 /* With ITHREADS, consts are stored in the pad, and the right pad
2836 * may not be active here, so check.
2837 * Looks like only during compiling the pads are illegal.
2840 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2842 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2846 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2847 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2854 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2858 S_deb_padvar(aTHX_ o->op_targ,
2859 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2863 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2864 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2867 case OP_MULTICONCAT:
2868 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2869 SVfARG(multiconcat_stringify(o)));
2875 PerlIO_printf(Perl_debug_log, "\n");
2881 =for apidoc op_class
2883 Given an op, determine what type of struct it has been allocated as.
2884 Returns one of the OPclass enums, such as OPclass_LISTOP.
2891 Perl_op_class(pTHX_ const OP *o)
2896 return OPclass_NULL;
2898 if (o->op_type == 0) {
2899 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2901 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2904 if (o->op_type == OP_SASSIGN)
2905 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2907 if (o->op_type == OP_AELEMFAST) {
2909 return OPclass_PADOP;
2911 return OPclass_SVOP;
2916 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2917 o->op_type == OP_RCATLINE)
2918 return OPclass_PADOP;
2921 if (o->op_type == OP_CUSTOM)
2924 switch (OP_CLASS(o)) {
2926 return OPclass_BASEOP;
2929 return OPclass_UNOP;
2932 return OPclass_BINOP;
2935 return OPclass_LOGOP;
2938 return OPclass_LISTOP;
2941 return OPclass_PMOP;
2944 return OPclass_SVOP;
2947 return OPclass_PADOP;
2949 case OA_PVOP_OR_SVOP:
2951 * Character translations (tr///) are usually a PVOP, keeping a
2952 * pointer to a table of shorts used to look up translations.
2953 * Under utf8, however, a simple table isn't practical; instead,
2954 * the OP is an SVOP (or, under threads, a PADOP),
2955 * and the SV is a reference to a swash
2956 * (i.e., an RV pointing to an HV).
2959 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2961 #if defined(USE_ITHREADS)
2962 ? OPclass_PADOP : OPclass_PVOP;
2964 ? OPclass_SVOP : OPclass_PVOP;
2968 return OPclass_LOOP;
2973 case OA_BASEOP_OR_UNOP:
2975 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2976 * whether parens were seen. perly.y uses OPf_SPECIAL to
2977 * signal whether a BASEOP had empty parens or none.
2978 * Some other UNOPs are created later, though, so the best
2979 * test is OPf_KIDS, which is set in newUNOP.
2981 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2985 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2986 * the OPf_REF flag to distinguish between OP types instead of the
2987 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2988 * return OPclass_UNOP so that walkoptree can find our children. If
2989 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2990 * (no argument to the operator) it's an OP; with OPf_REF set it's
2991 * an SVOP (and op_sv is the GV for the filehandle argument).
2993 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2995 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2997 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3001 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3002 * label was omitted (in which case it's a BASEOP) or else a term was
3003 * seen. In this last case, all except goto are definitely PVOP but
3004 * goto is either a PVOP (with an ordinary constant label), an UNOP
3005 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3006 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3009 if (o->op_flags & OPf_STACKED)
3010 return OPclass_UNOP;
3011 else if (o->op_flags & OPf_SPECIAL)
3012 return OPclass_BASEOP;
3014 return OPclass_PVOP;
3016 return OPclass_METHOP;
3018 return OPclass_UNOP_AUX;
3020 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3022 return OPclass_BASEOP;
3028 S_deb_curcv(pTHX_ I32 ix)
3030 PERL_SI *si = PL_curstackinfo;
3031 for (; ix >=0; ix--) {
3032 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3034 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3035 return cx->blk_sub.cv;
3036 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3037 return cx->blk_eval.cv;
3038 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3040 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3041 && si->si_type == PERLSI_SORT)
3043 /* fake sort sub; use CV of caller */
3045 ix = si->si_cxix + 1;
3052 Perl_watch(pTHX_ char **addr)
3054 PERL_ARGS_ASSERT_WATCH;
3056 PL_watchaddr = addr;
3058 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3059 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3063 S_debprof(pTHX_ const OP *o)
3065 PERL_ARGS_ASSERT_DEBPROF;
3067 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3069 if (!PL_profiledata)
3070 Newxz(PL_profiledata, MAXO, U32);
3071 ++PL_profiledata[o->op_type];
3075 Perl_debprofdump(pTHX)
3078 if (!PL_profiledata)
3080 for (i = 0; i < MAXO; i++) {
3081 if (PL_profiledata[i])
3082 PerlIO_printf(Perl_debug_log,
3083 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3090 * ex: set ts=8 sts=4 sw=4 et: