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)
1707 PERL_ARGS_ASSERT_DO_SV_DUMP;
1710 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1714 flags = SvFLAGS(sv);
1717 /* process general SV flags */
1719 d = Perl_newSVpvf(aTHX_
1720 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1721 PTR2UV(SvANY(sv)), PTR2UV(sv),
1722 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1723 (int)(PL_dumpindent*level), "");
1725 if ((flags & SVs_PADSTALE))
1726 sv_catpvs(d, "PADSTALE,");
1727 if ((flags & SVs_PADTMP))
1728 sv_catpvs(d, "PADTMP,");
1729 append_flags(d, flags, first_sv_flags_names);
1730 if (flags & SVf_ROK) {
1731 sv_catpvs(d, "ROK,");
1732 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
1734 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1735 append_flags(d, flags, second_sv_flags_names);
1736 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1737 && type != SVt_PVAV) {
1738 if (SvPCS_IMPORTED(sv))
1739 sv_catpvs(d, "PCS_IMPORTED,");
1741 sv_catpvs(d, "SCREAM,");
1744 /* process type-specific SV flags */
1749 append_flags(d, CvFLAGS(sv), cv_flags_names);
1752 append_flags(d, flags, hv_flags_names);
1756 if (isGV_with_GP(sv)) {
1757 append_flags(d, GvFLAGS(sv), gp_flags_names);
1759 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1760 sv_catpvs(d, "IMPORT");
1761 if (GvIMPORTED(sv) == GVf_IMPORTED)
1762 sv_catpvs(d, "ALL,");
1765 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1766 sv_catpvs(d, " ),");
1772 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1778 /* SVphv_SHAREKEYS is also 0x20000000 */
1779 if ((type != SVt_PVHV) && SvUTF8(sv))
1780 sv_catpvs(d, "UTF8");
1782 if (*(SvEND(d) - 1) == ',') {
1783 SvCUR_set(d, SvCUR(d) - 1);
1784 SvPVX(d)[SvCUR(d)] = '\0';
1789 /* dump initial SV details */
1791 #ifdef DEBUG_LEAKING_SCALARS
1792 Perl_dump_indent(aTHX_ level, file,
1793 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1794 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1796 sv->sv_debug_inpad ? "for" : "by",
1797 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1798 PTR2UV(sv->sv_debug_parent),
1802 Perl_dump_indent(aTHX_ level, file, "SV = ");
1806 if (type < SVt_LAST) {
1807 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1809 if (type == SVt_NULL) {
1814 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1819 /* Dump general SV fields */
1821 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1822 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1823 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1824 || (type == SVt_IV && !SvROK(sv))) {
1827 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1829 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1830 (void)PerlIO_putc(file, '\n');
1833 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1834 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1835 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1836 || type == SVt_NV) {
1837 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1838 STORE_LC_NUMERIC_SET_STANDARD();
1839 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1840 RESTORE_LC_NUMERIC();
1844 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1847 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1850 if (type < SVt_PV) {
1855 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1856 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1857 const bool re = isREGEXP(sv);
1858 const char * const ptr =
1859 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1863 SvOOK_offset(sv, delta);
1864 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1869 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1872 PerlIO_printf(file, "( %s . ) ",
1873 pv_display(d, ptr - delta, delta, 0,
1876 if (type == SVt_INVLIST) {
1877 PerlIO_printf(file, "\n");
1878 /* 4 blanks indents 2 beyond the PV, etc */
1879 _invlist_dump(file, level, " ", sv);
1882 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1885 if (SvUTF8(sv)) /* the 6? \x{....} */
1886 PerlIO_printf(file, " [UTF8 \"%s\"]",
1887 sv_uni_display(d, sv, 6 * SvCUR(sv),
1889 PerlIO_printf(file, "\n");
1891 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1892 if (re && type == SVt_PVLV)
1893 /* LV-as-REGEXP usurps len field to store pointer to
1895 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1896 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1898 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1900 #ifdef PERL_COPY_ON_WRITE
1901 if (SvIsCOW(sv) && SvLEN(sv))
1902 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1907 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1910 if (type >= SVt_PVMG) {
1912 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1914 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1916 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1917 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1922 /* Dump type-specific SV fields */
1926 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1927 PTR2UV(AvARRAY(sv)));
1928 if (AvARRAY(sv) != AvALLOC(sv)) {
1929 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1930 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1931 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1932 PTR2UV(AvALLOC(sv)));
1935 (void)PerlIO_putc(file, '\n');
1936 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1938 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1941 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1942 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
1943 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1944 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1945 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1947 SV **svp = AvARRAY(MUTABLE_AV(sv));
1949 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1952 SV* const elt = *svp;
1953 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1955 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1962 struct xpvhv_aux *const aux = HvAUX(sv);
1963 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1964 (UV)aux->xhv_aux_flags);
1966 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1967 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1968 if (HvARRAY(sv) && usedkeys) {
1969 /* Show distribution of HEs in the ARRAY */
1971 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1974 U32 pow2 = 2, keys = usedkeys;
1975 NV theoret, sum = 0;
1977 PerlIO_printf(file, " (");
1978 Zero(freq, FREQ_MAX + 1, int);
1979 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1982 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1984 if (count > FREQ_MAX)
1990 for (i = 0; i <= max; i++) {
1992 PerlIO_printf(file, "%d%s:%d", i,
1993 (i == FREQ_MAX) ? "+" : "",
1996 PerlIO_printf(file, ", ");
1999 (void)PerlIO_putc(file, ')');
2000 /* The "quality" of a hash is defined as the total number of
2001 comparisons needed to access every element once, relative
2002 to the expected number needed for a random hash.
2004 The total number of comparisons is equal to the sum of
2005 the squares of the number of entries in each bucket.
2006 For a random hash of n keys into k buckets, the expected
2011 for (i = max; i > 0; i--) { /* Precision: count down. */
2012 sum += freq[i] * i * i;
2014 while ((keys = keys >> 1))
2017 theoret += theoret * (theoret-1)/pow2;
2018 (void)PerlIO_putc(file, '\n');
2019 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2020 NVff "%%", theoret/sum*100);
2022 (void)PerlIO_putc(file, '\n');
2023 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2027 HE **ents = HvARRAY(sv);
2030 HE *const *const last = ents + HvMAX(sv);
2031 count = last + 1 - ents;
2036 } while (++ents <= last);
2039 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2042 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2045 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2046 (IV)HvRITER_get(sv));
2047 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2048 PTR2UV(HvEITER_get(sv)));
2049 #ifdef PERL_HASH_RANDOMIZE_KEYS
2050 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2051 (UV)HvRAND_get(sv));
2052 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2053 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2054 (UV)HvLASTRAND_get(sv));
2057 (void)PerlIO_putc(file, '\n');
2060 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2061 if (mg && mg->mg_obj) {
2062 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2066 const char * const hvname = HvNAME_get(sv);
2068 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2069 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2070 generic_pv_escape( tmpsv, hvname,
2071 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2076 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2077 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2078 if (HvAUX(sv)->xhv_name_count)
2079 Perl_dump_indent(aTHX_
2080 level, file, " NAMECOUNT = %" IVdf "\n",
2081 (IV)HvAUX(sv)->xhv_name_count
2083 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2084 const I32 count = HvAUX(sv)->xhv_name_count;
2086 SV * const names = newSVpvs_flags("", SVs_TEMP);
2087 /* The starting point is the first element if count is
2088 positive and the second element if count is negative. */
2089 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2090 + (count < 0 ? 1 : 0);
2091 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2092 + (count < 0 ? -count : count);
2093 while (hekp < endp) {
2095 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2096 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2097 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2099 /* This should never happen. */
2100 sv_catpvs(names, ", (null)");
2104 Perl_dump_indent(aTHX_
2105 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2109 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2110 const char *const hvename = HvENAME_get(sv);
2111 Perl_dump_indent(aTHX_
2112 level, file, " ENAME = \"%s\"\n",
2113 generic_pv_escape(tmp, hvename,
2114 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2118 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2120 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2124 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2125 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2127 generic_pv_escape( tmpsv, meta->mro_which->name,
2128 meta->mro_which->length,
2129 (meta->mro_which->kflags & HVhek_UTF8)),
2130 PTR2UV(meta->mro_which));
2131 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2133 (UV)meta->cache_gen);
2134 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2136 if (meta->mro_linear_all) {
2137 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2139 PTR2UV(meta->mro_linear_all));
2140 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2143 if (meta->mro_linear_current) {
2144 Perl_dump_indent(aTHX_ level, file,
2145 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2146 PTR2UV(meta->mro_linear_current));
2147 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2150 if (meta->mro_nextmethod) {
2151 Perl_dump_indent(aTHX_ level, file,
2152 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2153 PTR2UV(meta->mro_nextmethod));
2154 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2158 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2160 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2165 if (nest < maxnest) {
2166 HV * const hv = MUTABLE_HV(sv);
2171 int count = maxnest - nest;
2172 for (i=0; i <= HvMAX(hv); i++) {
2173 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2180 if (count-- <= 0) goto DONEHV;
2183 keysv = hv_iterkeysv(he);
2184 keypv = SvPV_const(keysv, len);
2187 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2189 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2190 if (HvEITER_get(hv) == he)
2191 PerlIO_printf(file, "[CURRENT] ");
2192 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2193 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2200 } /* case SVt_PVHV */
2203 if (CvAUTOLOAD(sv)) {
2204 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2206 const char *const name = SvPV_const(sv, len);
2207 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2208 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2211 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2212 const char *const proto = CvPROTO(sv);
2213 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2214 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2219 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2220 if (!CvISXSUB(sv)) {
2223 Perl_dump_indent(aTHX_ level, file,
2224 " SLAB = 0x%" UVxf "\n",
2225 PTR2UV(CvSTART(sv)));
2227 Perl_dump_indent(aTHX_ level, file,
2228 " START = 0x%" UVxf " ===> %" IVdf "\n",
2229 PTR2UV(CvSTART(sv)),
2230 (IV)sequence_num(CvSTART(sv)));
2232 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2233 PTR2UV(CvROOT(sv)));
2234 if (CvROOT(sv) && dumpops) {
2235 do_op_dump(level+1, file, CvROOT(sv));
2238 SV * const constant = cv_const_sv((const CV *)sv);
2240 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2243 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2245 PTR2UV(CvXSUBANY(sv).any_ptr));
2246 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2249 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2250 (IV)CvXSUBANY(sv).any_i32);
2254 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2255 HEK_KEY(CvNAME_HEK((CV *)sv)));
2256 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2257 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2258 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2259 IVdf "\n", (IV)CvDEPTH(sv));
2260 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2262 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2263 if (!CvISXSUB(sv)) {
2264 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2265 if (nest < maxnest) {
2266 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2270 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2272 const CV * const outside = CvOUTSIDE(sv);
2273 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2276 : CvANON(outside) ? "ANON"
2277 : (outside == PL_main_cv) ? "MAIN"
2278 : CvUNIQUE(outside) ? "UNIQUE"
2281 newSVpvs_flags("", SVs_TEMP),
2282 GvNAME(CvGV(outside)),
2283 GvNAMELEN(CvGV(outside)),
2284 GvNAMEUTF8(CvGV(outside)))
2288 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2289 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2294 if (type == SVt_PVLV) {
2295 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2296 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2297 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2298 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2299 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2300 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2301 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2304 if (isREGEXP(sv)) goto dumpregexp;
2305 if (!isGV_with_GP(sv))
2308 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2309 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2310 generic_pv_escape(tmpsv, GvNAME(sv),
2314 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2315 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2316 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2317 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2320 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2321 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2322 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2323 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2324 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2325 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2326 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2327 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2328 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2332 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2333 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2334 do_gv_dump (level, file, " EGV", GvEGV(sv));
2337 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2338 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2339 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2340 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2341 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2342 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2343 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2345 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2346 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2347 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2349 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2350 PTR2UV(IoTOP_GV(sv)));
2351 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2352 maxnest, dumpops, pvlim);
2354 /* Source filters hide things that are not GVs in these three, so let's
2355 be careful out there. */
2357 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2358 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2359 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2361 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2362 PTR2UV(IoFMT_GV(sv)));
2363 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2364 maxnest, dumpops, pvlim);
2366 if (IoBOTTOM_NAME(sv))
2367 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2368 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2369 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2371 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2372 PTR2UV(IoBOTTOM_GV(sv)));
2373 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2374 maxnest, dumpops, pvlim);
2376 if (isPRINT(IoTYPE(sv)))
2377 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2379 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2380 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2385 struct regexp * const r = ReANY((REGEXP*)sv);
2387 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2389 append_flags(d, flags, names); \
2390 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2391 SvCUR_set(d, SvCUR(d) - 1); \
2392 SvPVX(d)[SvCUR(d)] = '\0'; \
2395 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2396 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2397 (UV)(r->compflags), SvPVX_const(d));
2399 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2400 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2401 (UV)(r->extflags), SvPVX_const(d));
2403 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2404 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2405 if (r->engine == &PL_core_reg_engine) {
2406 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2407 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2408 (UV)(r->intflags), SvPVX_const(d));
2410 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2413 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2414 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2416 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2417 (UV)(r->lastparen));
2418 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2419 (UV)(r->lastcloseparen));
2420 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2422 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2423 (IV)(r->minlenret));
2424 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2426 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2427 (UV)(r->pre_prefix));
2428 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2430 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2431 (IV)(r->suboffset));
2432 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2433 (IV)(r->subcoffset));
2435 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2437 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2439 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2440 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2441 PTR2UV(r->mother_re));
2442 if (nest < maxnest && r->mother_re)
2443 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2444 maxnest, dumpops, pvlim);
2445 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2446 PTR2UV(r->paren_names));
2447 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2448 PTR2UV(r->substrs));
2449 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2450 PTR2UV(r->pprivate));
2451 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2453 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2454 PTR2UV(r->qr_anoncv));
2456 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2457 PTR2UV(r->saved_copy));
2468 Dumps the contents of an SV to the C<STDERR> filehandle.
2470 For an example of its output, see L<Devel::Peek>.
2476 Perl_sv_dump(pTHX_ SV *sv)
2478 if (sv && SvROK(sv))
2479 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2481 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2485 Perl_runops_debug(pTHX)
2487 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2488 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2490 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2494 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2497 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2499 #ifdef PERL_TRACE_OPS
2500 ++PL_op_exec_cnt[PL_op->op_type];
2502 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2503 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2504 Perl_croak_nocontext(
2505 "panic: previous op failed to extend arg stack: "
2506 "base=%p, sp=%p, hwm=%p\n",
2507 PL_stack_base, PL_stack_sp,
2508 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2509 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2514 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2515 PerlIO_printf(Perl_debug_log,
2516 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2517 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2518 PTR2UV(*PL_watchaddr));
2519 if (DEBUG_s_TEST_) {
2520 if (DEBUG_v_TEST_) {
2521 PerlIO_printf(Perl_debug_log, "\n");
2529 if (DEBUG_t_TEST_) debop(PL_op);
2530 if (DEBUG_P_TEST_) debprof(PL_op);
2535 PERL_DTRACE_PROBE_OP(PL_op);
2536 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2537 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2540 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2541 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2542 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2549 /* print the names of the n lexical vars starting at pad offset off */
2552 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2555 CV * const cv = deb_curcv(cxstack_ix);
2556 PADNAMELIST *comppad = NULL;
2560 PADLIST * const padlist = CvPADLIST(cv);
2561 comppad = PadlistNAMES(padlist);
2564 PerlIO_printf(Perl_debug_log, "(");
2565 for (i = 0; i < n; i++) {
2566 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2567 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2569 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2572 PerlIO_printf(Perl_debug_log, ",");
2575 PerlIO_printf(Perl_debug_log, ")");
2579 /* append to the out SV, the name of the lexical at offset off in the CV
2583 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2584 bool paren, bool is_scalar)
2587 PADNAMELIST *namepad = NULL;
2591 PADLIST * const padlist = CvPADLIST(cv);
2592 namepad = PadlistNAMES(padlist);
2596 sv_catpvs_nomg(out, "(");
2597 for (i = 0; i < n; i++) {
2598 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2600 STRLEN cur = SvCUR(out);
2601 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2602 UTF8fARG(1, PadnameLEN(sv) - 1,
2603 PadnamePV(sv) + 1));
2605 SvPVX(out)[cur] = '$';
2608 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2610 sv_catpvs_nomg(out, ",");
2613 sv_catpvs_nomg(out, "(");
2618 S_append_gv_name(pTHX_ GV *gv, SV *out)
2622 sv_catpvs_nomg(out, "<NULLGV>");
2626 gv_fullname4(sv, gv, NULL, FALSE);
2627 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2628 SvREFCNT_dec_NN(sv);
2632 # define ITEM_SV(item) (comppad ? \
2633 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2635 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2639 /* return a temporary SV containing a stringified representation of
2640 * the op_aux field of a MULTIDEREF op, associated with CV cv
2644 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2646 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2647 UV actions = items->uv;
2650 bool is_hash = FALSE;
2652 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2657 PADLIST *padlist = CvPADLIST(cv);
2658 comppad = PadlistARRAY(padlist)[1];
2664 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2667 switch (actions & MDEREF_ACTION_MASK) {
2670 actions = (++items)->uv;
2672 NOT_REACHED; /* NOTREACHED */
2674 case MDEREF_HV_padhv_helem:
2677 case MDEREF_AV_padav_aelem:
2679 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2681 NOT_REACHED; /* NOTREACHED */
2683 case MDEREF_HV_gvhv_helem:
2686 case MDEREF_AV_gvav_aelem:
2689 sv = ITEM_SV(items);
2690 S_append_gv_name(aTHX_ (GV*)sv, out);
2692 NOT_REACHED; /* NOTREACHED */
2694 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2697 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2699 sv = ITEM_SV(items);
2700 S_append_gv_name(aTHX_ (GV*)sv, out);
2701 goto do_vivify_rv2xv_elem;
2702 NOT_REACHED; /* NOTREACHED */
2704 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2707 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2708 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2709 goto do_vivify_rv2xv_elem;
2710 NOT_REACHED; /* NOTREACHED */
2712 case MDEREF_HV_pop_rv2hv_helem:
2713 case MDEREF_HV_vivify_rv2hv_helem:
2716 do_vivify_rv2xv_elem:
2717 case MDEREF_AV_pop_rv2av_aelem:
2718 case MDEREF_AV_vivify_rv2av_aelem:
2720 sv_catpvs_nomg(out, "->");
2722 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2723 sv_catpvs_nomg(out, "->");
2728 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2729 switch (actions & MDEREF_INDEX_MASK) {
2730 case MDEREF_INDEX_const:
2733 sv = ITEM_SV(items);
2735 sv_catpvs_nomg(out, "???");
2740 pv_pretty(out, s, cur, 30,
2742 (PERL_PV_PRETTY_NOCLEAR
2743 |PERL_PV_PRETTY_QUOTE
2744 |PERL_PV_PRETTY_ELLIPSES));
2748 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2750 case MDEREF_INDEX_padsv:
2751 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2753 case MDEREF_INDEX_gvsv:
2755 sv = ITEM_SV(items);
2756 S_append_gv_name(aTHX_ (GV*)sv, out);
2759 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2761 if (actions & MDEREF_FLAG_last)
2768 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2769 (int)(actions & MDEREF_ACTION_MASK));
2775 actions >>= MDEREF_SHIFT;
2781 /* Return a temporary SV containing a stringified representation of
2782 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2783 * both plain and utf8 versions of the const string and indices, only
2784 * the first is displayed.
2788 Perl_multiconcat_stringify(pTHX_ const OP *o)
2790 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2791 UNOP_AUX_item *lens;
2795 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2797 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2799 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2800 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2801 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2803 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2804 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2805 sv_catpvs(out, "UTF8 ");
2807 pv_pretty(out, s, len, 50,
2809 (PERL_PV_PRETTY_NOCLEAR
2810 |PERL_PV_PRETTY_QUOTE
2811 |PERL_PV_PRETTY_ELLIPSES));
2813 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2814 while (nargs-- >= 0) {
2815 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
2823 Perl_debop(pTHX_ const OP *o)
2825 PERL_ARGS_ASSERT_DEBOP;
2827 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2830 Perl_deb(aTHX_ "%s", OP_NAME(o));
2831 switch (o->op_type) {
2834 /* With ITHREADS, consts are stored in the pad, and the right pad
2835 * may not be active here, so check.
2836 * Looks like only during compiling the pads are illegal.
2839 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2841 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2845 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2846 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2853 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2857 S_deb_padvar(aTHX_ o->op_targ,
2858 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2862 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2863 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2866 case OP_MULTICONCAT:
2867 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2868 SVfARG(multiconcat_stringify(o)));
2874 PerlIO_printf(Perl_debug_log, "\n");
2880 =for apidoc op_class
2882 Given an op, determine what type of struct it has been allocated as.
2883 Returns one of the OPclass enums, such as OPclass_LISTOP.
2890 Perl_op_class(pTHX_ const OP *o)
2895 return OPclass_NULL;
2897 if (o->op_type == 0) {
2898 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2900 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2903 if (o->op_type == OP_SASSIGN)
2904 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2906 if (o->op_type == OP_AELEMFAST) {
2908 return OPclass_PADOP;
2910 return OPclass_SVOP;
2915 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2916 o->op_type == OP_RCATLINE)
2917 return OPclass_PADOP;
2920 if (o->op_type == OP_CUSTOM)
2923 switch (OP_CLASS(o)) {
2925 return OPclass_BASEOP;
2928 return OPclass_UNOP;
2931 return OPclass_BINOP;
2934 return OPclass_LOGOP;
2937 return OPclass_LISTOP;
2940 return OPclass_PMOP;
2943 return OPclass_SVOP;
2946 return OPclass_PADOP;
2948 case OA_PVOP_OR_SVOP:
2950 * Character translations (tr///) are usually a PVOP, keeping a
2951 * pointer to a table of shorts used to look up translations.
2952 * Under utf8, however, a simple table isn't practical; instead,
2953 * the OP is an SVOP (or, under threads, a PADOP),
2954 * and the SV is a reference to a swash
2955 * (i.e., an RV pointing to an HV).
2958 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2960 #if defined(USE_ITHREADS)
2961 ? OPclass_PADOP : OPclass_PVOP;
2963 ? OPclass_SVOP : OPclass_PVOP;
2967 return OPclass_LOOP;
2972 case OA_BASEOP_OR_UNOP:
2974 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2975 * whether parens were seen. perly.y uses OPf_SPECIAL to
2976 * signal whether a BASEOP had empty parens or none.
2977 * Some other UNOPs are created later, though, so the best
2978 * test is OPf_KIDS, which is set in newUNOP.
2980 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2984 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2985 * the OPf_REF flag to distinguish between OP types instead of the
2986 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2987 * return OPclass_UNOP so that walkoptree can find our children. If
2988 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2989 * (no argument to the operator) it's an OP; with OPf_REF set it's
2990 * an SVOP (and op_sv is the GV for the filehandle argument).
2992 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2994 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2996 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3000 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3001 * label was omitted (in which case it's a BASEOP) or else a term was
3002 * seen. In this last case, all except goto are definitely PVOP but
3003 * goto is either a PVOP (with an ordinary constant label), an UNOP
3004 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3005 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3008 if (o->op_flags & OPf_STACKED)
3009 return OPclass_UNOP;
3010 else if (o->op_flags & OPf_SPECIAL)
3011 return OPclass_BASEOP;
3013 return OPclass_PVOP;
3015 return OPclass_METHOP;
3017 return OPclass_UNOP_AUX;
3019 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3021 return OPclass_BASEOP;
3027 S_deb_curcv(pTHX_ I32 ix)
3029 PERL_SI *si = PL_curstackinfo;
3030 for (; ix >=0; ix--) {
3031 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3033 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3034 return cx->blk_sub.cv;
3035 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3036 return cx->blk_eval.cv;
3037 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3039 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3040 && si->si_type == PERLSI_SORT)
3042 /* fake sort sub; use CV of caller */
3044 ix = si->si_cxix + 1;
3051 Perl_watch(pTHX_ char **addr)
3053 PERL_ARGS_ASSERT_WATCH;
3055 PL_watchaddr = addr;
3057 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3058 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3062 S_debprof(pTHX_ const OP *o)
3064 PERL_ARGS_ASSERT_DEBPROF;
3066 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3068 if (!PL_profiledata)
3069 Newxz(PL_profiledata, MAXO, U32);
3070 ++PL_profiledata[o->op_type];
3074 Perl_debprofdump(pTHX)
3077 if (!PL_profiledata)
3079 for (i = 0; i < MAXO; i++) {
3080 if (PL_profiledata[i])
3081 PerlIO_printf(Perl_debug_log,
3082 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3089 * ex: set ts=8 sts=4 sw=4 et: