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();
367 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
368 /* detect data corruption under memory poisoning */
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_catpv(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_catpv(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_catpv(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_catpv(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_catpv(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_catpv(t, "FREED");
477 if (!SvPVX_const(sv))
478 sv_catpv(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_catpv(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 *o, PerlIO *file)
615 PerlIO_puts(file, " ===> ");
617 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
618 sequence_num(o), OP_NAME(o), PTR2UV(o));
620 PerlIO_puts(file, "[0x0]\n");
626 Dumps the entire optree of the current program starting at C<PL_main_root> to
627 C<STDERR>. Also dumps the optrees for all visible subroutines in
636 dump_all_perl(FALSE);
640 Perl_dump_all_perl(pTHX_ bool justperl)
642 PerlIO_setlinebuf(Perl_debug_log);
644 op_dump(PL_main_root);
645 dump_packsubs_perl(PL_defstash, justperl);
649 =for apidoc dump_packsubs
651 Dumps the optrees for all visible subroutines in C<stash>.
657 Perl_dump_packsubs(pTHX_ const HV *stash)
659 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
660 dump_packsubs_perl(stash, FALSE);
664 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
668 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
672 for (i = 0; i <= (I32) HvMAX(stash); i++) {
674 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
675 GV * gv = (GV *)HeVAL(entry);
676 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
677 /* unfake a fake GV */
678 (void)CvGV(SvRV(gv));
679 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
682 dump_sub_perl(gv, justperl);
685 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
686 const HV * const hv = GvHV(gv);
687 if (hv && (hv != PL_defstash))
688 dump_packsubs_perl(hv, justperl); /* nested package */
695 Perl_dump_sub(pTHX_ const GV *gv)
697 PERL_ARGS_ASSERT_DUMP_SUB;
698 dump_sub_perl(gv, FALSE);
702 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
706 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
708 cv = isGV_with_GP(gv) ? GvCV(gv) :
709 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
710 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
713 if (isGV_with_GP(gv)) {
714 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
715 SV *escsv = newSVpvs_flags("", SVs_TEMP);
718 gv_fullname3(namesv, gv, NULL);
719 namepv = SvPV_const(namesv, namelen);
720 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
721 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
723 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
726 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
728 (int)CvXSUBANY(cv).any_i32);
732 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
736 Perl_dump_form(pTHX_ const GV *gv)
738 SV * const sv = sv_newmortal();
740 PERL_ARGS_ASSERT_DUMP_FORM;
742 gv_fullname3(sv, gv, NULL);
743 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
744 if (CvROOT(GvFORM(gv)))
745 op_dump(CvROOT(GvFORM(gv)));
747 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
753 op_dump(PL_eval_root);
757 /* returns a temp SV displaying the name of a GV. Handles the case where
758 * a GV is in fact a ref to a CV */
761 S_gv_display(pTHX_ GV *gv)
763 SV * const name = newSVpvs_flags("", SVs_TEMP);
765 SV * const raw = newSVpvs_flags("", SVs_TEMP);
769 if (isGV_with_GP(gv))
770 gv_fullname3(raw, gv, NULL);
773 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
774 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
775 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
777 rawpv = SvPV_const(raw, len);
778 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
781 sv_catpvs(name, "(NULL)");
790 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
794 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
801 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
804 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
805 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
806 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
809 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
811 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
812 SV * const tmpsv = pm_description(pm);
813 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
814 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
815 SvREFCNT_dec_NN(tmpsv);
818 if (pm->op_type == OP_SPLIT)
819 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
820 "TARGOFF/GV = 0x%" UVxf "\n",
821 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
823 if (pm->op_pmreplrootu.op_pmreplroot) {
824 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
825 S_do_op_dump_bar(aTHX_ level + 2,
826 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
827 file, pm->op_pmreplrootu.op_pmreplroot);
831 if (pm->op_code_list) {
832 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
833 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
834 S_do_op_dump_bar(aTHX_ level + 2,
835 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
836 file, pm->op_code_list);
839 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
840 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
846 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
848 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
849 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
853 const struct flag_to_name pmflags_flags_names[] = {
854 {PMf_CONST, ",CONST"},
856 {PMf_GLOBAL, ",GLOBAL"},
857 {PMf_CONTINUE, ",CONTINUE"},
858 {PMf_RETAINT, ",RETAINT"},
860 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
861 {PMf_HAS_CV, ",HAS_CV"},
862 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
863 {PMf_IS_QR, ",IS_QR"}
867 S_pm_description(pTHX_ const PMOP *pm)
869 SV * const desc = newSVpvs("");
870 const REGEXP * const regex = PM_GETRE(pm);
871 const U32 pmflags = pm->op_pmflags;
873 PERL_ARGS_ASSERT_PM_DESCRIPTION;
875 if (pmflags & PMf_ONCE)
876 sv_catpv(desc, ",ONCE");
878 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
879 sv_catpv(desc, ":USED");
881 if (pmflags & PMf_USED)
882 sv_catpv(desc, ":USED");
886 if (RX_ISTAINTED(regex))
887 sv_catpv(desc, ",TAINTED");
888 if (RX_CHECK_SUBSTR(regex)) {
889 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
890 sv_catpv(desc, ",SCANFIRST");
891 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
892 sv_catpv(desc, ",ALL");
894 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
895 sv_catpv(desc, ",SKIPWHITE");
898 append_flags(desc, pmflags, pmflags_flags_names);
903 Perl_pmop_dump(pTHX_ PMOP *pm)
905 do_pmop_dump(0, Perl_debug_log, pm);
908 /* Return a unique integer to represent the address of op o.
909 * If it already exists in PL_op_sequence, just return it;
911 * *** Note that this isn't thread-safe */
914 S_sequence_num(pTHX_ const OP *o)
923 op = newSVuv(PTR2UV(o));
925 key = SvPV_const(op, len);
927 PL_op_sequence = newHV();
928 seq = hv_fetch(PL_op_sequence, key, len, 0);
931 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
939 const struct flag_to_name op_flags_names[] = {
941 {OPf_PARENS, ",PARENS"},
944 {OPf_STACKED, ",STACKED"},
945 {OPf_SPECIAL, ",SPECIAL"}
949 /* indexed by enum OPclass */
950 const char * const op_class_names[] = {
968 /* dump an op and any children. level indicates the initial indent.
969 * The bits of bar indicate which indents should receive a vertical bar.
970 * For example if level == 5 and bar == 0b01101, then the indent prefix
971 * emitted will be (not including the <>'s):
974 * 55554444333322221111
976 * For heavily nested output, the level may exceed the number of bits
977 * in bar; in this case the first few columns in the output will simply
978 * not have a bar, which is harmless.
982 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
984 const OPCODE optype = o->op_type;
986 PERL_ARGS_ASSERT_DO_OP_DUMP;
988 /* print op header line */
990 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
992 if (optype == OP_NULL && o->op_targ)
993 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
995 PerlIO_printf(file, " %s(0x%" UVxf ")",
996 op_class_names[op_class(o)], PTR2UV(o));
997 S_opdump_link(aTHX_ o->op_next, file);
999 /* print op common fields */
1001 if (o->op_targ && optype != OP_NULL)
1002 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1005 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1006 SV * const tmpsv = newSVpvs("");
1007 switch (o->op_flags & OPf_WANT) {
1009 sv_catpv(tmpsv, ",VOID");
1011 case OPf_WANT_SCALAR:
1012 sv_catpv(tmpsv, ",SCALAR");
1015 sv_catpv(tmpsv, ",LIST");
1018 sv_catpv(tmpsv, ",UNKNOWN");
1021 append_flags(tmpsv, o->op_flags, op_flags_names);
1022 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1023 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1024 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1025 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1026 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1027 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1028 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1031 if (o->op_private) {
1032 U16 oppriv = o->op_private;
1033 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1038 tmpsv = newSVpvs("");
1039 for (; !stop; op_ix++) {
1040 U16 entry = PL_op_private_bitdefs[op_ix];
1041 U16 bit = (entry >> 2) & 7;
1042 U16 ix = entry >> 5;
1048 I16 const *p = &PL_op_private_bitfields[ix];
1049 U16 bitmin = (U16) *p++;
1056 for (i = bitmin; i<= bit; i++)
1059 val = (oppriv & mask);
1062 && PL_op_private_labels[label] == '-'
1063 && PL_op_private_labels[label+1] == '\0'
1065 /* display as raw number */
1078 if (val == 0 && enum_label == -1)
1079 /* don't display anonymous zero values */
1082 sv_catpv(tmpsv, ",");
1084 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1085 sv_catpv(tmpsv, "=");
1087 if (enum_label == -1)
1088 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1090 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1095 if ( oppriv & (1<<bit)
1096 && !(PL_op_private_labels[ix] == '-'
1097 && PL_op_private_labels[ix+1] == '\0'))
1100 sv_catpv(tmpsv, ",");
1101 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1106 sv_catpv(tmpsv, ",");
1107 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1110 if (tmpsv && SvCUR(tmpsv)) {
1111 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1112 SvPVX_const(tmpsv) + 1);
1114 S_opdump_indent(aTHX_ o, level, bar, file,
1115 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1123 S_opdump_indent(aTHX_ o, level, bar, file,
1124 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1126 S_opdump_indent(aTHX_ o, level, bar, file,
1127 "GV = %" SVf " (0x%" UVxf ")\n",
1128 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1134 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1135 UV i, count = items[-1].uv;
1137 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1138 for (i=0; i < count; i++)
1139 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1140 "%" UVuf " => 0x%" UVxf "\n",
1145 case OP_MULTICONCAT:
1146 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
1147 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
1148 /* XXX really ought to dump each field individually,
1149 * but that's too much like hard work */
1150 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1151 SVfARG(multiconcat_stringify(o)));
1156 case OP_METHOD_NAMED:
1157 case OP_METHOD_SUPER:
1158 case OP_METHOD_REDIR:
1159 case OP_METHOD_REDIR_SUPER:
1160 #ifndef USE_ITHREADS
1161 /* with ITHREADS, consts are stored in the pad, and the right pad
1162 * may not be active here, so skip */
1163 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1164 SvPEEK(cMETHOPx_meth(o)));
1168 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1174 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1175 (UV)CopLINE(cCOPo));
1177 if (CopSTASHPV(cCOPo)) {
1178 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1179 HV *stash = CopSTASH(cCOPo);
1180 const char * const hvname = HvNAME_get(stash);
1182 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1183 generic_pv_escape(tmpsv, hvname,
1184 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1187 if (CopLABEL(cCOPo)) {
1188 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1191 const char *label = CopLABEL_len_flags(cCOPo,
1192 &label_len, &label_flags);
1193 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1194 generic_pv_escape( tmpsv, label, label_len,
1195 (label_flags & SVf_UTF8)));
1198 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1199 (unsigned int)cCOPo->cop_seq);
1204 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1205 S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
1206 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1207 S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
1208 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1209 S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
1229 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1230 S_opdump_link(aTHX_ cLOGOPo->op_other, file);
1236 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1244 if (o->op_private & OPpREFCOUNTED)
1245 S_opdump_indent(aTHX_ o, level, bar, file,
1246 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1254 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1257 SV * const label = newSVpvs_flags("", SVs_TEMP);
1258 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1259 S_opdump_indent(aTHX_ o, level, bar, file,
1260 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1261 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1267 if (o->op_private & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF)) {
1268 /* utf8: table stored as a swash */
1269 #ifndef USE_ITHREADS
1270 /* with ITHREADS, swash is stored in the pad, and the right pad
1271 * may not be active here, so skip */
1272 S_opdump_indent(aTHX_ o, level, bar, file,
1273 "SWASH = 0x%" UVxf "\n",
1274 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1278 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1279 SSize_t i, size = tbl->size;
1281 S_opdump_indent(aTHX_ o, level, bar, file,
1282 "TABLE = 0x%" UVxf "\n",
1284 S_opdump_indent(aTHX_ o, level, bar, file,
1285 " SIZE: 0x%" UVxf "\n", (UV)size);
1287 /* dump size+1 values, to include the extra slot at the end */
1288 for (i = 0; i <= size; i++) {
1289 short val = tbl->map[i];
1291 S_opdump_indent(aTHX_ o, level, bar, file,
1292 " %4" UVxf ":", (UV)i);
1294 PerlIO_printf(file, " %2" IVdf, (IV)val);
1296 PerlIO_printf(file, " %02" UVxf, (UV)val);
1298 if ( i == size || (i & 0xf) == 0xf)
1299 PerlIO_printf(file, "\n");
1308 if (o->op_flags & OPf_KIDS) {
1312 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1313 S_do_op_dump_bar(aTHX_ level,
1314 (bar | cBOOL(OpHAS_SIBLING(kid))),
1321 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1323 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1330 Dumps the optree starting at OP C<o> to C<STDERR>.
1336 Perl_op_dump(pTHX_ const OP *o)
1338 PERL_ARGS_ASSERT_OP_DUMP;
1339 do_op_dump(0, Perl_debug_log, o);
1343 Perl_gv_dump(pTHX_ GV *gv)
1347 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1350 PerlIO_printf(Perl_debug_log, "{}\n");
1353 sv = sv_newmortal();
1354 PerlIO_printf(Perl_debug_log, "{\n");
1355 gv_fullname3(sv, gv, NULL);
1356 name = SvPV_const(sv, len);
1357 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1358 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1359 if (gv != GvEGV(gv)) {
1360 gv_efullname3(sv, GvEGV(gv), NULL);
1361 name = SvPV_const(sv, len);
1362 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1363 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1365 (void)PerlIO_putc(Perl_debug_log, '\n');
1366 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1370 /* map magic types to the symbolic names
1371 * (with the PERL_MAGIC_ prefixed stripped)
1374 static const struct { const char type; const char *name; } magic_names[] = {
1375 #include "mg_names.inc"
1376 /* this null string terminates the list */
1381 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1383 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1385 for (; mg; mg = mg->mg_moremagic) {
1386 Perl_dump_indent(aTHX_ level, file,
1387 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1388 if (mg->mg_virtual) {
1389 const MGVTBL * const v = mg->mg_virtual;
1390 if (v >= PL_magic_vtables
1391 && v < PL_magic_vtables + magic_vtable_max) {
1392 const U32 i = v - PL_magic_vtables;
1393 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1396 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1397 UVxf "\n", PTR2UV(v));
1400 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1403 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1407 const char *name = NULL;
1408 for (n = 0; magic_names[n].name; n++) {
1409 if (mg->mg_type == magic_names[n].type) {
1410 name = magic_names[n].name;
1415 Perl_dump_indent(aTHX_ level, file,
1416 " MG_TYPE = PERL_MAGIC_%s\n", name);
1418 Perl_dump_indent(aTHX_ level, file,
1419 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1423 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1424 if (mg->mg_type == PERL_MAGIC_envelem &&
1425 mg->mg_flags & MGf_TAINTEDDIR)
1426 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1427 if (mg->mg_type == PERL_MAGIC_regex_global &&
1428 mg->mg_flags & MGf_MINMATCH)
1429 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1430 if (mg->mg_flags & MGf_REFCOUNTED)
1431 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1432 if (mg->mg_flags & MGf_GSKIP)
1433 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1434 if (mg->mg_flags & MGf_COPY)
1435 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1436 if (mg->mg_flags & MGf_DUP)
1437 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1438 if (mg->mg_flags & MGf_LOCAL)
1439 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1440 if (mg->mg_type == PERL_MAGIC_regex_global &&
1441 mg->mg_flags & MGf_BYTES)
1442 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1445 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1446 PTR2UV(mg->mg_obj));
1447 if (mg->mg_type == PERL_MAGIC_qr) {
1448 REGEXP* const re = (REGEXP *)mg->mg_obj;
1449 SV * const dsv = sv_newmortal();
1450 const char * const s
1451 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1453 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1454 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1456 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1457 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1460 if (mg->mg_flags & MGf_REFCOUNTED)
1461 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1464 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1466 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1467 if (mg->mg_len >= 0) {
1468 if (mg->mg_type != PERL_MAGIC_utf8) {
1469 SV * const sv = newSVpvs("");
1470 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1471 SvREFCNT_dec_NN(sv);
1474 else if (mg->mg_len == HEf_SVKEY) {
1475 PerlIO_puts(file, " => HEf_SVKEY\n");
1476 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1477 maxnest, dumpops, pvlim); /* MG is already +1 */
1480 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1485 " does not know how to handle this MG_LEN"
1487 (void)PerlIO_putc(file, '\n');
1489 if (mg->mg_type == PERL_MAGIC_utf8) {
1490 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1493 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1494 Perl_dump_indent(aTHX_ level, file,
1495 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1498 (UV)cache[i * 2 + 1]);
1505 Perl_magic_dump(pTHX_ const MAGIC *mg)
1507 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1511 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1515 PERL_ARGS_ASSERT_DO_HV_DUMP;
1517 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1518 if (sv && (hvname = HvNAME_get(sv)))
1520 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1521 name which quite legally could contain insane things like tabs, newlines, nulls or
1522 other scary crap - this should produce sane results - except maybe for unicode package
1523 names - but we will wait for someone to file a bug on that - demerphq */
1524 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1525 PerlIO_printf(file, "\t\"%s\"\n",
1526 generic_pv_escape( tmpsv, hvname,
1527 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1530 (void)PerlIO_putc(file, '\n');
1534 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1536 PERL_ARGS_ASSERT_DO_GV_DUMP;
1538 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1539 if (sv && GvNAME(sv)) {
1540 SV * const tmpsv = newSVpvs("");
1541 PerlIO_printf(file, "\t\"%s\"\n",
1542 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1545 (void)PerlIO_putc(file, '\n');
1549 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1551 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1553 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1554 if (sv && GvNAME(sv)) {
1555 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1557 HV * const stash = GvSTASH(sv);
1558 PerlIO_printf(file, "\t");
1559 /* TODO might have an extra \" here */
1560 if (stash && (hvname = HvNAME_get(stash))) {
1561 PerlIO_printf(file, "\"%s\" :: \"",
1562 generic_pv_escape(tmp, hvname,
1563 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1565 PerlIO_printf(file, "%s\"\n",
1566 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1569 (void)PerlIO_putc(file, '\n');
1572 const struct flag_to_name first_sv_flags_names[] = {
1573 {SVs_TEMP, "TEMP,"},
1574 {SVs_OBJECT, "OBJECT,"},
1583 const struct flag_to_name second_sv_flags_names[] = {
1585 {SVf_FAKE, "FAKE,"},
1586 {SVf_READONLY, "READONLY,"},
1587 {SVf_PROTECT, "PROTECT,"},
1588 {SVf_BREAK, "BREAK,"},
1594 const struct flag_to_name cv_flags_names[] = {
1595 {CVf_ANON, "ANON,"},
1596 {CVf_UNIQUE, "UNIQUE,"},
1597 {CVf_CLONE, "CLONE,"},
1598 {CVf_CLONED, "CLONED,"},
1599 {CVf_CONST, "CONST,"},
1600 {CVf_NODEBUG, "NODEBUG,"},
1601 {CVf_LVALUE, "LVALUE,"},
1602 {CVf_METHOD, "METHOD,"},
1603 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1604 {CVf_CVGV_RC, "CVGV_RC,"},
1605 {CVf_DYNFILE, "DYNFILE,"},
1606 {CVf_AUTOLOAD, "AUTOLOAD,"},
1607 {CVf_HASEVAL, "HASEVAL,"},
1608 {CVf_SLABBED, "SLABBED,"},
1609 {CVf_NAMED, "NAMED,"},
1610 {CVf_LEXICAL, "LEXICAL,"},
1611 {CVf_ISXSUB, "ISXSUB,"}
1614 const struct flag_to_name hv_flags_names[] = {
1615 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1616 {SVphv_LAZYDEL, "LAZYDEL,"},
1617 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1618 {SVf_AMAGIC, "OVERLOAD,"},
1619 {SVphv_CLONEABLE, "CLONEABLE,"}
1622 const struct flag_to_name gp_flags_names[] = {
1623 {GVf_INTRO, "INTRO,"},
1624 {GVf_MULTI, "MULTI,"},
1625 {GVf_ASSUMECV, "ASSUMECV,"},
1628 const struct flag_to_name gp_flags_imported_names[] = {
1629 {GVf_IMPORTED_SV, " SV"},
1630 {GVf_IMPORTED_AV, " AV"},
1631 {GVf_IMPORTED_HV, " HV"},
1632 {GVf_IMPORTED_CV, " CV"},
1635 /* NOTE: this structure is mostly duplicative of one generated by
1636 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1637 * the two. - Yves */
1638 const struct flag_to_name regexp_extflags_names[] = {
1639 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1640 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1641 {RXf_PMf_FOLD, "PMf_FOLD,"},
1642 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1643 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1644 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1645 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1646 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1647 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1648 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1649 {RXf_CHECK_ALL, "CHECK_ALL,"},
1650 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1651 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1652 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1653 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1654 {RXf_SPLIT, "SPLIT,"},
1655 {RXf_COPY_DONE, "COPY_DONE,"},
1656 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1657 {RXf_TAINTED, "TAINTED,"},
1658 {RXf_START_ONLY, "START_ONLY,"},
1659 {RXf_SKIPWHITE, "SKIPWHITE,"},
1660 {RXf_WHITE, "WHITE,"},
1661 {RXf_NULL, "NULL,"},
1664 /* NOTE: this structure is mostly duplicative of one generated by
1665 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1666 * the two. - Yves */
1667 const struct flag_to_name regexp_core_intflags_names[] = {
1668 {PREGf_SKIP, "SKIP,"},
1669 {PREGf_IMPLICIT, "IMPLICIT,"},
1670 {PREGf_NAUGHTY, "NAUGHTY,"},
1671 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1672 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1673 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1674 {PREGf_NOSCAN, "NOSCAN,"},
1675 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1676 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1677 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1678 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1679 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1682 /* Perl_do_sv_dump():
1684 * level: amount to indent the output
1685 * sv: the object to dump
1686 * nest: the current level of recursion
1687 * maxnest: the maximum allowed level of recursion
1688 * dumpops: if true, also dump the ops associated with a CV
1689 * pvlim: limit on the length of any strings that are output
1693 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1700 PERL_ARGS_ASSERT_DO_SV_DUMP;
1703 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1707 flags = SvFLAGS(sv);
1710 /* process general SV flags */
1712 d = Perl_newSVpvf(aTHX_
1713 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1714 PTR2UV(SvANY(sv)), PTR2UV(sv),
1715 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1716 (int)(PL_dumpindent*level), "");
1718 if ((flags & SVs_PADSTALE))
1719 sv_catpv(d, "PADSTALE,");
1720 if ((flags & SVs_PADTMP))
1721 sv_catpv(d, "PADTMP,");
1722 append_flags(d, flags, first_sv_flags_names);
1723 if (flags & SVf_ROK) {
1724 sv_catpv(d, "ROK,");
1725 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1727 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1728 append_flags(d, flags, second_sv_flags_names);
1729 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1730 && type != SVt_PVAV) {
1731 if (SvPCS_IMPORTED(sv))
1732 sv_catpv(d, "PCS_IMPORTED,");
1734 sv_catpv(d, "SCREAM,");
1737 /* process type-specific SV flags */
1742 append_flags(d, CvFLAGS(sv), cv_flags_names);
1745 append_flags(d, flags, hv_flags_names);
1749 if (isGV_with_GP(sv)) {
1750 append_flags(d, GvFLAGS(sv), gp_flags_names);
1752 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1753 sv_catpv(d, "IMPORT");
1754 if (GvIMPORTED(sv) == GVf_IMPORTED)
1755 sv_catpv(d, "ALL,");
1758 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1765 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1771 /* SVphv_SHAREKEYS is also 0x20000000 */
1772 if ((type != SVt_PVHV) && SvUTF8(sv))
1773 sv_catpv(d, "UTF8");
1775 if (*(SvEND(d) - 1) == ',') {
1776 SvCUR_set(d, SvCUR(d) - 1);
1777 SvPVX(d)[SvCUR(d)] = '\0';
1782 /* dump initial SV details */
1784 #ifdef DEBUG_LEAKING_SCALARS
1785 Perl_dump_indent(aTHX_ level, file,
1786 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1787 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1789 sv->sv_debug_inpad ? "for" : "by",
1790 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1791 PTR2UV(sv->sv_debug_parent),
1795 Perl_dump_indent(aTHX_ level, file, "SV = ");
1799 if (type < SVt_LAST) {
1800 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1802 if (type == SVt_NULL) {
1807 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1812 /* Dump general SV fields */
1814 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1815 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1816 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1817 || (type == SVt_IV && !SvROK(sv))) {
1820 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1822 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1823 (void)PerlIO_putc(file, '\n');
1826 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1827 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1828 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1829 || type == SVt_NV) {
1830 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1831 STORE_LC_NUMERIC_SET_STANDARD();
1832 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1833 RESTORE_LC_NUMERIC();
1837 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1840 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1843 if (type < SVt_PV) {
1848 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1849 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1850 const bool re = isREGEXP(sv);
1851 const char * const ptr =
1852 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1856 SvOOK_offset(sv, delta);
1857 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1862 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1865 PerlIO_printf(file, "( %s . ) ",
1866 pv_display(d, ptr - delta, delta, 0,
1869 if (type == SVt_INVLIST) {
1870 PerlIO_printf(file, "\n");
1871 /* 4 blanks indents 2 beyond the PV, etc */
1872 _invlist_dump(file, level, " ", sv);
1875 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1878 if (SvUTF8(sv)) /* the 6? \x{....} */
1879 PerlIO_printf(file, " [UTF8 \"%s\"]",
1880 sv_uni_display(d, sv, 6 * SvCUR(sv),
1882 PerlIO_printf(file, "\n");
1884 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1885 if (re && type == SVt_PVLV)
1886 /* LV-as-REGEXP usurps len field to store pointer to
1888 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1889 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1891 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1893 #ifdef PERL_COPY_ON_WRITE
1894 if (SvIsCOW(sv) && SvLEN(sv))
1895 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1900 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1903 if (type >= SVt_PVMG) {
1905 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1907 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1909 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1910 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1915 /* Dump type-specific SV fields */
1919 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1920 PTR2UV(AvARRAY(sv)));
1921 if (AvARRAY(sv) != AvALLOC(sv)) {
1922 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1923 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1924 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1925 PTR2UV(AvALLOC(sv)));
1928 (void)PerlIO_putc(file, '\n');
1929 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1931 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1934 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1935 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1936 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1937 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1938 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1940 SV **svp = AvARRAY(MUTABLE_AV(sv));
1942 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1945 SV* const elt = *svp;
1946 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1948 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1955 struct xpvhv_aux *const aux = HvAUX(sv);
1956 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1957 (UV)aux->xhv_aux_flags);
1959 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1960 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1961 if (HvARRAY(sv) && usedkeys) {
1962 /* Show distribution of HEs in the ARRAY */
1964 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1967 U32 pow2 = 2, keys = usedkeys;
1968 NV theoret, sum = 0;
1970 PerlIO_printf(file, " (");
1971 Zero(freq, FREQ_MAX + 1, int);
1972 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1975 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1977 if (count > FREQ_MAX)
1983 for (i = 0; i <= max; i++) {
1985 PerlIO_printf(file, "%d%s:%d", i,
1986 (i == FREQ_MAX) ? "+" : "",
1989 PerlIO_printf(file, ", ");
1992 (void)PerlIO_putc(file, ')');
1993 /* The "quality" of a hash is defined as the total number of
1994 comparisons needed to access every element once, relative
1995 to the expected number needed for a random hash.
1997 The total number of comparisons is equal to the sum of
1998 the squares of the number of entries in each bucket.
1999 For a random hash of n keys into k buckets, the expected
2004 for (i = max; i > 0; i--) { /* Precision: count down. */
2005 sum += freq[i] * i * i;
2007 while ((keys = keys >> 1))
2010 theoret += theoret * (theoret-1)/pow2;
2011 (void)PerlIO_putc(file, '\n');
2012 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2013 NVff "%%", theoret/sum*100);
2015 (void)PerlIO_putc(file, '\n');
2016 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2020 HE **ents = HvARRAY(sv);
2023 HE *const *const last = ents + HvMAX(sv);
2024 count = last + 1 - ents;
2029 } while (++ents <= last);
2032 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2035 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2038 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2039 (IV)HvRITER_get(sv));
2040 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2041 PTR2UV(HvEITER_get(sv)));
2042 #ifdef PERL_HASH_RANDOMIZE_KEYS
2043 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2044 (UV)HvRAND_get(sv));
2045 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2046 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2047 (UV)HvLASTRAND_get(sv));
2050 (void)PerlIO_putc(file, '\n');
2053 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2054 if (mg && mg->mg_obj) {
2055 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2059 const char * const hvname = HvNAME_get(sv);
2061 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2062 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2063 generic_pv_escape( tmpsv, hvname,
2064 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2069 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2070 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2071 if (HvAUX(sv)->xhv_name_count)
2072 Perl_dump_indent(aTHX_
2073 level, file, " NAMECOUNT = %" IVdf "\n",
2074 (IV)HvAUX(sv)->xhv_name_count
2076 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2077 const I32 count = HvAUX(sv)->xhv_name_count;
2079 SV * const names = newSVpvs_flags("", SVs_TEMP);
2080 /* The starting point is the first element if count is
2081 positive and the second element if count is negative. */
2082 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2083 + (count < 0 ? 1 : 0);
2084 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2085 + (count < 0 ? -count : count);
2086 while (hekp < endp) {
2088 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2089 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2090 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2092 /* This should never happen. */
2093 sv_catpvs(names, ", (null)");
2097 Perl_dump_indent(aTHX_
2098 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2102 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2103 const char *const hvename = HvENAME_get(sv);
2104 Perl_dump_indent(aTHX_
2105 level, file, " ENAME = \"%s\"\n",
2106 generic_pv_escape(tmp, hvename,
2107 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2111 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2113 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2117 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2118 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2120 generic_pv_escape( tmpsv, meta->mro_which->name,
2121 meta->mro_which->length,
2122 (meta->mro_which->kflags & HVhek_UTF8)),
2123 PTR2UV(meta->mro_which));
2124 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2126 (UV)meta->cache_gen);
2127 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2129 if (meta->mro_linear_all) {
2130 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2132 PTR2UV(meta->mro_linear_all));
2133 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2136 if (meta->mro_linear_current) {
2137 Perl_dump_indent(aTHX_ level, file,
2138 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2139 PTR2UV(meta->mro_linear_current));
2140 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2143 if (meta->mro_nextmethod) {
2144 Perl_dump_indent(aTHX_ level, file,
2145 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2146 PTR2UV(meta->mro_nextmethod));
2147 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2151 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2153 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2158 if (nest < maxnest) {
2159 HV * const hv = MUTABLE_HV(sv);
2164 int count = maxnest - nest;
2165 for (i=0; i <= HvMAX(hv); i++) {
2166 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2173 if (count-- <= 0) goto DONEHV;
2176 keysv = hv_iterkeysv(he);
2177 keypv = SvPV_const(keysv, len);
2180 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2182 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2183 if (HvEITER_get(hv) == he)
2184 PerlIO_printf(file, "[CURRENT] ");
2185 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2186 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2193 } /* case SVt_PVHV */
2196 if (CvAUTOLOAD(sv)) {
2197 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2199 const char *const name = SvPV_const(sv, len);
2200 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2201 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2204 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2205 const char *const proto = CvPROTO(sv);
2206 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2207 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2212 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2213 if (!CvISXSUB(sv)) {
2216 Perl_dump_indent(aTHX_ level, file,
2217 " SLAB = 0x%" UVxf "\n",
2218 PTR2UV(CvSTART(sv)));
2220 Perl_dump_indent(aTHX_ level, file,
2221 " START = 0x%" UVxf " ===> %" IVdf "\n",
2222 PTR2UV(CvSTART(sv)),
2223 (IV)sequence_num(CvSTART(sv)));
2225 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2226 PTR2UV(CvROOT(sv)));
2227 if (CvROOT(sv) && dumpops) {
2228 do_op_dump(level+1, file, CvROOT(sv));
2231 SV * const constant = cv_const_sv((const CV *)sv);
2233 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2236 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2238 PTR2UV(CvXSUBANY(sv).any_ptr));
2239 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2242 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2243 (IV)CvXSUBANY(sv).any_i32);
2247 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2248 HEK_KEY(CvNAME_HEK((CV *)sv)));
2249 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2250 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2251 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2252 IVdf "\n", (IV)CvDEPTH(sv));
2253 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2255 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2256 if (!CvISXSUB(sv)) {
2257 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2258 if (nest < maxnest) {
2259 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2263 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2265 const CV * const outside = CvOUTSIDE(sv);
2266 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2269 : CvANON(outside) ? "ANON"
2270 : (outside == PL_main_cv) ? "MAIN"
2271 : CvUNIQUE(outside) ? "UNIQUE"
2274 newSVpvs_flags("", SVs_TEMP),
2275 GvNAME(CvGV(outside)),
2276 GvNAMELEN(CvGV(outside)),
2277 GvNAMEUTF8(CvGV(outside)))
2281 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2282 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2287 if (type == SVt_PVLV) {
2288 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2289 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2290 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2291 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2292 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2293 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2294 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2297 if (isREGEXP(sv)) goto dumpregexp;
2298 if (!isGV_with_GP(sv))
2301 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2302 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2303 generic_pv_escape(tmpsv, GvNAME(sv),
2307 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2308 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2309 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2310 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2313 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2314 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2315 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2316 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2317 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2318 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2319 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2320 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2321 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2325 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2326 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2327 do_gv_dump (level, file, " EGV", GvEGV(sv));
2330 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2331 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2332 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2333 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2334 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2335 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2336 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2338 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2339 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2340 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2342 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2343 PTR2UV(IoTOP_GV(sv)));
2344 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2345 maxnest, dumpops, pvlim);
2347 /* Source filters hide things that are not GVs in these three, so let's
2348 be careful out there. */
2350 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2351 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2352 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2354 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2355 PTR2UV(IoFMT_GV(sv)));
2356 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2357 maxnest, dumpops, pvlim);
2359 if (IoBOTTOM_NAME(sv))
2360 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2361 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2362 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2364 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2365 PTR2UV(IoBOTTOM_GV(sv)));
2366 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2367 maxnest, dumpops, pvlim);
2369 if (isPRINT(IoTYPE(sv)))
2370 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2372 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2373 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2378 struct regexp * const r = ReANY((REGEXP*)sv);
2380 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2382 append_flags(d, flags, names); \
2383 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2384 SvCUR_set(d, SvCUR(d) - 1); \
2385 SvPVX(d)[SvCUR(d)] = '\0'; \
2388 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2389 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2390 (UV)(r->compflags), SvPVX_const(d));
2392 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2393 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2394 (UV)(r->extflags), SvPVX_const(d));
2396 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2397 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2398 if (r->engine == &PL_core_reg_engine) {
2399 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2400 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2401 (UV)(r->intflags), SvPVX_const(d));
2403 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2406 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2407 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2409 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2410 (UV)(r->lastparen));
2411 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2412 (UV)(r->lastcloseparen));
2413 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2415 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2416 (IV)(r->minlenret));
2417 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2419 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2420 (UV)(r->pre_prefix));
2421 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2423 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2424 (IV)(r->suboffset));
2425 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2426 (IV)(r->subcoffset));
2428 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2430 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2432 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2433 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2434 PTR2UV(r->mother_re));
2435 if (nest < maxnest && r->mother_re)
2436 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2437 maxnest, dumpops, pvlim);
2438 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2439 PTR2UV(r->paren_names));
2440 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2441 PTR2UV(r->substrs));
2442 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2443 PTR2UV(r->pprivate));
2444 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2446 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2447 PTR2UV(r->qr_anoncv));
2449 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2450 PTR2UV(r->saved_copy));
2461 Dumps the contents of an SV to the C<STDERR> filehandle.
2463 For an example of its output, see L<Devel::Peek>.
2469 Perl_sv_dump(pTHX_ SV *sv)
2471 if (sv && SvROK(sv))
2472 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2474 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2478 Perl_runops_debug(pTHX)
2480 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2481 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2483 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2487 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2490 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2492 #ifdef PERL_TRACE_OPS
2493 ++PL_op_exec_cnt[PL_op->op_type];
2495 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2496 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2497 Perl_croak_nocontext(
2498 "panic: previous op failed to extend arg stack: "
2499 "base=%p, sp=%p, hwm=%p\n",
2500 PL_stack_base, PL_stack_sp,
2501 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2502 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2507 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2508 PerlIO_printf(Perl_debug_log,
2509 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2510 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2511 PTR2UV(*PL_watchaddr));
2512 if (DEBUG_s_TEST_) {
2513 if (DEBUG_v_TEST_) {
2514 PerlIO_printf(Perl_debug_log, "\n");
2522 if (DEBUG_t_TEST_) debop(PL_op);
2523 if (DEBUG_P_TEST_) debprof(PL_op);
2528 PERL_DTRACE_PROBE_OP(PL_op);
2529 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2530 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2533 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2534 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2535 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2542 /* print the names of the n lexical vars starting at pad offset off */
2545 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2548 CV * const cv = deb_curcv(cxstack_ix);
2549 PADNAMELIST *comppad = NULL;
2553 PADLIST * const padlist = CvPADLIST(cv);
2554 comppad = PadlistNAMES(padlist);
2557 PerlIO_printf(Perl_debug_log, "(");
2558 for (i = 0; i < n; i++) {
2559 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2560 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2562 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2565 PerlIO_printf(Perl_debug_log, ",");
2568 PerlIO_printf(Perl_debug_log, ")");
2572 /* append to the out SV, the name of the lexical at offset off in the CV
2576 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2577 bool paren, bool is_scalar)
2580 PADNAMELIST *namepad = NULL;
2584 PADLIST * const padlist = CvPADLIST(cv);
2585 namepad = PadlistNAMES(padlist);
2589 sv_catpvs_nomg(out, "(");
2590 for (i = 0; i < n; i++) {
2591 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2593 STRLEN cur = SvCUR(out);
2594 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2595 UTF8fARG(1, PadnameLEN(sv) - 1,
2596 PadnamePV(sv) + 1));
2598 SvPVX(out)[cur] = '$';
2601 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2603 sv_catpvs_nomg(out, ",");
2606 sv_catpvs_nomg(out, "(");
2611 S_append_gv_name(pTHX_ GV *gv, SV *out)
2615 sv_catpvs_nomg(out, "<NULLGV>");
2619 gv_fullname4(sv, gv, NULL, FALSE);
2620 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2621 SvREFCNT_dec_NN(sv);
2625 # define ITEM_SV(item) (comppad ? \
2626 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2628 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2632 /* return a temporary SV containing a stringified representation of
2633 * the op_aux field of a MULTIDEREF op, associated with CV cv
2637 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2639 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2640 UV actions = items->uv;
2643 bool is_hash = FALSE;
2645 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2650 PADLIST *padlist = CvPADLIST(cv);
2651 comppad = PadlistARRAY(padlist)[1];
2657 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2660 switch (actions & MDEREF_ACTION_MASK) {
2663 actions = (++items)->uv;
2665 NOT_REACHED; /* NOTREACHED */
2667 case MDEREF_HV_padhv_helem:
2670 case MDEREF_AV_padav_aelem:
2672 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2674 NOT_REACHED; /* NOTREACHED */
2676 case MDEREF_HV_gvhv_helem:
2679 case MDEREF_AV_gvav_aelem:
2682 sv = ITEM_SV(items);
2683 S_append_gv_name(aTHX_ (GV*)sv, out);
2685 NOT_REACHED; /* NOTREACHED */
2687 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2690 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2692 sv = ITEM_SV(items);
2693 S_append_gv_name(aTHX_ (GV*)sv, out);
2694 goto do_vivify_rv2xv_elem;
2695 NOT_REACHED; /* NOTREACHED */
2697 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2700 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2701 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2702 goto do_vivify_rv2xv_elem;
2703 NOT_REACHED; /* NOTREACHED */
2705 case MDEREF_HV_pop_rv2hv_helem:
2706 case MDEREF_HV_vivify_rv2hv_helem:
2709 do_vivify_rv2xv_elem:
2710 case MDEREF_AV_pop_rv2av_aelem:
2711 case MDEREF_AV_vivify_rv2av_aelem:
2713 sv_catpvs_nomg(out, "->");
2715 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2716 sv_catpvs_nomg(out, "->");
2721 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2722 switch (actions & MDEREF_INDEX_MASK) {
2723 case MDEREF_INDEX_const:
2726 sv = ITEM_SV(items);
2728 sv_catpvs_nomg(out, "???");
2733 pv_pretty(out, s, cur, 30,
2735 (PERL_PV_PRETTY_NOCLEAR
2736 |PERL_PV_PRETTY_QUOTE
2737 |PERL_PV_PRETTY_ELLIPSES));
2741 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2743 case MDEREF_INDEX_padsv:
2744 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2746 case MDEREF_INDEX_gvsv:
2748 sv = ITEM_SV(items);
2749 S_append_gv_name(aTHX_ (GV*)sv, out);
2752 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2754 if (actions & MDEREF_FLAG_last)
2761 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2762 (int)(actions & MDEREF_ACTION_MASK));
2768 actions >>= MDEREF_SHIFT;
2774 /* Return a temporary SV containing a stringified representation of
2775 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2776 * both plain and utf8 versions of the const string and indices, only
2777 * the first is displayed.
2781 Perl_multiconcat_stringify(pTHX_ const OP *o)
2783 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2784 UNOP_AUX_item *lens;
2788 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2790 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2792 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2793 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2794 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2796 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2797 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2798 sv_catpvs(out, "UTF8 ");
2800 pv_pretty(out, s, len, 50,
2802 (PERL_PV_PRETTY_NOCLEAR
2803 |PERL_PV_PRETTY_QUOTE
2804 |PERL_PV_PRETTY_ELLIPSES));
2806 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2807 while (nargs-- >= 0) {
2808 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
2816 Perl_debop(pTHX_ const OP *o)
2818 PERL_ARGS_ASSERT_DEBOP;
2820 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2823 Perl_deb(aTHX_ "%s", OP_NAME(o));
2824 switch (o->op_type) {
2827 /* With ITHREADS, consts are stored in the pad, and the right pad
2828 * may not be active here, so check.
2829 * Looks like only during compiling the pads are illegal.
2832 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2834 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2838 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2839 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2846 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2850 S_deb_padvar(aTHX_ o->op_targ,
2851 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2855 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2856 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2859 case OP_MULTICONCAT:
2860 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2861 SVfARG(multiconcat_stringify(o)));
2867 PerlIO_printf(Perl_debug_log, "\n");
2873 =for apidoc op_class
2875 Given an op, determine what type of struct it has been allocated as.
2876 Returns one of the OPclass enums, such as OPclass_LISTOP.
2883 Perl_op_class(pTHX_ const OP *o)
2888 return OPclass_NULL;
2890 if (o->op_type == 0) {
2891 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2893 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2896 if (o->op_type == OP_SASSIGN)
2897 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2899 if (o->op_type == OP_AELEMFAST) {
2901 return OPclass_PADOP;
2903 return OPclass_SVOP;
2908 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2909 o->op_type == OP_RCATLINE)
2910 return OPclass_PADOP;
2913 if (o->op_type == OP_CUSTOM)
2916 switch (OP_CLASS(o)) {
2918 return OPclass_BASEOP;
2921 return OPclass_UNOP;
2924 return OPclass_BINOP;
2927 return OPclass_LOGOP;
2930 return OPclass_LISTOP;
2933 return OPclass_PMOP;
2936 return OPclass_SVOP;
2939 return OPclass_PADOP;
2941 case OA_PVOP_OR_SVOP:
2943 * Character translations (tr///) are usually a PVOP, keeping a
2944 * pointer to a table of shorts used to look up translations.
2945 * Under utf8, however, a simple table isn't practical; instead,
2946 * the OP is an SVOP (or, under threads, a PADOP),
2947 * and the SV is a reference to a swash
2948 * (i.e., an RV pointing to an HV).
2951 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2953 #if defined(USE_ITHREADS)
2954 ? OPclass_PADOP : OPclass_PVOP;
2956 ? OPclass_SVOP : OPclass_PVOP;
2960 return OPclass_LOOP;
2965 case OA_BASEOP_OR_UNOP:
2967 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2968 * whether parens were seen. perly.y uses OPf_SPECIAL to
2969 * signal whether a BASEOP had empty parens or none.
2970 * Some other UNOPs are created later, though, so the best
2971 * test is OPf_KIDS, which is set in newUNOP.
2973 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2977 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2978 * the OPf_REF flag to distinguish between OP types instead of the
2979 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2980 * return OPclass_UNOP so that walkoptree can find our children. If
2981 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2982 * (no argument to the operator) it's an OP; with OPf_REF set it's
2983 * an SVOP (and op_sv is the GV for the filehandle argument).
2985 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2987 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2989 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2993 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2994 * label was omitted (in which case it's a BASEOP) or else a term was
2995 * seen. In this last case, all except goto are definitely PVOP but
2996 * goto is either a PVOP (with an ordinary constant label), an UNOP
2997 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2998 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3001 if (o->op_flags & OPf_STACKED)
3002 return OPclass_UNOP;
3003 else if (o->op_flags & OPf_SPECIAL)
3004 return OPclass_BASEOP;
3006 return OPclass_PVOP;
3008 return OPclass_METHOP;
3010 return OPclass_UNOP_AUX;
3012 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3014 return OPclass_BASEOP;
3020 S_deb_curcv(pTHX_ I32 ix)
3022 PERL_SI *si = PL_curstackinfo;
3023 for (; ix >=0; ix--) {
3024 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3026 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3027 return cx->blk_sub.cv;
3028 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3029 return cx->blk_eval.cv;
3030 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3032 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3033 && si->si_type == PERLSI_SORT)
3035 /* fake sort sub; use CV of caller */
3037 ix = si->si_cxix + 1;
3044 Perl_watch(pTHX_ char **addr)
3046 PERL_ARGS_ASSERT_WATCH;
3048 PL_watchaddr = addr;
3050 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3051 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3055 S_debprof(pTHX_ const OP *o)
3057 PERL_ARGS_ASSERT_DEBPROF;
3059 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3061 if (!PL_profiledata)
3062 Newxz(PL_profiledata, MAXO, U32);
3063 ++PL_profiledata[o->op_type];
3067 Perl_debprofdump(pTHX)
3070 if (!PL_profiledata)
3072 for (i = 0; i < MAXO; i++) {
3073 if (PL_profiledata[i])
3074 PerlIO_printf(Perl_debug_log,
3075 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3082 * ex: set ts=8 sts=4 sw=4 et: