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 || sv == &PL_sv_placeholder) {
373 if (sv == &PL_sv_undef) {
374 sv_catpv(t, "SV_UNDEF");
375 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
376 SVs_GMG|SVs_SMG|SVs_RMG)) &&
380 else if (sv == &PL_sv_no) {
381 sv_catpv(t, "SV_NO");
382 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
383 SVs_GMG|SVs_SMG|SVs_RMG)) &&
384 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
390 else if (sv == &PL_sv_yes) {
391 sv_catpv(t, "SV_YES");
392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
393 SVs_GMG|SVs_SMG|SVs_RMG)) &&
394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
397 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
402 sv_catpv(t, "SV_PLACEHOLDER");
403 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
404 SVs_GMG|SVs_SMG|SVs_RMG)) &&
410 else if (SvREFCNT(sv) == 0) {
414 else if (DEBUG_R_TEST_) {
417 /* is this SV on the tmps stack? */
418 for (ix=PL_tmps_ix; ix>=0; ix--) {
419 if (PL_tmps_stack[ix] == sv) {
424 if (is_tmp || SvREFCNT(sv) > 1) {
425 Perl_sv_catpvf(aTHX_ t, "<");
426 if (SvREFCNT(sv) > 1)
427 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
429 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
430 Perl_sv_catpvf(aTHX_ t, ">");
436 if (SvCUR(t) + unref > 10) {
437 SvCUR_set(t, unref + 3);
446 if (type == SVt_PVCV) {
447 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
449 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
450 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
453 } else if (type < SVt_LAST) {
454 sv_catpv(t, svshorttypenames[type]);
456 if (type == SVt_NULL)
459 sv_catpv(t, "FREED");
464 if (!SvPVX_const(sv))
465 sv_catpv(t, "(null)");
467 SV * const tmp = newSVpvs("");
471 SvOOK_offset(sv, delta);
472 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
474 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
476 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
477 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
479 SvREFCNT_dec_NN(tmp);
482 else if (SvNOKp(sv)) {
483 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
484 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
485 RESTORE_LC_NUMERIC_UNDERLYING();
487 else if (SvIOKp(sv)) {
489 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
491 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
499 if (TAINTING_get && sv && SvTAINTED(sv))
500 sv_catpv(t, " [tainted]");
501 return SvPV_nolen(t);
505 =head1 Debugging Utilities
509 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
512 PERL_ARGS_ASSERT_DUMP_INDENT;
514 dump_vindent(level, file, pat, &args);
519 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
521 PERL_ARGS_ASSERT_DUMP_VINDENT;
522 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
523 PerlIO_vprintf(file, pat, *args);
527 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
528 * for each indent level as appropriate.
530 * bar contains bits indicating which indent columns should have a
531 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
532 * levels than bits in bar, then the first few indents are displayed
535 * The start of a new op is signalled by passing a value for level which
536 * has been negated and offset by 1 (so that level 0 is passed as -1 and
537 * can thus be distinguished from -0); in this case, emit a suitably
538 * indented blank line, then on the next line, display the op's sequence
539 * number, and make the final indent an '+----'.
543 * | FOO # level = 1, bar = 0b1
544 * | | # level =-2-1, bar = 0b11
546 * | BAZ # level = 2, bar = 0b10
550 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
551 const char* pat, ...)
555 bool newop = (level < 0);
559 /* start displaying a new op? */
561 UV seq = sequence_num(o);
565 /* output preceding blank line */
566 PerlIO_puts(file, " ");
567 for (i = level-1; i >= 0; i--)
568 PerlIO_puts(file, i == 0 || (bar & (1 << i)) ? "| " : " ");
569 PerlIO_puts(file, "\n");
571 /* output sequence number */
573 PerlIO_printf(file, "%-4" UVuf " ", seq);
575 PerlIO_puts(file, "???? ");
579 PerlIO_printf(file, " ");
581 for (i = level-1; i >= 0; i--)
583 (i == 0 && newop) ? "+--"
584 : (bar & (1 << i)) ? "| "
586 PerlIO_vprintf(file, pat, args);
591 /* display a link field (e.g. op_next) in the format
592 * ====> sequence_number [opname 0x123456]
596 S_opdump_link(pTHX_ const OP *o, PerlIO *file)
598 PerlIO_puts(file, " ===> ");
600 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
601 sequence_num(o), OP_NAME(o), PTR2UV(o));
603 PerlIO_puts(file, "[0x0]\n");
609 Dumps the entire optree of the current program starting at C<PL_main_root> to
610 C<STDERR>. Also dumps the optrees for all visible subroutines in
619 dump_all_perl(FALSE);
623 Perl_dump_all_perl(pTHX_ bool justperl)
625 PerlIO_setlinebuf(Perl_debug_log);
627 op_dump(PL_main_root);
628 dump_packsubs_perl(PL_defstash, justperl);
632 =for apidoc dump_packsubs
634 Dumps the optrees for all visible subroutines in C<stash>.
640 Perl_dump_packsubs(pTHX_ const HV *stash)
642 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
643 dump_packsubs_perl(stash, FALSE);
647 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
651 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
655 for (i = 0; i <= (I32) HvMAX(stash); i++) {
657 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
658 GV * gv = (GV *)HeVAL(entry);
659 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
660 /* unfake a fake GV */
661 (void)CvGV(SvRV(gv));
662 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
665 dump_sub_perl(gv, justperl);
668 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
669 const HV * const hv = GvHV(gv);
670 if (hv && (hv != PL_defstash))
671 dump_packsubs_perl(hv, justperl); /* nested package */
678 Perl_dump_sub(pTHX_ const GV *gv)
680 PERL_ARGS_ASSERT_DUMP_SUB;
681 dump_sub_perl(gv, FALSE);
685 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
689 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
691 cv = isGV_with_GP(gv) ? GvCV(gv) :
692 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
693 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
696 if (isGV_with_GP(gv)) {
697 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
698 SV *escsv = newSVpvs_flags("", SVs_TEMP);
701 gv_fullname3(namesv, gv, NULL);
702 namepv = SvPV_const(namesv, namelen);
703 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
704 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
706 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
709 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
711 (int)CvXSUBANY(cv).any_i32);
715 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
719 Perl_dump_form(pTHX_ const GV *gv)
721 SV * const sv = sv_newmortal();
723 PERL_ARGS_ASSERT_DUMP_FORM;
725 gv_fullname3(sv, gv, NULL);
726 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
727 if (CvROOT(GvFORM(gv)))
728 op_dump(CvROOT(GvFORM(gv)));
730 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
736 op_dump(PL_eval_root);
740 /* returns a temp SV displaying the name of a GV. Handles the case where
741 * a GV is in fact a ref to a CV */
744 S_gv_display(pTHX_ GV *gv)
746 SV * const name = newSVpvs_flags("", SVs_TEMP);
748 SV * const raw = newSVpvs_flags("", SVs_TEMP);
752 if (isGV_with_GP(gv))
753 gv_fullname3(raw, gv, NULL);
756 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
757 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
758 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
760 rawpv = SvPV_const(raw, len);
761 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
764 sv_catpvs(name, "(NULL)");
773 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
777 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
784 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
787 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
788 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
789 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
792 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
794 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
795 SV * const tmpsv = pm_description(pm);
796 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
797 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
798 SvREFCNT_dec_NN(tmpsv);
801 if (pm->op_type == OP_SPLIT)
802 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
803 "TARGOFF/GV = 0x%" UVxf "\n",
804 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
806 if (pm->op_pmreplrootu.op_pmreplroot) {
807 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
808 S_do_op_dump_bar(aTHX_ level + 2,
809 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
810 file, pm->op_pmreplrootu.op_pmreplroot);
814 if (pm->op_code_list) {
815 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
816 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
817 S_do_op_dump_bar(aTHX_ level + 2,
818 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
819 file, pm->op_code_list);
822 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
823 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
829 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
831 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
832 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
836 const struct flag_to_name pmflags_flags_names[] = {
837 {PMf_CONST, ",CONST"},
839 {PMf_GLOBAL, ",GLOBAL"},
840 {PMf_CONTINUE, ",CONTINUE"},
841 {PMf_RETAINT, ",RETAINT"},
843 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
844 {PMf_HAS_CV, ",HAS_CV"},
845 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
846 {PMf_IS_QR, ",IS_QR"}
850 S_pm_description(pTHX_ const PMOP *pm)
852 SV * const desc = newSVpvs("");
853 const REGEXP * const regex = PM_GETRE(pm);
854 const U32 pmflags = pm->op_pmflags;
856 PERL_ARGS_ASSERT_PM_DESCRIPTION;
858 if (pmflags & PMf_ONCE)
859 sv_catpv(desc, ",ONCE");
861 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
862 sv_catpv(desc, ":USED");
864 if (pmflags & PMf_USED)
865 sv_catpv(desc, ":USED");
869 if (RX_ISTAINTED(regex))
870 sv_catpv(desc, ",TAINTED");
871 if (RX_CHECK_SUBSTR(regex)) {
872 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
873 sv_catpv(desc, ",SCANFIRST");
874 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
875 sv_catpv(desc, ",ALL");
877 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
878 sv_catpv(desc, ",SKIPWHITE");
881 append_flags(desc, pmflags, pmflags_flags_names);
886 Perl_pmop_dump(pTHX_ PMOP *pm)
888 do_pmop_dump(0, Perl_debug_log, pm);
891 /* Return a unique integer to represent the address of op o.
892 * If it already exists in PL_op_sequence, just return it;
894 * *** Note that this isn't thread-safe */
897 S_sequence_num(pTHX_ const OP *o)
906 op = newSVuv(PTR2UV(o));
908 key = SvPV_const(op, len);
910 PL_op_sequence = newHV();
911 seq = hv_fetch(PL_op_sequence, key, len, 0);
914 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
922 const struct flag_to_name op_flags_names[] = {
924 {OPf_PARENS, ",PARENS"},
927 {OPf_STACKED, ",STACKED"},
928 {OPf_SPECIAL, ",SPECIAL"}
932 /* indexed by enum OPclass */
933 const char * const op_class_names[] = {
951 /* dump an op and any children. level indicates the initial indent.
952 * The bits of bar indicate which indents should receive a vertical bar.
953 * For example if level == 5 and bar == 0b01101, then the indent prefix
954 * emitted will be (not including the <>'s):
957 * 55554444333322221111
959 * For heavily nested output, the level may exceed the number of bits
960 * in bar; in this case the first few columns in the output will simply
961 * not have a bar, which is harmless.
965 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
967 const OPCODE optype = o->op_type;
969 PERL_ARGS_ASSERT_DO_OP_DUMP;
971 /* print op header line */
973 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
975 if (optype == OP_NULL && o->op_targ)
976 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
978 PerlIO_printf(file, " %s(0x%" UVxf ")",
979 op_class_names[op_class(o)], PTR2UV(o));
980 S_opdump_link(aTHX_ o->op_next, file);
982 /* print op common fields */
984 if (o->op_targ && optype != OP_NULL)
985 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
988 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
989 SV * const tmpsv = newSVpvs("");
990 switch (o->op_flags & OPf_WANT) {
992 sv_catpv(tmpsv, ",VOID");
994 case OPf_WANT_SCALAR:
995 sv_catpv(tmpsv, ",SCALAR");
998 sv_catpv(tmpsv, ",LIST");
1001 sv_catpv(tmpsv, ",UNKNOWN");
1004 append_flags(tmpsv, o->op_flags, op_flags_names);
1005 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1006 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1007 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1008 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
1009 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
1010 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1011 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1014 if (o->op_private) {
1015 U16 oppriv = o->op_private;
1016 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1021 tmpsv = newSVpvs("");
1022 for (; !stop; op_ix++) {
1023 U16 entry = PL_op_private_bitdefs[op_ix];
1024 U16 bit = (entry >> 2) & 7;
1025 U16 ix = entry >> 5;
1031 I16 const *p = &PL_op_private_bitfields[ix];
1032 U16 bitmin = (U16) *p++;
1039 for (i = bitmin; i<= bit; i++)
1042 val = (oppriv & mask);
1045 && PL_op_private_labels[label] == '-'
1046 && PL_op_private_labels[label+1] == '\0'
1048 /* display as raw number */
1061 if (val == 0 && enum_label == -1)
1062 /* don't display anonymous zero values */
1065 sv_catpv(tmpsv, ",");
1067 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1068 sv_catpv(tmpsv, "=");
1070 if (enum_label == -1)
1071 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1073 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1078 if ( oppriv & (1<<bit)
1079 && !(PL_op_private_labels[ix] == '-'
1080 && PL_op_private_labels[ix+1] == '\0'))
1083 sv_catpv(tmpsv, ",");
1084 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1089 sv_catpv(tmpsv, ",");
1090 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1093 if (tmpsv && SvCUR(tmpsv)) {
1094 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1095 SvPVX_const(tmpsv) + 1);
1097 S_opdump_indent(aTHX_ o, level, bar, file,
1098 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1106 S_opdump_indent(aTHX_ o, level, bar, file,
1107 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1109 S_opdump_indent(aTHX_ o, level, bar, file,
1110 "GV = %" SVf " (0x%" UVxf ")\n",
1111 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1117 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118 UV i, count = items[-1].uv;
1120 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1121 for (i=0; i < count; i++)
1122 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1123 "%" UVuf " => 0x%" UVxf "\n",
1130 case OP_METHOD_NAMED:
1131 case OP_METHOD_SUPER:
1132 case OP_METHOD_REDIR:
1133 case OP_METHOD_REDIR_SUPER:
1134 #ifndef USE_ITHREADS
1135 /* with ITHREADS, consts are stored in the pad, and the right pad
1136 * may not be active here, so skip */
1137 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1138 SvPEEK(cMETHOPx_meth(o)));
1142 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1148 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1149 (UV)CopLINE(cCOPo));
1151 if (CopSTASHPV(cCOPo)) {
1152 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1153 HV *stash = CopSTASH(cCOPo);
1154 const char * const hvname = HvNAME_get(stash);
1156 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1157 generic_pv_escape(tmpsv, hvname,
1158 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1161 if (CopLABEL(cCOPo)) {
1162 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1165 const char *label = CopLABEL_len_flags(cCOPo,
1166 &label_len, &label_flags);
1167 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1168 generic_pv_escape( tmpsv, label, label_len,
1169 (label_flags & SVf_UTF8)));
1172 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1173 (unsigned int)cCOPo->cop_seq);
1178 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1179 S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
1180 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1181 S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
1182 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1183 S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
1203 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1204 S_opdump_link(aTHX_ cLOGOPo->op_other, file);
1210 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1218 if (o->op_private & OPpREFCOUNTED)
1219 S_opdump_indent(aTHX_ o, level, bar, file,
1220 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1228 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1231 SV * const label = newSVpvs_flags("", SVs_TEMP);
1232 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1233 S_opdump_indent(aTHX_ o, level, bar, file,
1234 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1235 SVfARG(label), PTR2UV(cPVOPo->op_pv));
1241 S_opdump_indent(aTHX_ o, level, bar, file,
1242 "PV = 0x%" UVxf "\n",
1243 PTR2UV(cPVOPo->op_pv));
1250 if (o->op_flags & OPf_KIDS) {
1254 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1255 S_do_op_dump_bar(aTHX_ level,
1256 (bar | cBOOL(OpHAS_SIBLING(kid))),
1263 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1265 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1272 Dumps the optree starting at OP C<o> to C<STDERR>.
1278 Perl_op_dump(pTHX_ const OP *o)
1280 PERL_ARGS_ASSERT_OP_DUMP;
1281 do_op_dump(0, Perl_debug_log, o);
1285 Perl_gv_dump(pTHX_ GV *gv)
1289 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1292 PerlIO_printf(Perl_debug_log, "{}\n");
1295 sv = sv_newmortal();
1296 PerlIO_printf(Perl_debug_log, "{\n");
1297 gv_fullname3(sv, gv, NULL);
1298 name = SvPV_const(sv, len);
1299 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1300 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1301 if (gv != GvEGV(gv)) {
1302 gv_efullname3(sv, GvEGV(gv), NULL);
1303 name = SvPV_const(sv, len);
1304 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1305 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1307 (void)PerlIO_putc(Perl_debug_log, '\n');
1308 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1312 /* map magic types to the symbolic names
1313 * (with the PERL_MAGIC_ prefixed stripped)
1316 static const struct { const char type; const char *name; } magic_names[] = {
1317 #include "mg_names.inc"
1318 /* this null string terminates the list */
1323 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1325 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1327 for (; mg; mg = mg->mg_moremagic) {
1328 Perl_dump_indent(aTHX_ level, file,
1329 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1330 if (mg->mg_virtual) {
1331 const MGVTBL * const v = mg->mg_virtual;
1332 if (v >= PL_magic_vtables
1333 && v < PL_magic_vtables + magic_vtable_max) {
1334 const U32 i = v - PL_magic_vtables;
1335 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1338 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1339 UVxf "\n", PTR2UV(v));
1342 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1345 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1349 const char *name = NULL;
1350 for (n = 0; magic_names[n].name; n++) {
1351 if (mg->mg_type == magic_names[n].type) {
1352 name = magic_names[n].name;
1357 Perl_dump_indent(aTHX_ level, file,
1358 " MG_TYPE = PERL_MAGIC_%s\n", name);
1360 Perl_dump_indent(aTHX_ level, file,
1361 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1365 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1366 if (mg->mg_type == PERL_MAGIC_envelem &&
1367 mg->mg_flags & MGf_TAINTEDDIR)
1368 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1369 if (mg->mg_type == PERL_MAGIC_regex_global &&
1370 mg->mg_flags & MGf_MINMATCH)
1371 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1372 if (mg->mg_flags & MGf_REFCOUNTED)
1373 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1374 if (mg->mg_flags & MGf_GSKIP)
1375 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1376 if (mg->mg_flags & MGf_COPY)
1377 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1378 if (mg->mg_flags & MGf_DUP)
1379 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1380 if (mg->mg_flags & MGf_LOCAL)
1381 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1382 if (mg->mg_type == PERL_MAGIC_regex_global &&
1383 mg->mg_flags & MGf_BYTES)
1384 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1387 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1388 PTR2UV(mg->mg_obj));
1389 if (mg->mg_type == PERL_MAGIC_qr) {
1390 REGEXP* const re = (REGEXP *)mg->mg_obj;
1391 SV * const dsv = sv_newmortal();
1392 const char * const s
1393 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1395 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1396 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1398 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1399 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1402 if (mg->mg_flags & MGf_REFCOUNTED)
1403 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1406 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1408 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1409 if (mg->mg_len >= 0) {
1410 if (mg->mg_type != PERL_MAGIC_utf8) {
1411 SV * const sv = newSVpvs("");
1412 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1413 SvREFCNT_dec_NN(sv);
1416 else if (mg->mg_len == HEf_SVKEY) {
1417 PerlIO_puts(file, " => HEf_SVKEY\n");
1418 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1419 maxnest, dumpops, pvlim); /* MG is already +1 */
1422 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1427 " does not know how to handle this MG_LEN"
1429 (void)PerlIO_putc(file, '\n');
1431 if (mg->mg_type == PERL_MAGIC_utf8) {
1432 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1435 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1436 Perl_dump_indent(aTHX_ level, file,
1437 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1440 (UV)cache[i * 2 + 1]);
1447 Perl_magic_dump(pTHX_ const MAGIC *mg)
1449 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1453 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1457 PERL_ARGS_ASSERT_DO_HV_DUMP;
1459 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1460 if (sv && (hvname = HvNAME_get(sv)))
1462 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1463 name which quite legally could contain insane things like tabs, newlines, nulls or
1464 other scary crap - this should produce sane results - except maybe for unicode package
1465 names - but we will wait for someone to file a bug on that - demerphq */
1466 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1467 PerlIO_printf(file, "\t\"%s\"\n",
1468 generic_pv_escape( tmpsv, hvname,
1469 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1472 (void)PerlIO_putc(file, '\n');
1476 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1478 PERL_ARGS_ASSERT_DO_GV_DUMP;
1480 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1481 if (sv && GvNAME(sv)) {
1482 SV * const tmpsv = newSVpvs("");
1483 PerlIO_printf(file, "\t\"%s\"\n",
1484 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1487 (void)PerlIO_putc(file, '\n');
1491 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1493 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1495 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1496 if (sv && GvNAME(sv)) {
1497 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1499 HV * const stash = GvSTASH(sv);
1500 PerlIO_printf(file, "\t");
1501 /* TODO might have an extra \" here */
1502 if (stash && (hvname = HvNAME_get(stash))) {
1503 PerlIO_printf(file, "\"%s\" :: \"",
1504 generic_pv_escape(tmp, hvname,
1505 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1507 PerlIO_printf(file, "%s\"\n",
1508 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1511 (void)PerlIO_putc(file, '\n');
1514 const struct flag_to_name first_sv_flags_names[] = {
1515 {SVs_TEMP, "TEMP,"},
1516 {SVs_OBJECT, "OBJECT,"},
1525 const struct flag_to_name second_sv_flags_names[] = {
1527 {SVf_FAKE, "FAKE,"},
1528 {SVf_READONLY, "READONLY,"},
1529 {SVf_PROTECT, "PROTECT,"},
1530 {SVf_BREAK, "BREAK,"},
1536 const struct flag_to_name cv_flags_names[] = {
1537 {CVf_ANON, "ANON,"},
1538 {CVf_UNIQUE, "UNIQUE,"},
1539 {CVf_CLONE, "CLONE,"},
1540 {CVf_CLONED, "CLONED,"},
1541 {CVf_CONST, "CONST,"},
1542 {CVf_NODEBUG, "NODEBUG,"},
1543 {CVf_LVALUE, "LVALUE,"},
1544 {CVf_METHOD, "METHOD,"},
1545 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1546 {CVf_CVGV_RC, "CVGV_RC,"},
1547 {CVf_DYNFILE, "DYNFILE,"},
1548 {CVf_AUTOLOAD, "AUTOLOAD,"},
1549 {CVf_HASEVAL, "HASEVAL,"},
1550 {CVf_SLABBED, "SLABBED,"},
1551 {CVf_NAMED, "NAMED,"},
1552 {CVf_LEXICAL, "LEXICAL,"},
1553 {CVf_ISXSUB, "ISXSUB,"}
1556 const struct flag_to_name hv_flags_names[] = {
1557 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1558 {SVphv_LAZYDEL, "LAZYDEL,"},
1559 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1560 {SVf_AMAGIC, "OVERLOAD,"},
1561 {SVphv_CLONEABLE, "CLONEABLE,"}
1564 const struct flag_to_name gp_flags_names[] = {
1565 {GVf_INTRO, "INTRO,"},
1566 {GVf_MULTI, "MULTI,"},
1567 {GVf_ASSUMECV, "ASSUMECV,"},
1570 const struct flag_to_name gp_flags_imported_names[] = {
1571 {GVf_IMPORTED_SV, " SV"},
1572 {GVf_IMPORTED_AV, " AV"},
1573 {GVf_IMPORTED_HV, " HV"},
1574 {GVf_IMPORTED_CV, " CV"},
1577 /* NOTE: this structure is mostly duplicative of one generated by
1578 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1579 * the two. - Yves */
1580 const struct flag_to_name regexp_extflags_names[] = {
1581 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1582 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1583 {RXf_PMf_FOLD, "PMf_FOLD,"},
1584 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1585 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1586 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1587 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1588 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1589 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1590 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1591 {RXf_CHECK_ALL, "CHECK_ALL,"},
1592 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1593 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1594 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1595 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1596 {RXf_SPLIT, "SPLIT,"},
1597 {RXf_COPY_DONE, "COPY_DONE,"},
1598 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1599 {RXf_TAINTED, "TAINTED,"},
1600 {RXf_START_ONLY, "START_ONLY,"},
1601 {RXf_SKIPWHITE, "SKIPWHITE,"},
1602 {RXf_WHITE, "WHITE,"},
1603 {RXf_NULL, "NULL,"},
1606 /* NOTE: this structure is mostly duplicative of one generated by
1607 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1608 * the two. - Yves */
1609 const struct flag_to_name regexp_core_intflags_names[] = {
1610 {PREGf_SKIP, "SKIP,"},
1611 {PREGf_IMPLICIT, "IMPLICIT,"},
1612 {PREGf_NAUGHTY, "NAUGHTY,"},
1613 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1614 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1615 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1616 {PREGf_NOSCAN, "NOSCAN,"},
1617 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1618 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1619 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1620 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1621 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1624 /* Perl_do_sv_dump():
1626 * level: amount to indent the output
1627 * sv: the object to dump
1628 * nest: the current level of recursion
1629 * maxnest: the maximum allowed level of recursion
1630 * dumpops: if true, also dump the ops associated with a CV
1631 * pvlim: limit on the length of any strings that are output
1635 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1642 PERL_ARGS_ASSERT_DO_SV_DUMP;
1645 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1649 flags = SvFLAGS(sv);
1652 /* process general SV flags */
1654 d = Perl_newSVpvf(aTHX_
1655 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1656 PTR2UV(SvANY(sv)), PTR2UV(sv),
1657 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1658 (int)(PL_dumpindent*level), "");
1660 if ((flags & SVs_PADSTALE))
1661 sv_catpv(d, "PADSTALE,");
1662 if ((flags & SVs_PADTMP))
1663 sv_catpv(d, "PADTMP,");
1664 append_flags(d, flags, first_sv_flags_names);
1665 if (flags & SVf_ROK) {
1666 sv_catpv(d, "ROK,");
1667 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1669 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1670 append_flags(d, flags, second_sv_flags_names);
1671 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1672 && type != SVt_PVAV) {
1673 if (SvPCS_IMPORTED(sv))
1674 sv_catpv(d, "PCS_IMPORTED,");
1676 sv_catpv(d, "SCREAM,");
1679 /* process type-specific SV flags */
1684 append_flags(d, CvFLAGS(sv), cv_flags_names);
1687 append_flags(d, flags, hv_flags_names);
1691 if (isGV_with_GP(sv)) {
1692 append_flags(d, GvFLAGS(sv), gp_flags_names);
1694 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1695 sv_catpv(d, "IMPORT");
1696 if (GvIMPORTED(sv) == GVf_IMPORTED)
1697 sv_catpv(d, "ALL,");
1700 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1707 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1713 /* SVphv_SHAREKEYS is also 0x20000000 */
1714 if ((type != SVt_PVHV) && SvUTF8(sv))
1715 sv_catpv(d, "UTF8");
1717 if (*(SvEND(d) - 1) == ',') {
1718 SvCUR_set(d, SvCUR(d) - 1);
1719 SvPVX(d)[SvCUR(d)] = '\0';
1724 /* dump initial SV details */
1726 #ifdef DEBUG_LEAKING_SCALARS
1727 Perl_dump_indent(aTHX_ level, file,
1728 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1729 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1731 sv->sv_debug_inpad ? "for" : "by",
1732 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1733 PTR2UV(sv->sv_debug_parent),
1737 Perl_dump_indent(aTHX_ level, file, "SV = ");
1741 if (type < SVt_LAST) {
1742 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1744 if (type == SVt_NULL) {
1749 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1754 /* Dump general SV fields */
1756 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1757 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1758 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1759 || (type == SVt_IV && !SvROK(sv))) {
1762 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1764 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1765 (void)PerlIO_putc(file, '\n');
1768 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1769 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1770 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1771 || type == SVt_NV) {
1772 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1773 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1774 RESTORE_LC_NUMERIC_UNDERLYING();
1778 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1781 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1784 if (type < SVt_PV) {
1789 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1790 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1791 const bool re = isREGEXP(sv);
1792 const char * const ptr =
1793 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1797 SvOOK_offset(sv, delta);
1798 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1803 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1806 PerlIO_printf(file, "( %s . ) ",
1807 pv_display(d, ptr - delta, delta, 0,
1810 if (type == SVt_INVLIST) {
1811 PerlIO_printf(file, "\n");
1812 /* 4 blanks indents 2 beyond the PV, etc */
1813 _invlist_dump(file, level, " ", sv);
1816 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1819 if (SvUTF8(sv)) /* the 6? \x{....} */
1820 PerlIO_printf(file, " [UTF8 \"%s\"]",
1821 sv_uni_display(d, sv, 6 * SvCUR(sv),
1823 PerlIO_printf(file, "\n");
1825 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1827 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1829 #ifdef PERL_COPY_ON_WRITE
1830 if (SvIsCOW(sv) && SvLEN(sv))
1831 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1836 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1839 if (type >= SVt_PVMG) {
1841 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1843 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1845 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1846 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1851 /* Dump type-specific SV fields */
1855 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1856 PTR2UV(AvARRAY(sv)));
1857 if (AvARRAY(sv) != AvALLOC(sv)) {
1858 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1859 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1860 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1861 PTR2UV(AvALLOC(sv)));
1864 (void)PerlIO_putc(file, '\n');
1865 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1867 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1870 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1871 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1872 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1873 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1874 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1876 SV **svp = AvARRAY(MUTABLE_AV(sv));
1878 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1881 SV* const elt = *svp;
1882 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1884 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1891 struct xpvhv_aux *const aux = HvAUX(sv);
1892 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
1893 (UV)aux->xhv_aux_flags);
1895 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1896 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1897 if (HvARRAY(sv) && usedkeys) {
1898 /* Show distribution of HEs in the ARRAY */
1900 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1903 U32 pow2 = 2, keys = usedkeys;
1904 NV theoret, sum = 0;
1906 PerlIO_printf(file, " (");
1907 Zero(freq, FREQ_MAX + 1, int);
1908 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1911 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1913 if (count > FREQ_MAX)
1919 for (i = 0; i <= max; i++) {
1921 PerlIO_printf(file, "%d%s:%d", i,
1922 (i == FREQ_MAX) ? "+" : "",
1925 PerlIO_printf(file, ", ");
1928 (void)PerlIO_putc(file, ')');
1929 /* The "quality" of a hash is defined as the total number of
1930 comparisons needed to access every element once, relative
1931 to the expected number needed for a random hash.
1933 The total number of comparisons is equal to the sum of
1934 the squares of the number of entries in each bucket.
1935 For a random hash of n keys into k buckets, the expected
1940 for (i = max; i > 0; i--) { /* Precision: count down. */
1941 sum += freq[i] * i * i;
1943 while ((keys = keys >> 1))
1946 theoret += theoret * (theoret-1)/pow2;
1947 (void)PerlIO_putc(file, '\n');
1948 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
1949 NVff "%%", theoret/sum*100);
1951 (void)PerlIO_putc(file, '\n');
1952 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
1956 HE **ents = HvARRAY(sv);
1959 HE *const *const last = ents + HvMAX(sv);
1960 count = last + 1 - ents;
1965 } while (++ents <= last);
1968 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
1971 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1974 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
1975 (IV)HvRITER_get(sv));
1976 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
1977 PTR2UV(HvEITER_get(sv)));
1978 #ifdef PERL_HASH_RANDOMIZE_KEYS
1979 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
1980 (UV)HvRAND_get(sv));
1981 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1982 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1983 (UV)HvLASTRAND_get(sv));
1986 (void)PerlIO_putc(file, '\n');
1989 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1990 if (mg && mg->mg_obj) {
1991 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
1995 const char * const hvname = HvNAME_get(sv);
1997 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1998 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1999 generic_pv_escape( tmpsv, hvname,
2000 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2005 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2006 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2007 if (HvAUX(sv)->xhv_name_count)
2008 Perl_dump_indent(aTHX_
2009 level, file, " NAMECOUNT = %" IVdf "\n",
2010 (IV)HvAUX(sv)->xhv_name_count
2012 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2013 const I32 count = HvAUX(sv)->xhv_name_count;
2015 SV * const names = newSVpvs_flags("", SVs_TEMP);
2016 /* The starting point is the first element if count is
2017 positive and the second element if count is negative. */
2018 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2019 + (count < 0 ? 1 : 0);
2020 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2021 + (count < 0 ? -count : count);
2022 while (hekp < endp) {
2024 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2025 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2026 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2028 /* This should never happen. */
2029 sv_catpvs(names, ", (null)");
2033 Perl_dump_indent(aTHX_
2034 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2038 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2039 const char *const hvename = HvENAME_get(sv);
2040 Perl_dump_indent(aTHX_
2041 level, file, " ENAME = \"%s\"\n",
2042 generic_pv_escape(tmp, hvename,
2043 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2047 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2049 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2053 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2054 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2056 generic_pv_escape( tmpsv, meta->mro_which->name,
2057 meta->mro_which->length,
2058 (meta->mro_which->kflags & HVhek_UTF8)),
2059 PTR2UV(meta->mro_which));
2060 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2062 (UV)meta->cache_gen);
2063 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2065 if (meta->mro_linear_all) {
2066 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2068 PTR2UV(meta->mro_linear_all));
2069 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2072 if (meta->mro_linear_current) {
2073 Perl_dump_indent(aTHX_ level, file,
2074 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2075 PTR2UV(meta->mro_linear_current));
2076 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2079 if (meta->mro_nextmethod) {
2080 Perl_dump_indent(aTHX_ level, file,
2081 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2082 PTR2UV(meta->mro_nextmethod));
2083 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2087 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2089 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2094 if (nest < maxnest) {
2095 HV * const hv = MUTABLE_HV(sv);
2100 int count = maxnest - nest;
2101 for (i=0; i <= HvMAX(hv); i++) {
2102 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2109 if (count-- <= 0) goto DONEHV;
2112 keysv = hv_iterkeysv(he);
2113 keypv = SvPV_const(keysv, len);
2116 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2118 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2119 if (HvEITER_get(hv) == he)
2120 PerlIO_printf(file, "[CURRENT] ");
2121 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2122 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2129 } /* case SVt_PVHV */
2132 if (CvAUTOLOAD(sv)) {
2133 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2135 const char *const name = SvPV_const(sv, len);
2136 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2137 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2140 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2141 const char *const proto = CvPROTO(sv);
2142 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2143 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2148 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2149 if (!CvISXSUB(sv)) {
2152 Perl_dump_indent(aTHX_ level, file,
2153 " SLAB = 0x%" UVxf "\n",
2154 PTR2UV(CvSTART(sv)));
2156 Perl_dump_indent(aTHX_ level, file,
2157 " START = 0x%" UVxf " ===> %" IVdf "\n",
2158 PTR2UV(CvSTART(sv)),
2159 (IV)sequence_num(CvSTART(sv)));
2161 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2162 PTR2UV(CvROOT(sv)));
2163 if (CvROOT(sv) && dumpops) {
2164 do_op_dump(level+1, file, CvROOT(sv));
2167 SV * const constant = cv_const_sv((const CV *)sv);
2169 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2172 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2174 PTR2UV(CvXSUBANY(sv).any_ptr));
2175 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2178 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2179 (IV)CvXSUBANY(sv).any_i32);
2183 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2184 HEK_KEY(CvNAME_HEK((CV *)sv)));
2185 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2186 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2187 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2188 IVdf "\n", (IV)CvDEPTH(sv));
2189 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2191 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2192 if (!CvISXSUB(sv)) {
2193 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2194 if (nest < maxnest) {
2195 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2199 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2201 const CV * const outside = CvOUTSIDE(sv);
2202 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2205 : CvANON(outside) ? "ANON"
2206 : (outside == PL_main_cv) ? "MAIN"
2207 : CvUNIQUE(outside) ? "UNIQUE"
2210 newSVpvs_flags("", SVs_TEMP),
2211 GvNAME(CvGV(outside)),
2212 GvNAMELEN(CvGV(outside)),
2213 GvNAMEUTF8(CvGV(outside)))
2217 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2218 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2223 if (type == SVt_PVLV) {
2224 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2225 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2226 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2227 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2228 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2229 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2230 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2233 if (isREGEXP(sv)) goto dumpregexp;
2234 if (!isGV_with_GP(sv))
2237 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2238 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2239 generic_pv_escape(tmpsv, GvNAME(sv),
2243 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2244 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2245 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2246 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2249 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2250 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2251 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2252 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2253 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2254 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2255 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2256 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2257 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2261 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2262 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2263 do_gv_dump (level, file, " EGV", GvEGV(sv));
2266 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2267 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2268 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2269 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2270 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2271 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2272 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2274 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2275 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2276 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2278 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2279 PTR2UV(IoTOP_GV(sv)));
2280 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2281 maxnest, dumpops, pvlim);
2283 /* Source filters hide things that are not GVs in these three, so let's
2284 be careful out there. */
2286 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2287 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2288 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2290 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2291 PTR2UV(IoFMT_GV(sv)));
2292 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2293 maxnest, dumpops, pvlim);
2295 if (IoBOTTOM_NAME(sv))
2296 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2297 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2298 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2300 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2301 PTR2UV(IoBOTTOM_GV(sv)));
2302 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2303 maxnest, dumpops, pvlim);
2305 if (isPRINT(IoTYPE(sv)))
2306 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2308 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2309 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2314 struct regexp * const r = ReANY((REGEXP*)sv);
2316 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2318 append_flags(d, flags, names); \
2319 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2320 SvCUR_set(d, SvCUR(d) - 1); \
2321 SvPVX(d)[SvCUR(d)] = '\0'; \
2324 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2325 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2326 (UV)(r->compflags), SvPVX_const(d));
2328 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2329 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2330 (UV)(r->extflags), SvPVX_const(d));
2332 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2333 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2334 if (r->engine == &PL_core_reg_engine) {
2335 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2336 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2337 (UV)(r->intflags), SvPVX_const(d));
2339 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
2342 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2343 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2345 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2346 (UV)(r->lastparen));
2347 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2348 (UV)(r->lastcloseparen));
2349 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2351 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2352 (IV)(r->minlenret));
2353 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2355 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2356 (UV)(r->pre_prefix));
2357 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2359 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2360 (IV)(r->suboffset));
2361 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2362 (IV)(r->subcoffset));
2364 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2366 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2368 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2369 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2370 PTR2UV(r->mother_re));
2371 if (nest < maxnest && r->mother_re)
2372 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2373 maxnest, dumpops, pvlim);
2374 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2375 PTR2UV(r->paren_names));
2376 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2377 PTR2UV(r->substrs));
2378 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2379 PTR2UV(r->pprivate));
2380 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2382 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2383 PTR2UV(r->qr_anoncv));
2385 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2386 PTR2UV(r->saved_copy));
2397 Dumps the contents of an SV to the C<STDERR> filehandle.
2399 For an example of its output, see L<Devel::Peek>.
2405 Perl_sv_dump(pTHX_ SV *sv)
2407 if (sv && SvROK(sv))
2408 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2410 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2414 Perl_runops_debug(pTHX)
2416 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2417 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2419 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2423 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2426 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2428 #ifdef PERL_TRACE_OPS
2429 ++PL_op_exec_cnt[PL_op->op_type];
2431 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2432 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2433 Perl_croak_nocontext(
2434 "panic: previous op failed to extend arg stack: "
2435 "base=%p, sp=%p, hwm=%p\n",
2436 PL_stack_base, PL_stack_sp,
2437 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2438 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2443 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2444 PerlIO_printf(Perl_debug_log,
2445 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2446 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2447 PTR2UV(*PL_watchaddr));
2448 if (DEBUG_s_TEST_) {
2449 if (DEBUG_v_TEST_) {
2450 PerlIO_printf(Perl_debug_log, "\n");
2458 if (DEBUG_t_TEST_) debop(PL_op);
2459 if (DEBUG_P_TEST_) debprof(PL_op);
2464 PERL_DTRACE_PROBE_OP(PL_op);
2465 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2466 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2469 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2470 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2477 /* print the names of the n lexical vars starting at pad offset off */
2480 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2483 CV * const cv = deb_curcv(cxstack_ix);
2484 PADNAMELIST *comppad = NULL;
2488 PADLIST * const padlist = CvPADLIST(cv);
2489 comppad = PadlistNAMES(padlist);
2492 PerlIO_printf(Perl_debug_log, "(");
2493 for (i = 0; i < n; i++) {
2494 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2495 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2497 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2500 PerlIO_printf(Perl_debug_log, ",");
2503 PerlIO_printf(Perl_debug_log, ")");
2507 /* append to the out SV, the name of the lexical at offset off in the CV
2511 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2512 bool paren, bool is_scalar)
2515 PADNAMELIST *namepad = NULL;
2519 PADLIST * const padlist = CvPADLIST(cv);
2520 namepad = PadlistNAMES(padlist);
2524 sv_catpvs_nomg(out, "(");
2525 for (i = 0; i < n; i++) {
2526 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2528 STRLEN cur = SvCUR(out);
2529 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2530 UTF8fARG(1, PadnameLEN(sv) - 1,
2531 PadnamePV(sv) + 1));
2533 SvPVX(out)[cur] = '$';
2536 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2538 sv_catpvs_nomg(out, ",");
2541 sv_catpvs_nomg(out, "(");
2546 S_append_gv_name(pTHX_ GV *gv, SV *out)
2550 sv_catpvs_nomg(out, "<NULLGV>");
2554 gv_fullname4(sv, gv, NULL, FALSE);
2555 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2556 SvREFCNT_dec_NN(sv);
2560 # define ITEM_SV(item) (comppad ? \
2561 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2563 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2567 /* return a temporary SV containing a stringified representation of
2568 * the op_aux field of a MULTIDEREF op, associated with CV cv
2572 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2574 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2575 UV actions = items->uv;
2578 bool is_hash = FALSE;
2580 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2585 PADLIST *padlist = CvPADLIST(cv);
2586 comppad = PadlistARRAY(padlist)[1];
2592 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2595 switch (actions & MDEREF_ACTION_MASK) {
2598 actions = (++items)->uv;
2600 NOT_REACHED; /* NOTREACHED */
2602 case MDEREF_HV_padhv_helem:
2605 case MDEREF_AV_padav_aelem:
2607 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2609 NOT_REACHED; /* NOTREACHED */
2611 case MDEREF_HV_gvhv_helem:
2614 case MDEREF_AV_gvav_aelem:
2617 sv = ITEM_SV(items);
2618 S_append_gv_name(aTHX_ (GV*)sv, out);
2620 NOT_REACHED; /* NOTREACHED */
2622 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2625 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2627 sv = ITEM_SV(items);
2628 S_append_gv_name(aTHX_ (GV*)sv, out);
2629 goto do_vivify_rv2xv_elem;
2630 NOT_REACHED; /* NOTREACHED */
2632 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2635 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2636 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2637 goto do_vivify_rv2xv_elem;
2638 NOT_REACHED; /* NOTREACHED */
2640 case MDEREF_HV_pop_rv2hv_helem:
2641 case MDEREF_HV_vivify_rv2hv_helem:
2644 do_vivify_rv2xv_elem:
2645 case MDEREF_AV_pop_rv2av_aelem:
2646 case MDEREF_AV_vivify_rv2av_aelem:
2648 sv_catpvs_nomg(out, "->");
2650 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2651 sv_catpvs_nomg(out, "->");
2656 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2657 switch (actions & MDEREF_INDEX_MASK) {
2658 case MDEREF_INDEX_const:
2661 sv = ITEM_SV(items);
2663 sv_catpvs_nomg(out, "???");
2668 pv_pretty(out, s, cur, 30,
2670 (PERL_PV_PRETTY_NOCLEAR
2671 |PERL_PV_PRETTY_QUOTE
2672 |PERL_PV_PRETTY_ELLIPSES));
2676 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2678 case MDEREF_INDEX_padsv:
2679 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2681 case MDEREF_INDEX_gvsv:
2683 sv = ITEM_SV(items);
2684 S_append_gv_name(aTHX_ (GV*)sv, out);
2687 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2689 if (actions & MDEREF_FLAG_last)
2696 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2697 (int)(actions & MDEREF_ACTION_MASK));
2703 actions >>= MDEREF_SHIFT;
2710 Perl_debop(pTHX_ const OP *o)
2712 PERL_ARGS_ASSERT_DEBOP;
2714 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2717 Perl_deb(aTHX_ "%s", OP_NAME(o));
2718 switch (o->op_type) {
2721 /* With ITHREADS, consts are stored in the pad, and the right pad
2722 * may not be active here, so check.
2723 * Looks like only during compiling the pads are illegal.
2726 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2728 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2732 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2733 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2740 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2744 S_deb_padvar(aTHX_ o->op_targ,
2745 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2749 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2750 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2756 PerlIO_printf(Perl_debug_log, "\n");
2762 =for apidoc op_class
2764 Given an op, determine what type of struct it has been allocated as.
2765 Returns one of the OPclass enums, such as OPclass_LISTOP.
2772 Perl_op_class(pTHX_ const OP *o)
2777 return OPclass_NULL;
2779 if (o->op_type == 0) {
2780 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2782 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2785 if (o->op_type == OP_SASSIGN)
2786 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2788 if (o->op_type == OP_AELEMFAST) {
2790 return OPclass_PADOP;
2792 return OPclass_SVOP;
2797 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2798 o->op_type == OP_RCATLINE)
2799 return OPclass_PADOP;
2802 if (o->op_type == OP_CUSTOM)
2805 switch (OP_CLASS(o)) {
2807 return OPclass_BASEOP;
2810 return OPclass_UNOP;
2813 return OPclass_BINOP;
2816 return OPclass_LOGOP;
2819 return OPclass_LISTOP;
2822 return OPclass_PMOP;
2825 return OPclass_SVOP;
2828 return OPclass_PADOP;
2830 case OA_PVOP_OR_SVOP:
2832 * Character translations (tr///) are usually a PVOP, keeping a
2833 * pointer to a table of shorts used to look up translations.
2834 * Under utf8, however, a simple table isn't practical; instead,
2835 * the OP is an SVOP (or, under threads, a PADOP),
2836 * and the SV is a reference to a swash
2837 * (i.e., an RV pointing to an HV).
2840 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2842 #if defined(USE_ITHREADS)
2843 ? OPclass_PADOP : OPclass_PVOP;
2845 ? OPclass_SVOP : OPclass_PVOP;
2849 return OPclass_LOOP;
2854 case OA_BASEOP_OR_UNOP:
2856 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2857 * whether parens were seen. perly.y uses OPf_SPECIAL to
2858 * signal whether a BASEOP had empty parens or none.
2859 * Some other UNOPs are created later, though, so the best
2860 * test is OPf_KIDS, which is set in newUNOP.
2862 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2866 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2867 * the OPf_REF flag to distinguish between OP types instead of the
2868 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2869 * return OPclass_UNOP so that walkoptree can find our children. If
2870 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2871 * (no argument to the operator) it's an OP; with OPf_REF set it's
2872 * an SVOP (and op_sv is the GV for the filehandle argument).
2874 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2876 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2878 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2882 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2883 * label was omitted (in which case it's a BASEOP) or else a term was
2884 * seen. In this last case, all except goto are definitely PVOP but
2885 * goto is either a PVOP (with an ordinary constant label), an UNOP
2886 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2887 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2890 if (o->op_flags & OPf_STACKED)
2891 return OPclass_UNOP;
2892 else if (o->op_flags & OPf_SPECIAL)
2893 return OPclass_BASEOP;
2895 return OPclass_PVOP;
2897 return OPclass_METHOP;
2899 return OPclass_UNOP_AUX;
2901 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2903 return OPclass_BASEOP;
2909 S_deb_curcv(pTHX_ I32 ix)
2911 PERL_SI *si = PL_curstackinfo;
2912 for (; ix >=0; ix--) {
2913 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2915 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2916 return cx->blk_sub.cv;
2917 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2918 return cx->blk_eval.cv;
2919 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2921 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2922 && si->si_type == PERLSI_SORT)
2924 /* fake sort sub; use CV of caller */
2926 ix = si->si_cxix + 1;
2933 Perl_watch(pTHX_ char **addr)
2935 PERL_ARGS_ASSERT_WATCH;
2937 PL_watchaddr = addr;
2939 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
2940 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2944 S_debprof(pTHX_ const OP *o)
2946 PERL_ARGS_ASSERT_DEBPROF;
2948 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2950 if (!PL_profiledata)
2951 Newxz(PL_profiledata, MAXO, U32);
2952 ++PL_profiledata[o->op_type];
2956 Perl_debprofdump(pTHX)
2959 if (!PL_profiledata)
2961 for (i = 0; i < MAXO; i++) {
2962 if (PL_profiledata[i])
2963 PerlIO_printf(Perl_debug_log,
2964 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2971 * ex: set ts=8 sts=4 sw=4 et: