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 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
497 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
498 RESTORE_LC_NUMERIC_UNDERLYING();
500 else if (SvIOKp(sv)) {
502 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
504 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
512 if (TAINTING_get && sv && SvTAINTED(sv))
513 sv_catpv(t, " [tainted]");
514 return SvPV_nolen(t);
518 =head1 Debugging Utilities
522 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
525 PERL_ARGS_ASSERT_DUMP_INDENT;
527 dump_vindent(level, file, pat, &args);
532 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
534 PERL_ARGS_ASSERT_DUMP_VINDENT;
535 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
536 PerlIO_vprintf(file, pat, *args);
540 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
541 * for each indent level as appropriate.
543 * bar contains bits indicating which indent columns should have a
544 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
545 * levels than bits in bar, then the first few indents are displayed
548 * The start of a new op is signalled by passing a value for level which
549 * has been negated and offset by 1 (so that level 0 is passed as -1 and
550 * can thus be distinguished from -0); in this case, emit a suitably
551 * indented blank line, then on the next line, display the op's sequence
552 * number, and make the final indent an '+----'.
556 * | FOO # level = 1, bar = 0b1
557 * | | # level =-2-1, bar = 0b11
559 * | BAZ # level = 2, bar = 0b10
563 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
564 const char* pat, ...)
568 bool newop = (level < 0);
572 /* start displaying a new op? */
574 UV seq = sequence_num(o);
578 /* output preceding blank line */
579 PerlIO_puts(file, " ");
580 for (i = level-1; i >= 0; i--)
581 PerlIO_puts(file, ( i == 0
582 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
585 PerlIO_puts(file, "\n");
587 /* output sequence number */
589 PerlIO_printf(file, "%-4" UVuf " ", seq);
591 PerlIO_puts(file, "???? ");
595 PerlIO_printf(file, " ");
597 for (i = level-1; i >= 0; i--)
599 (i == 0 && newop) ? "+--"
600 : (bar & (1 << i)) ? "| "
602 PerlIO_vprintf(file, pat, args);
607 /* display a link field (e.g. op_next) in the format
608 * ====> sequence_number [opname 0x123456]
612 S_opdump_link(pTHX_ const OP *o, PerlIO *file)
614 PerlIO_puts(file, " ===> ");
616 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
617 sequence_num(o), OP_NAME(o), PTR2UV(o));
619 PerlIO_puts(file, "[0x0]\n");
625 Dumps the entire optree of the current program starting at C<PL_main_root> to
626 C<STDERR>. Also dumps the optrees for all visible subroutines in
635 dump_all_perl(FALSE);
639 Perl_dump_all_perl(pTHX_ bool justperl)
641 PerlIO_setlinebuf(Perl_debug_log);
643 op_dump(PL_main_root);
644 dump_packsubs_perl(PL_defstash, justperl);
648 =for apidoc dump_packsubs
650 Dumps the optrees for all visible subroutines in C<stash>.
656 Perl_dump_packsubs(pTHX_ const HV *stash)
658 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
659 dump_packsubs_perl(stash, FALSE);
663 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
667 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
671 for (i = 0; i <= (I32) HvMAX(stash); i++) {
673 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
674 GV * gv = (GV *)HeVAL(entry);
675 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
676 /* unfake a fake GV */
677 (void)CvGV(SvRV(gv));
678 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
681 dump_sub_perl(gv, justperl);
684 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
685 const HV * const hv = GvHV(gv);
686 if (hv && (hv != PL_defstash))
687 dump_packsubs_perl(hv, justperl); /* nested package */
694 Perl_dump_sub(pTHX_ const GV *gv)
696 PERL_ARGS_ASSERT_DUMP_SUB;
697 dump_sub_perl(gv, FALSE);
701 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
705 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
707 cv = isGV_with_GP(gv) ? GvCV(gv) :
708 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
709 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
712 if (isGV_with_GP(gv)) {
713 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
714 SV *escsv = newSVpvs_flags("", SVs_TEMP);
717 gv_fullname3(namesv, gv, NULL);
718 namepv = SvPV_const(namesv, namelen);
719 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
720 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
722 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
725 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
727 (int)CvXSUBANY(cv).any_i32);
731 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
735 Perl_dump_form(pTHX_ const GV *gv)
737 SV * const sv = sv_newmortal();
739 PERL_ARGS_ASSERT_DUMP_FORM;
741 gv_fullname3(sv, gv, NULL);
742 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
743 if (CvROOT(GvFORM(gv)))
744 op_dump(CvROOT(GvFORM(gv)));
746 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
752 op_dump(PL_eval_root);
756 /* returns a temp SV displaying the name of a GV. Handles the case where
757 * a GV is in fact a ref to a CV */
760 S_gv_display(pTHX_ GV *gv)
762 SV * const name = newSVpvs_flags("", SVs_TEMP);
764 SV * const raw = newSVpvs_flags("", SVs_TEMP);
768 if (isGV_with_GP(gv))
769 gv_fullname3(raw, gv, NULL);
772 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
773 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
774 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
776 rawpv = SvPV_const(raw, len);
777 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
780 sv_catpvs(name, "(NULL)");
789 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
793 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
800 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
803 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
804 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
805 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
808 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
810 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
811 SV * const tmpsv = pm_description(pm);
812 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
813 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
814 SvREFCNT_dec_NN(tmpsv);
817 if (pm->op_type == OP_SPLIT)
818 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
819 "TARGOFF/GV = 0x%" UVxf "\n",
820 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
822 if (pm->op_pmreplrootu.op_pmreplroot) {
823 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
824 S_do_op_dump_bar(aTHX_ level + 2,
825 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
826 file, pm->op_pmreplrootu.op_pmreplroot);
830 if (pm->op_code_list) {
831 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
832 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
833 S_do_op_dump_bar(aTHX_ level + 2,
834 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
835 file, pm->op_code_list);
838 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
839 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
845 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
847 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
848 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
852 const struct flag_to_name pmflags_flags_names[] = {
853 {PMf_CONST, ",CONST"},
855 {PMf_GLOBAL, ",GLOBAL"},
856 {PMf_CONTINUE, ",CONTINUE"},
857 {PMf_RETAINT, ",RETAINT"},
859 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
860 {PMf_HAS_CV, ",HAS_CV"},
861 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
862 {PMf_IS_QR, ",IS_QR"}
866 S_pm_description(pTHX_ const PMOP *pm)
868 SV * const desc = newSVpvs("");
869 const REGEXP * const regex = PM_GETRE(pm);
870 const U32 pmflags = pm->op_pmflags;
872 PERL_ARGS_ASSERT_PM_DESCRIPTION;
874 if (pmflags & PMf_ONCE)
875 sv_catpv(desc, ",ONCE");
877 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
878 sv_catpv(desc, ":USED");
880 if (pmflags & PMf_USED)
881 sv_catpv(desc, ":USED");
885 if (RX_ISTAINTED(regex))
886 sv_catpv(desc, ",TAINTED");
887 if (RX_CHECK_SUBSTR(regex)) {
888 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
889 sv_catpv(desc, ",SCANFIRST");
890 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
891 sv_catpv(desc, ",ALL");
893 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
894 sv_catpv(desc, ",SKIPWHITE");
897 append_flags(desc, pmflags, pmflags_flags_names);
902 Perl_pmop_dump(pTHX_ PMOP *pm)
904 do_pmop_dump(0, Perl_debug_log, pm);
907 /* Return a unique integer to represent the address of op o.
908 * If it already exists in PL_op_sequence, just return it;
910 * *** Note that this isn't thread-safe */
913 S_sequence_num(pTHX_ const OP *o)
922 op = newSVuv(PTR2UV(o));
924 key = SvPV_const(op, len);
926 PL_op_sequence = newHV();
927 seq = hv_fetch(PL_op_sequence, key, len, 0);
930 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
938 const struct flag_to_name op_flags_names[] = {
940 {OPf_PARENS, ",PARENS"},
943 {OPf_STACKED, ",STACKED"},
944 {OPf_SPECIAL, ",SPECIAL"}
948 /* indexed by enum OPclass */
949 const char * const op_class_names[] = {
967 /* dump an op and any children. level indicates the initial indent.
968 * The bits of bar indicate which indents should receive a vertical bar.
969 * For example if level == 5 and bar == 0b01101, then the indent prefix
970 * emitted will be (not including the <>'s):
973 * 55554444333322221111
975 * For heavily nested output, the level may exceed the number of bits
976 * in bar; in this case the first few columns in the output will simply
977 * not have a bar, which is harmless.
981 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
983 const OPCODE optype = o->op_type;
985 PERL_ARGS_ASSERT_DO_OP_DUMP;
987 /* print op header line */
989 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
991 if (optype == OP_NULL && o->op_targ)
992 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
994 PerlIO_printf(file, " %s(0x%" UVxf ")",
995 op_class_names[op_class(o)], PTR2UV(o));
996 S_opdump_link(aTHX_ o->op_next, file);
998 /* print op common fields */
1000 if (o->op_targ && optype != OP_NULL)
1001 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1004 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1005 SV * const tmpsv = newSVpvs("");
1006 switch (o->op_flags & OPf_WANT) {
1008 sv_catpv(tmpsv, ",VOID");
1010 case OPf_WANT_SCALAR:
1011 sv_catpv(tmpsv, ",SCALAR");
1014 sv_catpv(tmpsv, ",LIST");
1017 sv_catpv(tmpsv, ",UNKNOWN");
1020 append_flags(tmpsv, o->op_flags, op_flags_names);
1021 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1022 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1023 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1024 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1025 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1026 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1027 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1030 if (o->op_private) {
1031 U16 oppriv = o->op_private;
1032 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1037 tmpsv = newSVpvs("");
1038 for (; !stop; op_ix++) {
1039 U16 entry = PL_op_private_bitdefs[op_ix];
1040 U16 bit = (entry >> 2) & 7;
1041 U16 ix = entry >> 5;
1047 I16 const *p = &PL_op_private_bitfields[ix];
1048 U16 bitmin = (U16) *p++;
1055 for (i = bitmin; i<= bit; i++)
1058 val = (oppriv & mask);
1061 && PL_op_private_labels[label] == '-'
1062 && PL_op_private_labels[label+1] == '\0'
1064 /* display as raw number */
1077 if (val == 0 && enum_label == -1)
1078 /* don't display anonymous zero values */
1081 sv_catpv(tmpsv, ",");
1083 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1084 sv_catpv(tmpsv, "=");
1086 if (enum_label == -1)
1087 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1089 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1094 if ( oppriv & (1<<bit)
1095 && !(PL_op_private_labels[ix] == '-'
1096 && PL_op_private_labels[ix+1] == '\0'))
1099 sv_catpv(tmpsv, ",");
1100 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1105 sv_catpv(tmpsv, ",");
1106 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1109 if (tmpsv && SvCUR(tmpsv)) {
1110 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1111 SvPVX_const(tmpsv) + 1);
1113 S_opdump_indent(aTHX_ o, level, bar, file,
1114 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1122 S_opdump_indent(aTHX_ o, level, bar, file,
1123 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1125 S_opdump_indent(aTHX_ o, level, bar, file,
1126 "GV = %" SVf " (0x%" UVxf ")\n",
1127 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1133 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1134 UV i, count = items[-1].uv;
1136 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1137 for (i=0; i < count; i++)
1138 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1139 "%" UVuf " => 0x%" UVxf "\n",
1144 case OP_MULTICONCAT:
1145 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" UVuf "\n",
1146 cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].uv);
1147 /* XXX really ought to dump each field individually,
1148 * but that's too much like hard work */
1149 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1150 SVfARG(multiconcat_stringify(o)));
1155 case OP_METHOD_NAMED:
1156 case OP_METHOD_SUPER:
1157 case OP_METHOD_REDIR:
1158 case OP_METHOD_REDIR_SUPER:
1159 #ifndef USE_ITHREADS
1160 /* with ITHREADS, consts are stored in the pad, and the right pad
1161 * may not be active here, so skip */
1162 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1163 SvPEEK(cMETHOPx_meth(o)));
1167 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1173 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1174 (UV)CopLINE(cCOPo));
1176 if (CopSTASHPV(cCOPo)) {
1177 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1178 HV *stash = CopSTASH(cCOPo);
1179 const char * const hvname = HvNAME_get(stash);
1181 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1182 generic_pv_escape(tmpsv, hvname,
1183 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1186 if (CopLABEL(cCOPo)) {
1187 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1190 const char *label = CopLABEL_len_flags(cCOPo,
1191 &label_len, &label_flags);
1192 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1193 generic_pv_escape( tmpsv, label, label_len,
1194 (label_flags & SVf_UTF8)));
1197 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1198 (unsigned int)cCOPo->cop_seq);
1203 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1204 S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
1205 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1206 S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
1207 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1208 S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
1228 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1229 S_opdump_link(aTHX_ cLOGOPo->op_other, file);
1235 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1243 if (o->op_private & OPpREFCOUNTED)
1244 S_opdump_indent(aTHX_ o, level, bar, file,
1245 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1253 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1256 SV * const label = newSVpvs_flags("", SVs_TEMP);
1257 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1258 S_opdump_indent(aTHX_ o, level, bar, file,
1259 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1260 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1266 S_opdump_indent(aTHX_ o, level, bar, file,
1267 "PV = 0x%" UVxf "\n",
1268 PTR2UV(cPVOPo->op_pv));
1275 if (o->op_flags & OPf_KIDS) {
1279 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1280 S_do_op_dump_bar(aTHX_ level,
1281 (bar | cBOOL(OpHAS_SIBLING(kid))),
1288 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1290 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1297 Dumps the optree starting at OP C<o> to C<STDERR>.
1303 Perl_op_dump(pTHX_ const OP *o)
1305 PERL_ARGS_ASSERT_OP_DUMP;
1306 do_op_dump(0, Perl_debug_log, o);
1310 Perl_gv_dump(pTHX_ GV *gv)
1314 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1317 PerlIO_printf(Perl_debug_log, "{}\n");
1320 sv = sv_newmortal();
1321 PerlIO_printf(Perl_debug_log, "{\n");
1322 gv_fullname3(sv, gv, NULL);
1323 name = SvPV_const(sv, len);
1324 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1325 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1326 if (gv != GvEGV(gv)) {
1327 gv_efullname3(sv, GvEGV(gv), NULL);
1328 name = SvPV_const(sv, len);
1329 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1330 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1332 (void)PerlIO_putc(Perl_debug_log, '\n');
1333 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1337 /* map magic types to the symbolic names
1338 * (with the PERL_MAGIC_ prefixed stripped)
1341 static const struct { const char type; const char *name; } magic_names[] = {
1342 #include "mg_names.inc"
1343 /* this null string terminates the list */
1348 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1350 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1352 for (; mg; mg = mg->mg_moremagic) {
1353 Perl_dump_indent(aTHX_ level, file,
1354 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1355 if (mg->mg_virtual) {
1356 const MGVTBL * const v = mg->mg_virtual;
1357 if (v >= PL_magic_vtables
1358 && v < PL_magic_vtables + magic_vtable_max) {
1359 const U32 i = v - PL_magic_vtables;
1360 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1363 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1364 UVxf "\n", PTR2UV(v));
1367 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1370 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1374 const char *name = NULL;
1375 for (n = 0; magic_names[n].name; n++) {
1376 if (mg->mg_type == magic_names[n].type) {
1377 name = magic_names[n].name;
1382 Perl_dump_indent(aTHX_ level, file,
1383 " MG_TYPE = PERL_MAGIC_%s\n", name);
1385 Perl_dump_indent(aTHX_ level, file,
1386 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1390 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1391 if (mg->mg_type == PERL_MAGIC_envelem &&
1392 mg->mg_flags & MGf_TAINTEDDIR)
1393 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1394 if (mg->mg_type == PERL_MAGIC_regex_global &&
1395 mg->mg_flags & MGf_MINMATCH)
1396 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1397 if (mg->mg_flags & MGf_REFCOUNTED)
1398 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1399 if (mg->mg_flags & MGf_GSKIP)
1400 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1401 if (mg->mg_flags & MGf_COPY)
1402 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1403 if (mg->mg_flags & MGf_DUP)
1404 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1405 if (mg->mg_flags & MGf_LOCAL)
1406 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1407 if (mg->mg_type == PERL_MAGIC_regex_global &&
1408 mg->mg_flags & MGf_BYTES)
1409 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1412 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1413 PTR2UV(mg->mg_obj));
1414 if (mg->mg_type == PERL_MAGIC_qr) {
1415 REGEXP* const re = (REGEXP *)mg->mg_obj;
1416 SV * const dsv = sv_newmortal();
1417 const char * const s
1418 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1420 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1421 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1423 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1424 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1427 if (mg->mg_flags & MGf_REFCOUNTED)
1428 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1431 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1433 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1434 if (mg->mg_len >= 0) {
1435 if (mg->mg_type != PERL_MAGIC_utf8) {
1436 SV * const sv = newSVpvs("");
1437 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1438 SvREFCNT_dec_NN(sv);
1441 else if (mg->mg_len == HEf_SVKEY) {
1442 PerlIO_puts(file, " => HEf_SVKEY\n");
1443 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1444 maxnest, dumpops, pvlim); /* MG is already +1 */
1447 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1452 " does not know how to handle this MG_LEN"
1454 (void)PerlIO_putc(file, '\n');
1456 if (mg->mg_type == PERL_MAGIC_utf8) {
1457 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1460 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1461 Perl_dump_indent(aTHX_ level, file,
1462 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1465 (UV)cache[i * 2 + 1]);
1472 Perl_magic_dump(pTHX_ const MAGIC *mg)
1474 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1478 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1482 PERL_ARGS_ASSERT_DO_HV_DUMP;
1484 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1485 if (sv && (hvname = HvNAME_get(sv)))
1487 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1488 name which quite legally could contain insane things like tabs, newlines, nulls or
1489 other scary crap - this should produce sane results - except maybe for unicode package
1490 names - but we will wait for someone to file a bug on that - demerphq */
1491 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1492 PerlIO_printf(file, "\t\"%s\"\n",
1493 generic_pv_escape( tmpsv, hvname,
1494 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1497 (void)PerlIO_putc(file, '\n');
1501 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1503 PERL_ARGS_ASSERT_DO_GV_DUMP;
1505 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1506 if (sv && GvNAME(sv)) {
1507 SV * const tmpsv = newSVpvs("");
1508 PerlIO_printf(file, "\t\"%s\"\n",
1509 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1512 (void)PerlIO_putc(file, '\n');
1516 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1518 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1520 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1521 if (sv && GvNAME(sv)) {
1522 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1524 HV * const stash = GvSTASH(sv);
1525 PerlIO_printf(file, "\t");
1526 /* TODO might have an extra \" here */
1527 if (stash && (hvname = HvNAME_get(stash))) {
1528 PerlIO_printf(file, "\"%s\" :: \"",
1529 generic_pv_escape(tmp, hvname,
1530 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1532 PerlIO_printf(file, "%s\"\n",
1533 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1536 (void)PerlIO_putc(file, '\n');
1539 const struct flag_to_name first_sv_flags_names[] = {
1540 {SVs_TEMP, "TEMP,"},
1541 {SVs_OBJECT, "OBJECT,"},
1550 const struct flag_to_name second_sv_flags_names[] = {
1552 {SVf_FAKE, "FAKE,"},
1553 {SVf_READONLY, "READONLY,"},
1554 {SVf_PROTECT, "PROTECT,"},
1555 {SVf_BREAK, "BREAK,"},
1561 const struct flag_to_name cv_flags_names[] = {
1562 {CVf_ANON, "ANON,"},
1563 {CVf_UNIQUE, "UNIQUE,"},
1564 {CVf_CLONE, "CLONE,"},
1565 {CVf_CLONED, "CLONED,"},
1566 {CVf_CONST, "CONST,"},
1567 {CVf_NODEBUG, "NODEBUG,"},
1568 {CVf_LVALUE, "LVALUE,"},
1569 {CVf_METHOD, "METHOD,"},
1570 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1571 {CVf_CVGV_RC, "CVGV_RC,"},
1572 {CVf_DYNFILE, "DYNFILE,"},
1573 {CVf_AUTOLOAD, "AUTOLOAD,"},
1574 {CVf_HASEVAL, "HASEVAL,"},
1575 {CVf_SLABBED, "SLABBED,"},
1576 {CVf_NAMED, "NAMED,"},
1577 {CVf_LEXICAL, "LEXICAL,"},
1578 {CVf_ISXSUB, "ISXSUB,"}
1581 const struct flag_to_name hv_flags_names[] = {
1582 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1583 {SVphv_LAZYDEL, "LAZYDEL,"},
1584 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1585 {SVf_AMAGIC, "OVERLOAD,"},
1586 {SVphv_CLONEABLE, "CLONEABLE,"}
1589 const struct flag_to_name gp_flags_names[] = {
1590 {GVf_INTRO, "INTRO,"},
1591 {GVf_MULTI, "MULTI,"},
1592 {GVf_ASSUMECV, "ASSUMECV,"},
1595 const struct flag_to_name gp_flags_imported_names[] = {
1596 {GVf_IMPORTED_SV, " SV"},
1597 {GVf_IMPORTED_AV, " AV"},
1598 {GVf_IMPORTED_HV, " HV"},
1599 {GVf_IMPORTED_CV, " CV"},
1602 /* NOTE: this structure is mostly duplicative of one generated by
1603 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1604 * the two. - Yves */
1605 const struct flag_to_name regexp_extflags_names[] = {
1606 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1607 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1608 {RXf_PMf_FOLD, "PMf_FOLD,"},
1609 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1610 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1611 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1612 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1613 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1614 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1615 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1616 {RXf_CHECK_ALL, "CHECK_ALL,"},
1617 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1618 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1619 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1620 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1621 {RXf_SPLIT, "SPLIT,"},
1622 {RXf_COPY_DONE, "COPY_DONE,"},
1623 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1624 {RXf_TAINTED, "TAINTED,"},
1625 {RXf_START_ONLY, "START_ONLY,"},
1626 {RXf_SKIPWHITE, "SKIPWHITE,"},
1627 {RXf_WHITE, "WHITE,"},
1628 {RXf_NULL, "NULL,"},
1631 /* NOTE: this structure is mostly duplicative of one generated by
1632 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1633 * the two. - Yves */
1634 const struct flag_to_name regexp_core_intflags_names[] = {
1635 {PREGf_SKIP, "SKIP,"},
1636 {PREGf_IMPLICIT, "IMPLICIT,"},
1637 {PREGf_NAUGHTY, "NAUGHTY,"},
1638 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1639 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1640 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1641 {PREGf_NOSCAN, "NOSCAN,"},
1642 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1643 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1644 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1645 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1646 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1649 /* Perl_do_sv_dump():
1651 * level: amount to indent the output
1652 * sv: the object to dump
1653 * nest: the current level of recursion
1654 * maxnest: the maximum allowed level of recursion
1655 * dumpops: if true, also dump the ops associated with a CV
1656 * pvlim: limit on the length of any strings that are output
1660 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1667 PERL_ARGS_ASSERT_DO_SV_DUMP;
1670 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1674 flags = SvFLAGS(sv);
1677 /* process general SV flags */
1679 d = Perl_newSVpvf(aTHX_
1680 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1681 PTR2UV(SvANY(sv)), PTR2UV(sv),
1682 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1683 (int)(PL_dumpindent*level), "");
1685 if ((flags & SVs_PADSTALE))
1686 sv_catpv(d, "PADSTALE,");
1687 if ((flags & SVs_PADTMP))
1688 sv_catpv(d, "PADTMP,");
1689 append_flags(d, flags, first_sv_flags_names);
1690 if (flags & SVf_ROK) {
1691 sv_catpv(d, "ROK,");
1692 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1694 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1695 append_flags(d, flags, second_sv_flags_names);
1696 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1697 && type != SVt_PVAV) {
1698 if (SvPCS_IMPORTED(sv))
1699 sv_catpv(d, "PCS_IMPORTED,");
1701 sv_catpv(d, "SCREAM,");
1704 /* process type-specific SV flags */
1709 append_flags(d, CvFLAGS(sv), cv_flags_names);
1712 append_flags(d, flags, hv_flags_names);
1716 if (isGV_with_GP(sv)) {
1717 append_flags(d, GvFLAGS(sv), gp_flags_names);
1719 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1720 sv_catpv(d, "IMPORT");
1721 if (GvIMPORTED(sv) == GVf_IMPORTED)
1722 sv_catpv(d, "ALL,");
1725 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1732 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1738 /* SVphv_SHAREKEYS is also 0x20000000 */
1739 if ((type != SVt_PVHV) && SvUTF8(sv))
1740 sv_catpv(d, "UTF8");
1742 if (*(SvEND(d) - 1) == ',') {
1743 SvCUR_set(d, SvCUR(d) - 1);
1744 SvPVX(d)[SvCUR(d)] = '\0';
1749 /* dump initial SV details */
1751 #ifdef DEBUG_LEAKING_SCALARS
1752 Perl_dump_indent(aTHX_ level, file,
1753 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1754 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1756 sv->sv_debug_inpad ? "for" : "by",
1757 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1758 PTR2UV(sv->sv_debug_parent),
1762 Perl_dump_indent(aTHX_ level, file, "SV = ");
1766 if (type < SVt_LAST) {
1767 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1769 if (type == SVt_NULL) {
1774 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1779 /* Dump general SV fields */
1781 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1782 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1783 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1784 || (type == SVt_IV && !SvROK(sv))) {
1787 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1789 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1790 (void)PerlIO_putc(file, '\n');
1793 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1794 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1795 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1796 || type == SVt_NV) {
1797 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1798 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1799 RESTORE_LC_NUMERIC_UNDERLYING();
1803 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1806 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1809 if (type < SVt_PV) {
1814 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1815 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1816 const bool re = isREGEXP(sv);
1817 const char * const ptr =
1818 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1822 SvOOK_offset(sv, delta);
1823 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1828 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1831 PerlIO_printf(file, "( %s . ) ",
1832 pv_display(d, ptr - delta, delta, 0,
1835 if (type == SVt_INVLIST) {
1836 PerlIO_printf(file, "\n");
1837 /* 4 blanks indents 2 beyond the PV, etc */
1838 _invlist_dump(file, level, " ", sv);
1841 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1844 if (SvUTF8(sv)) /* the 6? \x{....} */
1845 PerlIO_printf(file, " [UTF8 \"%s\"]",
1846 sv_uni_display(d, sv, 6 * SvCUR(sv),
1848 PerlIO_printf(file, "\n");
1850 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1851 if (re && type == SVt_PVLV)
1852 /* LV-as-REGEXP usurps len field to store pointer to
1854 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1855 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1857 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1859 #ifdef PERL_COPY_ON_WRITE
1860 if (SvIsCOW(sv) && SvLEN(sv))
1861 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1866 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1869 if (type >= SVt_PVMG) {
1871 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1873 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1875 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1876 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1881 /* Dump type-specific SV fields */
1885 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1886 PTR2UV(AvARRAY(sv)));
1887 if (AvARRAY(sv) != AvALLOC(sv)) {
1888 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1889 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1890 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1891 PTR2UV(AvALLOC(sv)));
1894 (void)PerlIO_putc(file, '\n');
1895 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1897 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1900 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1901 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1902 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1903 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1904 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1906 SV **svp = AvARRAY(MUTABLE_AV(sv));
1908 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1911 SV* const elt = *svp;
1912 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1914 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1921 struct xpvhv_aux *const aux = HvAUX(sv);
1922 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1923 (UV)aux->xhv_aux_flags);
1925 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1926 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1927 if (HvARRAY(sv) && usedkeys) {
1928 /* Show distribution of HEs in the ARRAY */
1930 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1933 U32 pow2 = 2, keys = usedkeys;
1934 NV theoret, sum = 0;
1936 PerlIO_printf(file, " (");
1937 Zero(freq, FREQ_MAX + 1, int);
1938 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1941 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1943 if (count > FREQ_MAX)
1949 for (i = 0; i <= max; i++) {
1951 PerlIO_printf(file, "%d%s:%d", i,
1952 (i == FREQ_MAX) ? "+" : "",
1955 PerlIO_printf(file, ", ");
1958 (void)PerlIO_putc(file, ')');
1959 /* The "quality" of a hash is defined as the total number of
1960 comparisons needed to access every element once, relative
1961 to the expected number needed for a random hash.
1963 The total number of comparisons is equal to the sum of
1964 the squares of the number of entries in each bucket.
1965 For a random hash of n keys into k buckets, the expected
1970 for (i = max; i > 0; i--) { /* Precision: count down. */
1971 sum += freq[i] * i * i;
1973 while ((keys = keys >> 1))
1976 theoret += theoret * (theoret-1)/pow2;
1977 (void)PerlIO_putc(file, '\n');
1978 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
1979 NVff "%%", theoret/sum*100);
1981 (void)PerlIO_putc(file, '\n');
1982 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
1986 HE **ents = HvARRAY(sv);
1989 HE *const *const last = ents + HvMAX(sv);
1990 count = last + 1 - ents;
1995 } while (++ents <= last);
1998 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2001 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2004 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2005 (IV)HvRITER_get(sv));
2006 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2007 PTR2UV(HvEITER_get(sv)));
2008 #ifdef PERL_HASH_RANDOMIZE_KEYS
2009 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2010 (UV)HvRAND_get(sv));
2011 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2012 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2013 (UV)HvLASTRAND_get(sv));
2016 (void)PerlIO_putc(file, '\n');
2019 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2020 if (mg && mg->mg_obj) {
2021 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2025 const char * const hvname = HvNAME_get(sv);
2027 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2028 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2029 generic_pv_escape( tmpsv, hvname,
2030 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2035 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2036 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2037 if (HvAUX(sv)->xhv_name_count)
2038 Perl_dump_indent(aTHX_
2039 level, file, " NAMECOUNT = %" IVdf "\n",
2040 (IV)HvAUX(sv)->xhv_name_count
2042 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2043 const I32 count = HvAUX(sv)->xhv_name_count;
2045 SV * const names = newSVpvs_flags("", SVs_TEMP);
2046 /* The starting point is the first element if count is
2047 positive and the second element if count is negative. */
2048 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2049 + (count < 0 ? 1 : 0);
2050 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2051 + (count < 0 ? -count : count);
2052 while (hekp < endp) {
2054 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2055 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2056 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2058 /* This should never happen. */
2059 sv_catpvs(names, ", (null)");
2063 Perl_dump_indent(aTHX_
2064 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2068 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2069 const char *const hvename = HvENAME_get(sv);
2070 Perl_dump_indent(aTHX_
2071 level, file, " ENAME = \"%s\"\n",
2072 generic_pv_escape(tmp, hvename,
2073 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2077 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2079 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2083 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2084 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2086 generic_pv_escape( tmpsv, meta->mro_which->name,
2087 meta->mro_which->length,
2088 (meta->mro_which->kflags & HVhek_UTF8)),
2089 PTR2UV(meta->mro_which));
2090 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2092 (UV)meta->cache_gen);
2093 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2095 if (meta->mro_linear_all) {
2096 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2098 PTR2UV(meta->mro_linear_all));
2099 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2102 if (meta->mro_linear_current) {
2103 Perl_dump_indent(aTHX_ level, file,
2104 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2105 PTR2UV(meta->mro_linear_current));
2106 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2109 if (meta->mro_nextmethod) {
2110 Perl_dump_indent(aTHX_ level, file,
2111 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2112 PTR2UV(meta->mro_nextmethod));
2113 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2117 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2119 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2124 if (nest < maxnest) {
2125 HV * const hv = MUTABLE_HV(sv);
2130 int count = maxnest - nest;
2131 for (i=0; i <= HvMAX(hv); i++) {
2132 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2139 if (count-- <= 0) goto DONEHV;
2142 keysv = hv_iterkeysv(he);
2143 keypv = SvPV_const(keysv, len);
2146 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2148 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2149 if (HvEITER_get(hv) == he)
2150 PerlIO_printf(file, "[CURRENT] ");
2151 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2152 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2159 } /* case SVt_PVHV */
2162 if (CvAUTOLOAD(sv)) {
2163 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2165 const char *const name = SvPV_const(sv, len);
2166 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2167 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2170 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2171 const char *const proto = CvPROTO(sv);
2172 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2173 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2178 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2179 if (!CvISXSUB(sv)) {
2182 Perl_dump_indent(aTHX_ level, file,
2183 " SLAB = 0x%" UVxf "\n",
2184 PTR2UV(CvSTART(sv)));
2186 Perl_dump_indent(aTHX_ level, file,
2187 " START = 0x%" UVxf " ===> %" IVdf "\n",
2188 PTR2UV(CvSTART(sv)),
2189 (IV)sequence_num(CvSTART(sv)));
2191 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2192 PTR2UV(CvROOT(sv)));
2193 if (CvROOT(sv) && dumpops) {
2194 do_op_dump(level+1, file, CvROOT(sv));
2197 SV * const constant = cv_const_sv((const CV *)sv);
2199 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2202 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2204 PTR2UV(CvXSUBANY(sv).any_ptr));
2205 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2208 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2209 (IV)CvXSUBANY(sv).any_i32);
2213 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2214 HEK_KEY(CvNAME_HEK((CV *)sv)));
2215 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2216 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2217 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2218 IVdf "\n", (IV)CvDEPTH(sv));
2219 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2221 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2222 if (!CvISXSUB(sv)) {
2223 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2224 if (nest < maxnest) {
2225 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2229 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2231 const CV * const outside = CvOUTSIDE(sv);
2232 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2235 : CvANON(outside) ? "ANON"
2236 : (outside == PL_main_cv) ? "MAIN"
2237 : CvUNIQUE(outside) ? "UNIQUE"
2240 newSVpvs_flags("", SVs_TEMP),
2241 GvNAME(CvGV(outside)),
2242 GvNAMELEN(CvGV(outside)),
2243 GvNAMEUTF8(CvGV(outside)))
2247 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2248 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2253 if (type == SVt_PVLV) {
2254 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2255 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2256 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2257 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2258 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2259 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2260 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2263 if (isREGEXP(sv)) goto dumpregexp;
2264 if (!isGV_with_GP(sv))
2267 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2268 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2269 generic_pv_escape(tmpsv, GvNAME(sv),
2273 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2274 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2275 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2276 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2279 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2280 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2281 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2282 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2283 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2284 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2285 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2286 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2287 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2291 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2292 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2293 do_gv_dump (level, file, " EGV", GvEGV(sv));
2296 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2297 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2298 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2299 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2300 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2301 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2302 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2304 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2305 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2306 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2308 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2309 PTR2UV(IoTOP_GV(sv)));
2310 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2311 maxnest, dumpops, pvlim);
2313 /* Source filters hide things that are not GVs in these three, so let's
2314 be careful out there. */
2316 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2317 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2318 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2320 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2321 PTR2UV(IoFMT_GV(sv)));
2322 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2323 maxnest, dumpops, pvlim);
2325 if (IoBOTTOM_NAME(sv))
2326 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2327 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2328 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2330 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2331 PTR2UV(IoBOTTOM_GV(sv)));
2332 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2333 maxnest, dumpops, pvlim);
2335 if (isPRINT(IoTYPE(sv)))
2336 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2338 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2339 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2344 struct regexp * const r = ReANY((REGEXP*)sv);
2346 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2348 append_flags(d, flags, names); \
2349 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2350 SvCUR_set(d, SvCUR(d) - 1); \
2351 SvPVX(d)[SvCUR(d)] = '\0'; \
2354 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2355 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2356 (UV)(r->compflags), SvPVX_const(d));
2358 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2359 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2360 (UV)(r->extflags), SvPVX_const(d));
2362 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2363 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2364 if (r->engine == &PL_core_reg_engine) {
2365 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2366 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2367 (UV)(r->intflags), SvPVX_const(d));
2369 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2372 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2373 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2375 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2376 (UV)(r->lastparen));
2377 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2378 (UV)(r->lastcloseparen));
2379 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2381 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2382 (IV)(r->minlenret));
2383 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2385 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2386 (UV)(r->pre_prefix));
2387 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2389 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2390 (IV)(r->suboffset));
2391 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2392 (IV)(r->subcoffset));
2394 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2396 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2398 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2399 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2400 PTR2UV(r->mother_re));
2401 if (nest < maxnest && r->mother_re)
2402 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2403 maxnest, dumpops, pvlim);
2404 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2405 PTR2UV(r->paren_names));
2406 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2407 PTR2UV(r->substrs));
2408 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2409 PTR2UV(r->pprivate));
2410 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2412 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2413 PTR2UV(r->qr_anoncv));
2415 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2416 PTR2UV(r->saved_copy));
2427 Dumps the contents of an SV to the C<STDERR> filehandle.
2429 For an example of its output, see L<Devel::Peek>.
2435 Perl_sv_dump(pTHX_ SV *sv)
2437 if (sv && SvROK(sv))
2438 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2440 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2444 Perl_runops_debug(pTHX)
2446 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2447 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2449 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2453 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2456 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2458 #ifdef PERL_TRACE_OPS
2459 ++PL_op_exec_cnt[PL_op->op_type];
2461 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2462 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2463 Perl_croak_nocontext(
2464 "panic: previous op failed to extend arg stack: "
2465 "base=%p, sp=%p, hwm=%p\n",
2466 PL_stack_base, PL_stack_sp,
2467 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2468 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2473 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2474 PerlIO_printf(Perl_debug_log,
2475 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2476 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2477 PTR2UV(*PL_watchaddr));
2478 if (DEBUG_s_TEST_) {
2479 if (DEBUG_v_TEST_) {
2480 PerlIO_printf(Perl_debug_log, "\n");
2488 if (DEBUG_t_TEST_) debop(PL_op);
2489 if (DEBUG_P_TEST_) debprof(PL_op);
2494 PERL_DTRACE_PROBE_OP(PL_op);
2495 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2496 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2499 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2500 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2501 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2508 /* print the names of the n lexical vars starting at pad offset off */
2511 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2514 CV * const cv = deb_curcv(cxstack_ix);
2515 PADNAMELIST *comppad = NULL;
2519 PADLIST * const padlist = CvPADLIST(cv);
2520 comppad = PadlistNAMES(padlist);
2523 PerlIO_printf(Perl_debug_log, "(");
2524 for (i = 0; i < n; i++) {
2525 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2526 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2528 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2531 PerlIO_printf(Perl_debug_log, ",");
2534 PerlIO_printf(Perl_debug_log, ")");
2538 /* append to the out SV, the name of the lexical at offset off in the CV
2542 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2543 bool paren, bool is_scalar)
2546 PADNAMELIST *namepad = NULL;
2550 PADLIST * const padlist = CvPADLIST(cv);
2551 namepad = PadlistNAMES(padlist);
2555 sv_catpvs_nomg(out, "(");
2556 for (i = 0; i < n; i++) {
2557 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2559 STRLEN cur = SvCUR(out);
2560 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2561 UTF8fARG(1, PadnameLEN(sv) - 1,
2562 PadnamePV(sv) + 1));
2564 SvPVX(out)[cur] = '$';
2567 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2569 sv_catpvs_nomg(out, ",");
2572 sv_catpvs_nomg(out, "(");
2577 S_append_gv_name(pTHX_ GV *gv, SV *out)
2581 sv_catpvs_nomg(out, "<NULLGV>");
2585 gv_fullname4(sv, gv, NULL, FALSE);
2586 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2587 SvREFCNT_dec_NN(sv);
2591 # define ITEM_SV(item) (comppad ? \
2592 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2594 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2598 /* return a temporary SV containing a stringified representation of
2599 * the op_aux field of a MULTIDEREF op, associated with CV cv
2603 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2605 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2606 UV actions = items->uv;
2609 bool is_hash = FALSE;
2611 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2616 PADLIST *padlist = CvPADLIST(cv);
2617 comppad = PadlistARRAY(padlist)[1];
2623 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2626 switch (actions & MDEREF_ACTION_MASK) {
2629 actions = (++items)->uv;
2631 NOT_REACHED; /* NOTREACHED */
2633 case MDEREF_HV_padhv_helem:
2636 case MDEREF_AV_padav_aelem:
2638 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2640 NOT_REACHED; /* NOTREACHED */
2642 case MDEREF_HV_gvhv_helem:
2645 case MDEREF_AV_gvav_aelem:
2648 sv = ITEM_SV(items);
2649 S_append_gv_name(aTHX_ (GV*)sv, out);
2651 NOT_REACHED; /* NOTREACHED */
2653 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2656 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2658 sv = ITEM_SV(items);
2659 S_append_gv_name(aTHX_ (GV*)sv, out);
2660 goto do_vivify_rv2xv_elem;
2661 NOT_REACHED; /* NOTREACHED */
2663 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2666 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2667 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2668 goto do_vivify_rv2xv_elem;
2669 NOT_REACHED; /* NOTREACHED */
2671 case MDEREF_HV_pop_rv2hv_helem:
2672 case MDEREF_HV_vivify_rv2hv_helem:
2675 do_vivify_rv2xv_elem:
2676 case MDEREF_AV_pop_rv2av_aelem:
2677 case MDEREF_AV_vivify_rv2av_aelem:
2679 sv_catpvs_nomg(out, "->");
2681 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2682 sv_catpvs_nomg(out, "->");
2687 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2688 switch (actions & MDEREF_INDEX_MASK) {
2689 case MDEREF_INDEX_const:
2692 sv = ITEM_SV(items);
2694 sv_catpvs_nomg(out, "???");
2699 pv_pretty(out, s, cur, 30,
2701 (PERL_PV_PRETTY_NOCLEAR
2702 |PERL_PV_PRETTY_QUOTE
2703 |PERL_PV_PRETTY_ELLIPSES));
2707 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2709 case MDEREF_INDEX_padsv:
2710 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2712 case MDEREF_INDEX_gvsv:
2714 sv = ITEM_SV(items);
2715 S_append_gv_name(aTHX_ (GV*)sv, out);
2718 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2720 if (actions & MDEREF_FLAG_last)
2727 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2728 (int)(actions & MDEREF_ACTION_MASK));
2734 actions >>= MDEREF_SHIFT;
2740 /* Return a temporary SV containing a stringified representation of
2741 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2742 * both plain and utf8 versions of the const string and indices, only
2743 * the first is displayed.
2747 Perl_multiconcat_stringify(pTHX_ const OP *o)
2749 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2750 UNOP_AUX_item *lens;
2754 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2756 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2758 nargs = aux[PERL_MULTICONCAT_IX_NARGS].uv;
2759 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2760 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].size;
2762 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2763 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].size;
2764 sv_catpvs(out, "UTF8 ");
2766 pv_pretty(out, s, len, 50,
2768 (PERL_PV_PRETTY_NOCLEAR
2769 |PERL_PV_PRETTY_QUOTE
2770 |PERL_PV_PRETTY_ELLIPSES));
2772 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2774 while (nargs-- > 0) {
2775 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->size);
2783 Perl_debop(pTHX_ const OP *o)
2785 PERL_ARGS_ASSERT_DEBOP;
2787 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2790 Perl_deb(aTHX_ "%s", OP_NAME(o));
2791 switch (o->op_type) {
2794 /* With ITHREADS, consts are stored in the pad, and the right pad
2795 * may not be active here, so check.
2796 * Looks like only during compiling the pads are illegal.
2799 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2801 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2805 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2806 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2813 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2817 S_deb_padvar(aTHX_ o->op_targ,
2818 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2822 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2823 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2826 case OP_MULTICONCAT:
2827 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2828 SVfARG(multiconcat_stringify(o)));
2834 PerlIO_printf(Perl_debug_log, "\n");
2840 =for apidoc op_class
2842 Given an op, determine what type of struct it has been allocated as.
2843 Returns one of the OPclass enums, such as OPclass_LISTOP.
2850 Perl_op_class(pTHX_ const OP *o)
2855 return OPclass_NULL;
2857 if (o->op_type == 0) {
2858 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2860 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2863 if (o->op_type == OP_SASSIGN)
2864 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2866 if (o->op_type == OP_AELEMFAST) {
2868 return OPclass_PADOP;
2870 return OPclass_SVOP;
2875 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2876 o->op_type == OP_RCATLINE)
2877 return OPclass_PADOP;
2880 if (o->op_type == OP_CUSTOM)
2883 switch (OP_CLASS(o)) {
2885 return OPclass_BASEOP;
2888 return OPclass_UNOP;
2891 return OPclass_BINOP;
2894 return OPclass_LOGOP;
2897 return OPclass_LISTOP;
2900 return OPclass_PMOP;
2903 return OPclass_SVOP;
2906 return OPclass_PADOP;
2908 case OA_PVOP_OR_SVOP:
2910 * Character translations (tr///) are usually a PVOP, keeping a
2911 * pointer to a table of shorts used to look up translations.
2912 * Under utf8, however, a simple table isn't practical; instead,
2913 * the OP is an SVOP (or, under threads, a PADOP),
2914 * and the SV is a reference to a swash
2915 * (i.e., an RV pointing to an HV).
2918 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2920 #if defined(USE_ITHREADS)
2921 ? OPclass_PADOP : OPclass_PVOP;
2923 ? OPclass_SVOP : OPclass_PVOP;
2927 return OPclass_LOOP;
2932 case OA_BASEOP_OR_UNOP:
2934 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2935 * whether parens were seen. perly.y uses OPf_SPECIAL to
2936 * signal whether a BASEOP had empty parens or none.
2937 * Some other UNOPs are created later, though, so the best
2938 * test is OPf_KIDS, which is set in newUNOP.
2940 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2944 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2945 * the OPf_REF flag to distinguish between OP types instead of the
2946 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2947 * return OPclass_UNOP so that walkoptree can find our children. If
2948 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2949 * (no argument to the operator) it's an OP; with OPf_REF set it's
2950 * an SVOP (and op_sv is the GV for the filehandle argument).
2952 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2954 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2956 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2960 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2961 * label was omitted (in which case it's a BASEOP) or else a term was
2962 * seen. In this last case, all except goto are definitely PVOP but
2963 * goto is either a PVOP (with an ordinary constant label), an UNOP
2964 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2965 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2968 if (o->op_flags & OPf_STACKED)
2969 return OPclass_UNOP;
2970 else if (o->op_flags & OPf_SPECIAL)
2971 return OPclass_BASEOP;
2973 return OPclass_PVOP;
2975 return OPclass_METHOP;
2977 return OPclass_UNOP_AUX;
2979 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2981 return OPclass_BASEOP;
2987 S_deb_curcv(pTHX_ I32 ix)
2989 PERL_SI *si = PL_curstackinfo;
2990 for (; ix >=0; ix--) {
2991 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2993 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2994 return cx->blk_sub.cv;
2995 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2996 return cx->blk_eval.cv;
2997 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2999 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3000 && si->si_type == PERLSI_SORT)
3002 /* fake sort sub; use CV of caller */
3004 ix = si->si_cxix + 1;
3011 Perl_watch(pTHX_ char **addr)
3013 PERL_ARGS_ASSERT_WATCH;
3015 PL_watchaddr = addr;
3017 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3018 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3022 S_debprof(pTHX_ const OP *o)
3024 PERL_ARGS_ASSERT_DEBPROF;
3026 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3028 if (!PL_profiledata)
3029 Newxz(PL_profiledata, MAXO, U32);
3030 ++PL_profiledata[o->op_type];
3034 Perl_debprofdump(pTHX)
3037 if (!PL_profiledata)
3039 for (i = 0; i < MAXO; i++) {
3040 if (PL_profiledata[i])
3041 PerlIO_printf(Perl_debug_log,
3042 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3049 * ex: set ts=8 sts=4 sw=4 et: