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 "count" chars of pv and puts the results into
98 dsv such that the size of the escaped string will not exceed "max" chars
99 and will not contain any incomplete escape sequences. The number of bytes
100 escaped will be returned in the STRLEN *escaped parameter if it is not null.
101 When the 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 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 PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
110 If PERL_PV_ESCAPE_UNI is set then the input string is treated as UTF-8
111 if 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 PERL_PV_ESCAPE_ALL is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if 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 PERL_PV_ESCAPE_NOBACKSLASH
120 then all chars below 255 will be treated as printable and
121 will be output as literals.
123 If 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 PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
130 not a '\\'. This is because regexes very often contain backslashed
131 sequences, whereas '%' is not a particularly common character in patterns.
133 Returns a pointer to the escaped text as held by 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 pv_escape() and supporting quoting and ellipses.
254 If the 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 PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
259 If the 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 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 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 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 (SvREFCNT(sv) > 1)
425 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
433 if (SvCUR(t) + unref > 10) {
434 SvCUR_set(t, unref + 3);
443 if (type == SVt_PVCV) {
444 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
446 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
447 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
450 } else if (type < SVt_LAST) {
451 sv_catpv(t, svshorttypenames[type]);
453 if (type == SVt_NULL)
456 sv_catpv(t, "FREED");
461 if (!SvPVX_const(sv))
462 sv_catpv(t, "(null)");
464 SV * const tmp = newSVpvs("");
468 SvOOK_offset(sv, delta);
469 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
471 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
473 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
474 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
476 SvREFCNT_dec_NN(tmp);
479 else if (SvNOKp(sv)) {
480 STORE_NUMERIC_LOCAL_SET_STANDARD();
481 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
482 RESTORE_NUMERIC_LOCAL();
484 else if (SvIOKp(sv)) {
486 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
488 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
496 if (TAINTING_get && sv && SvTAINTED(sv))
497 sv_catpv(t, " [tainted]");
498 return SvPV_nolen(t);
502 =head1 Debugging Utilities
506 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
509 PERL_ARGS_ASSERT_DUMP_INDENT;
511 dump_vindent(level, file, pat, &args);
516 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
518 PERL_ARGS_ASSERT_DUMP_VINDENT;
519 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
520 PerlIO_vprintf(file, pat, *args);
526 Dumps the entire optree of the current program starting at C<PL_main_root> to
527 C<STDERR>. Also dumps the optrees for all visible subroutines in
536 dump_all_perl(FALSE);
540 Perl_dump_all_perl(pTHX_ bool justperl)
542 PerlIO_setlinebuf(Perl_debug_log);
544 op_dump(PL_main_root);
545 dump_packsubs_perl(PL_defstash, justperl);
549 =for apidoc dump_packsubs
551 Dumps the optrees for all visible subroutines in C<stash>.
557 Perl_dump_packsubs(pTHX_ const HV *stash)
559 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
560 dump_packsubs_perl(stash, FALSE);
564 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
568 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
572 for (i = 0; i <= (I32) HvMAX(stash); i++) {
574 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
575 const GV * const gv = (const GV *)HeVAL(entry);
576 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
579 dump_sub_perl(gv, justperl);
582 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
583 const HV * const hv = GvHV(gv);
584 if (hv && (hv != PL_defstash))
585 dump_packsubs_perl(hv, justperl); /* nested package */
592 Perl_dump_sub(pTHX_ const GV *gv)
594 PERL_ARGS_ASSERT_DUMP_SUB;
595 dump_sub_perl(gv, FALSE);
599 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
602 SV * const sv = newSVpvs_flags("", SVs_TEMP);
606 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
608 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
611 tmpsv = newSVpvs_flags("", SVs_TEMP);
612 gv_fullname3(sv, gv, NULL);
613 name = SvPV_const(sv, len);
614 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
615 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
616 if (CvISXSUB(GvCV(gv)))
617 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
618 PTR2UV(CvXSUB(GvCV(gv))),
619 (int)CvXSUBANY(GvCV(gv)).any_i32);
620 else if (CvROOT(GvCV(gv)))
621 op_dump(CvROOT(GvCV(gv)));
623 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
627 Perl_dump_form(pTHX_ const GV *gv)
629 SV * const sv = sv_newmortal();
631 PERL_ARGS_ASSERT_DUMP_FORM;
633 gv_fullname3(sv, gv, NULL);
634 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
635 if (CvROOT(GvFORM(gv)))
636 op_dump(CvROOT(GvFORM(gv)));
638 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
644 op_dump(PL_eval_root);
648 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
652 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
655 Perl_dump_indent(aTHX_ level, file, "{}\n");
658 Perl_dump_indent(aTHX_ level, file, "{\n");
660 if (pm->op_pmflags & PMf_ONCE)
665 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
666 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
667 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
669 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
670 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
671 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
672 op_dump(pm->op_pmreplrootu.op_pmreplroot);
674 if (pm->op_code_list) {
675 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
676 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
677 do_op_dump(level, file, pm->op_code_list);
680 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
681 PTR2UV(pm->op_code_list));
683 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
684 SV * const tmpsv = pm_description(pm);
685 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
686 SvREFCNT_dec_NN(tmpsv);
689 Perl_dump_indent(aTHX_ level-1, file, "}\n");
692 const struct flag_to_name pmflags_flags_names[] = {
693 {PMf_CONST, ",CONST"},
695 {PMf_GLOBAL, ",GLOBAL"},
696 {PMf_CONTINUE, ",CONTINUE"},
697 {PMf_RETAINT, ",RETAINT"},
699 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
700 {PMf_HAS_CV, ",HAS_CV"},
701 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
702 {PMf_IS_QR, ",IS_QR"}
706 S_pm_description(pTHX_ const PMOP *pm)
708 SV * const desc = newSVpvs("");
709 const REGEXP * const regex = PM_GETRE(pm);
710 const U32 pmflags = pm->op_pmflags;
712 PERL_ARGS_ASSERT_PM_DESCRIPTION;
714 if (pmflags & PMf_ONCE)
715 sv_catpv(desc, ",ONCE");
717 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
718 sv_catpv(desc, ":USED");
720 if (pmflags & PMf_USED)
721 sv_catpv(desc, ":USED");
725 if (RX_ISTAINTED(regex))
726 sv_catpv(desc, ",TAINTED");
727 if (RX_CHECK_SUBSTR(regex)) {
728 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
729 sv_catpv(desc, ",SCANFIRST");
730 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
731 sv_catpv(desc, ",ALL");
733 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
734 sv_catpv(desc, ",SKIPWHITE");
737 append_flags(desc, pmflags, pmflags_flags_names);
742 Perl_pmop_dump(pTHX_ PMOP *pm)
744 do_pmop_dump(0, Perl_debug_log, pm);
747 /* Return a unique integer to represent the address of op o.
748 * If it already exists in PL_op_sequence, just return it;
750 * *** Note that this isn't thread-safe */
753 S_sequence_num(pTHX_ const OP *o)
762 op = newSVuv(PTR2UV(o));
764 key = SvPV_const(op, len);
766 PL_op_sequence = newHV();
767 seq = hv_fetch(PL_op_sequence, key, len, 0);
770 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
778 const struct flag_to_name op_flags_names[] = {
780 {OPf_PARENS, ",PARENS"},
783 {OPf_STACKED, ",STACKED"},
784 {OPf_SPECIAL, ",SPECIAL"}
789 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
792 const OPCODE optype = o->op_type;
794 PERL_ARGS_ASSERT_DO_OP_DUMP;
796 Perl_dump_indent(aTHX_ level, file, "{\n");
798 seq = sequence_num(o);
800 PerlIO_printf(file, "%-4"UVuf, seq);
802 PerlIO_printf(file, "????");
804 "%*sTYPE = %s ===> ",
805 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
808 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
809 sequence_num(o->op_next));
811 PerlIO_printf(file, "NULL\n");
813 if (optype == OP_NULL) {
814 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
817 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
820 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
823 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
824 SV * const tmpsv = newSVpvs("");
825 switch (o->op_flags & OPf_WANT) {
827 sv_catpv(tmpsv, ",VOID");
829 case OPf_WANT_SCALAR:
830 sv_catpv(tmpsv, ",SCALAR");
833 sv_catpv(tmpsv, ",LIST");
836 sv_catpv(tmpsv, ",UNKNOWN");
839 append_flags(tmpsv, o->op_flags, op_flags_names);
840 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
841 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
842 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
843 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
844 if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB");
845 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
846 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
850 U16 oppriv = o->op_private;
851 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
856 tmpsv = newSVpvs("");
857 for (; !stop; op_ix++) {
858 U16 entry = PL_op_private_bitdefs[op_ix];
859 U16 bit = (entry >> 2) & 7;
866 I16 const *p = &PL_op_private_bitfields[ix];
867 U16 bitmin = (U16) *p++;
874 for (i = bitmin; i<= bit; i++)
877 val = (oppriv & mask);
880 && PL_op_private_labels[label] == '-'
881 && PL_op_private_labels[label+1] == '\0'
883 /* display as raw number */
896 if (val == 0 && enum_label == -1)
897 /* don't display anonymous zero values */
900 sv_catpv(tmpsv, ",");
902 sv_catpv(tmpsv, &PL_op_private_labels[label]);
903 sv_catpv(tmpsv, "=");
905 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
910 if ( oppriv & (1<<bit)
911 && !(PL_op_private_labels[ix] == '-'
912 && PL_op_private_labels[ix+1] == '\0'))
915 sv_catpv(tmpsv, ",");
916 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
921 sv_catpv(tmpsv, ",");
922 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
925 if (tmpsv && SvCUR(tmpsv)) {
926 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
928 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
937 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
939 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
943 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
944 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
945 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
946 name = SvPV_const(tmpsv, len);
947 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
948 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
951 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
958 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
959 UV i, count = items[-1].uv;
961 Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
962 for (i=0; i < count; i++)
963 Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
969 case OP_METHOD_NAMED:
970 case OP_METHOD_SUPER:
971 case OP_METHOD_REDIR:
972 case OP_METHOD_REDIR_SUPER:
974 /* with ITHREADS, consts are stored in the pad, and the right pad
975 * may not be active here, so skip */
976 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
980 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
986 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
988 if (CopSTASHPV(cCOPo)) {
989 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
990 HV *stash = CopSTASH(cCOPo);
991 const char * const hvname = HvNAME_get(stash);
993 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
994 generic_pv_escape(tmpsv, hvname,
995 HvNAMELEN(stash), HvNAMEUTF8(stash)));
997 if (CopLABEL(cCOPo)) {
998 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1001 const char *label = CopLABEL_len_flags(cCOPo,
1002 &label_len, &label_flags);
1003 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1004 generic_pv_escape( tmpsv, label, label_len,
1005 (label_flags & SVf_UTF8)));
1007 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1008 (unsigned int)cCOPo->cop_seq);
1011 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1012 if (cLOOPo->op_redoop)
1013 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1015 PerlIO_printf(file, "DONE\n");
1016 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1017 if (cLOOPo->op_nextop)
1018 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1020 PerlIO_printf(file, "DONE\n");
1021 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1022 if (cLOOPo->op_lastop)
1023 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1025 PerlIO_printf(file, "DONE\n");
1033 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1034 if (cLOGOPo->op_other)
1035 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1037 PerlIO_printf(file, "DONE\n");
1043 do_pmop_dump(level, file, cPMOPo);
1051 if (o->op_private & OPpREFCOUNTED)
1052 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1057 if (o->op_flags & OPf_KIDS) {
1059 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1060 do_op_dump(level, file, kid);
1062 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1068 Dumps the optree starting at OP C<o> to C<STDERR>.
1074 Perl_op_dump(pTHX_ const OP *o)
1076 PERL_ARGS_ASSERT_OP_DUMP;
1077 do_op_dump(0, Perl_debug_log, o);
1081 Perl_gv_dump(pTHX_ GV *gv)
1085 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1088 PERL_ARGS_ASSERT_GV_DUMP;
1091 PerlIO_printf(Perl_debug_log, "{}\n");
1094 sv = sv_newmortal();
1095 PerlIO_printf(Perl_debug_log, "{\n");
1096 gv_fullname3(sv, gv, NULL);
1097 name = SvPV_const(sv, len);
1098 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1099 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1100 if (gv != GvEGV(gv)) {
1101 gv_efullname3(sv, GvEGV(gv), NULL);
1102 name = SvPV_const(sv, len);
1103 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1104 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1106 PerlIO_putc(Perl_debug_log, '\n');
1107 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1111 /* map magic types to the symbolic names
1112 * (with the PERL_MAGIC_ prefixed stripped)
1115 static const struct { const char type; const char *name; } magic_names[] = {
1116 #include "mg_names.c"
1117 /* this null string terminates the list */
1122 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1124 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1126 for (; mg; mg = mg->mg_moremagic) {
1127 Perl_dump_indent(aTHX_ level, file,
1128 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1129 if (mg->mg_virtual) {
1130 const MGVTBL * const v = mg->mg_virtual;
1131 if (v >= PL_magic_vtables
1132 && v < PL_magic_vtables + magic_vtable_max) {
1133 const U32 i = v - PL_magic_vtables;
1134 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1137 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1140 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1143 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1147 const char *name = NULL;
1148 for (n = 0; magic_names[n].name; n++) {
1149 if (mg->mg_type == magic_names[n].type) {
1150 name = magic_names[n].name;
1155 Perl_dump_indent(aTHX_ level, file,
1156 " MG_TYPE = PERL_MAGIC_%s\n", name);
1158 Perl_dump_indent(aTHX_ level, file,
1159 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1163 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1164 if (mg->mg_type == PERL_MAGIC_envelem &&
1165 mg->mg_flags & MGf_TAINTEDDIR)
1166 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1167 if (mg->mg_type == PERL_MAGIC_regex_global &&
1168 mg->mg_flags & MGf_MINMATCH)
1169 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1170 if (mg->mg_flags & MGf_REFCOUNTED)
1171 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1172 if (mg->mg_flags & MGf_GSKIP)
1173 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1174 if (mg->mg_flags & MGf_COPY)
1175 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1176 if (mg->mg_flags & MGf_DUP)
1177 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1178 if (mg->mg_flags & MGf_LOCAL)
1179 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1180 if (mg->mg_type == PERL_MAGIC_regex_global &&
1181 mg->mg_flags & MGf_BYTES)
1182 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1185 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1186 PTR2UV(mg->mg_obj));
1187 if (mg->mg_type == PERL_MAGIC_qr) {
1188 REGEXP* const re = (REGEXP *)mg->mg_obj;
1189 SV * const dsv = sv_newmortal();
1190 const char * const s
1191 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1193 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1194 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1196 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1197 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1200 if (mg->mg_flags & MGf_REFCOUNTED)
1201 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1204 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1206 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1207 if (mg->mg_len >= 0) {
1208 if (mg->mg_type != PERL_MAGIC_utf8) {
1209 SV * const sv = newSVpvs("");
1210 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1211 SvREFCNT_dec_NN(sv);
1214 else if (mg->mg_len == HEf_SVKEY) {
1215 PerlIO_puts(file, " => HEf_SVKEY\n");
1216 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1217 maxnest, dumpops, pvlim); /* MG is already +1 */
1220 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1225 " does not know how to handle this MG_LEN"
1227 PerlIO_putc(file, '\n');
1229 if (mg->mg_type == PERL_MAGIC_utf8) {
1230 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1233 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1234 Perl_dump_indent(aTHX_ level, file,
1235 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1238 (UV)cache[i * 2 + 1]);
1245 Perl_magic_dump(pTHX_ const MAGIC *mg)
1247 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1251 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1255 PERL_ARGS_ASSERT_DO_HV_DUMP;
1257 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1258 if (sv && (hvname = HvNAME_get(sv)))
1260 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1261 name which quite legally could contain insane things like tabs, newlines, nulls or
1262 other scary crap - this should produce sane results - except maybe for unicode package
1263 names - but we will wait for someone to file a bug on that - demerphq */
1264 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1265 PerlIO_printf(file, "\t\"%s\"\n",
1266 generic_pv_escape( tmpsv, hvname,
1267 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1270 PerlIO_putc(file, '\n');
1274 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1276 PERL_ARGS_ASSERT_DO_GV_DUMP;
1278 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1279 if (sv && GvNAME(sv)) {
1280 SV * const tmpsv = newSVpvs("");
1281 PerlIO_printf(file, "\t\"%s\"\n",
1282 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1285 PerlIO_putc(file, '\n');
1289 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1291 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1293 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1294 if (sv && GvNAME(sv)) {
1295 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1297 HV * const stash = GvSTASH(sv);
1298 PerlIO_printf(file, "\t");
1299 /* TODO might have an extra \" here */
1300 if (stash && (hvname = HvNAME_get(stash))) {
1301 PerlIO_printf(file, "\"%s\" :: \"",
1302 generic_pv_escape(tmp, hvname,
1303 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1305 PerlIO_printf(file, "%s\"\n",
1306 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1309 PerlIO_putc(file, '\n');
1312 const struct flag_to_name first_sv_flags_names[] = {
1313 {SVs_TEMP, "TEMP,"},
1314 {SVs_OBJECT, "OBJECT,"},
1323 const struct flag_to_name second_sv_flags_names[] = {
1325 {SVf_FAKE, "FAKE,"},
1326 {SVf_READONLY, "READONLY,"},
1327 {SVf_PROTECT, "PROTECT,"},
1328 {SVf_BREAK, "BREAK,"},
1334 const struct flag_to_name cv_flags_names[] = {
1335 {CVf_ANON, "ANON,"},
1336 {CVf_UNIQUE, "UNIQUE,"},
1337 {CVf_CLONE, "CLONE,"},
1338 {CVf_CLONED, "CLONED,"},
1339 {CVf_CONST, "CONST,"},
1340 {CVf_NODEBUG, "NODEBUG,"},
1341 {CVf_LVALUE, "LVALUE,"},
1342 {CVf_METHOD, "METHOD,"},
1343 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1344 {CVf_CVGV_RC, "CVGV_RC,"},
1345 {CVf_DYNFILE, "DYNFILE,"},
1346 {CVf_AUTOLOAD, "AUTOLOAD,"},
1347 {CVf_HASEVAL, "HASEVAL,"},
1348 {CVf_SLABBED, "SLABBED,"},
1349 {CVf_NAMED, "NAMED,"},
1350 {CVf_LEXICAL, "LEXICAL,"},
1351 {CVf_ISXSUB, "ISXSUB,"}
1354 const struct flag_to_name hv_flags_names[] = {
1355 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1356 {SVphv_LAZYDEL, "LAZYDEL,"},
1357 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1358 {SVf_AMAGIC, "OVERLOAD,"},
1359 {SVphv_CLONEABLE, "CLONEABLE,"}
1362 const struct flag_to_name gp_flags_names[] = {
1363 {GVf_INTRO, "INTRO,"},
1364 {GVf_MULTI, "MULTI,"},
1365 {GVf_ASSUMECV, "ASSUMECV,"},
1368 const struct flag_to_name gp_flags_imported_names[] = {
1369 {GVf_IMPORTED_SV, " SV"},
1370 {GVf_IMPORTED_AV, " AV"},
1371 {GVf_IMPORTED_HV, " HV"},
1372 {GVf_IMPORTED_CV, " CV"},
1375 /* NOTE: this structure is mostly duplicative of one generated by
1376 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1377 * the two. - Yves */
1378 const struct flag_to_name regexp_extflags_names[] = {
1379 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1380 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1381 {RXf_PMf_FOLD, "PMf_FOLD,"},
1382 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1383 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1384 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1385 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1386 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1387 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1388 {RXf_CHECK_ALL, "CHECK_ALL,"},
1389 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1390 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1391 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1392 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1393 {RXf_SPLIT, "SPLIT,"},
1394 {RXf_COPY_DONE, "COPY_DONE,"},
1395 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1396 {RXf_TAINTED, "TAINTED,"},
1397 {RXf_START_ONLY, "START_ONLY,"},
1398 {RXf_SKIPWHITE, "SKIPWHITE,"},
1399 {RXf_WHITE, "WHITE,"},
1400 {RXf_NULL, "NULL,"},
1403 /* NOTE: this structure is mostly duplicative of one generated by
1404 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1405 * the two. - Yves */
1406 const struct flag_to_name regexp_core_intflags_names[] = {
1407 {PREGf_SKIP, "SKIP,"},
1408 {PREGf_IMPLICIT, "IMPLICIT,"},
1409 {PREGf_NAUGHTY, "NAUGHTY,"},
1410 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1411 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1412 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1413 {PREGf_NOSCAN, "NOSCAN,"},
1414 {PREGf_CANY_SEEN, "CANY_SEEN,"},
1415 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1416 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1417 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1418 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1419 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1423 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1430 PERL_ARGS_ASSERT_DO_SV_DUMP;
1433 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1437 flags = SvFLAGS(sv);
1440 /* process general SV flags */
1442 d = Perl_newSVpvf(aTHX_
1443 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1444 PTR2UV(SvANY(sv)), PTR2UV(sv),
1445 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1446 (int)(PL_dumpindent*level), "");
1448 if ((flags & SVs_PADSTALE))
1449 sv_catpv(d, "PADSTALE,");
1450 if ((flags & SVs_PADTMP))
1451 sv_catpv(d, "PADTMP,");
1452 append_flags(d, flags, first_sv_flags_names);
1453 if (flags & SVf_ROK) {
1454 sv_catpv(d, "ROK,");
1455 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1457 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1458 append_flags(d, flags, second_sv_flags_names);
1459 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1460 && type != SVt_PVAV) {
1461 if (SvPCS_IMPORTED(sv))
1462 sv_catpv(d, "PCS_IMPORTED,");
1464 sv_catpv(d, "SCREAM,");
1467 /* process type-specific SV flags */
1472 append_flags(d, CvFLAGS(sv), cv_flags_names);
1475 append_flags(d, flags, hv_flags_names);
1479 if (isGV_with_GP(sv)) {
1480 append_flags(d, GvFLAGS(sv), gp_flags_names);
1482 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1483 sv_catpv(d, "IMPORT");
1484 if (GvIMPORTED(sv) == GVf_IMPORTED)
1485 sv_catpv(d, "ALL,");
1488 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1495 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1496 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1499 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1500 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1506 /* SVphv_SHAREKEYS is also 0x20000000 */
1507 if ((type != SVt_PVHV) && SvUTF8(sv))
1508 sv_catpv(d, "UTF8");
1510 if (*(SvEND(d) - 1) == ',') {
1511 SvCUR_set(d, SvCUR(d) - 1);
1512 SvPVX(d)[SvCUR(d)] = '\0';
1517 /* dump initial SV details */
1519 #ifdef DEBUG_LEAKING_SCALARS
1520 Perl_dump_indent(aTHX_ level, file,
1521 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1522 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1524 sv->sv_debug_inpad ? "for" : "by",
1525 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1526 PTR2UV(sv->sv_debug_parent),
1530 Perl_dump_indent(aTHX_ level, file, "SV = ");
1534 if (type < SVt_LAST) {
1535 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1537 if (type == SVt_NULL) {
1542 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1547 /* Dump general SV fields */
1549 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1550 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1551 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1552 || (type == SVt_IV && !SvROK(sv))) {
1554 #ifdef PERL_OLD_COPY_ON_WRITE
1558 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1560 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1561 #ifdef PERL_OLD_COPY_ON_WRITE
1562 if (SvIsCOW_shared_hash(sv))
1563 PerlIO_printf(file, " (HASH)");
1564 else if (SvIsCOW_normal(sv))
1565 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1567 PerlIO_putc(file, '\n');
1570 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1571 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1572 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1573 || type == SVt_NV) {
1574 STORE_NUMERIC_LOCAL_SET_STANDARD();
1575 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1576 RESTORE_NUMERIC_LOCAL();
1580 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1582 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1585 if (type < SVt_PV) {
1590 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1591 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1592 const bool re = isREGEXP(sv);
1593 const char * const ptr =
1594 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1598 SvOOK_offset(sv, delta);
1599 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1604 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1606 PerlIO_printf(file, "( %s . ) ",
1607 pv_display(d, ptr - delta, delta, 0,
1610 if (type == SVt_INVLIST) {
1611 PerlIO_printf(file, "\n");
1612 /* 4 blanks indents 2 beyond the PV, etc */
1613 _invlist_dump(file, level, " ", sv);
1616 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1619 if (SvUTF8(sv)) /* the 6? \x{....} */
1620 PerlIO_printf(file, " [UTF8 \"%s\"]",
1621 sv_uni_display(d, sv, 6 * SvCUR(sv),
1623 PerlIO_printf(file, "\n");
1625 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1627 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1629 #ifdef PERL_NEW_COPY_ON_WRITE
1630 if (SvIsCOW(sv) && SvLEN(sv))
1631 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1636 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1639 if (type >= SVt_PVMG) {
1641 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1643 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1645 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1646 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1650 /* Dump type-specific SV fields */
1654 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1655 if (AvARRAY(sv) != AvALLOC(sv)) {
1656 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1657 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1660 PerlIO_putc(file, '\n');
1661 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1662 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1663 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1664 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1666 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1667 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1668 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1669 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1670 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1672 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1673 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1675 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1677 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1684 struct xpvhv_aux *const aux = HvAUX(sv);
1685 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1686 (UV)aux->xhv_aux_flags);
1688 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1689 usedkeys = HvUSEDKEYS(sv);
1690 if (HvARRAY(sv) && usedkeys) {
1691 /* Show distribution of HEs in the ARRAY */
1693 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1696 U32 pow2 = 2, keys = usedkeys;
1697 NV theoret, sum = 0;
1699 PerlIO_printf(file, " (");
1700 Zero(freq, FREQ_MAX + 1, int);
1701 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1704 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1706 if (count > FREQ_MAX)
1712 for (i = 0; i <= max; i++) {
1714 PerlIO_printf(file, "%d%s:%d", i,
1715 (i == FREQ_MAX) ? "+" : "",
1718 PerlIO_printf(file, ", ");
1721 PerlIO_putc(file, ')');
1722 /* The "quality" of a hash is defined as the total number of
1723 comparisons needed to access every element once, relative
1724 to the expected number needed for a random hash.
1726 The total number of comparisons is equal to the sum of
1727 the squares of the number of entries in each bucket.
1728 For a random hash of n keys into k buckets, the expected
1733 for (i = max; i > 0; i--) { /* Precision: count down. */
1734 sum += freq[i] * i * i;
1736 while ((keys = keys >> 1))
1739 theoret += theoret * (theoret-1)/pow2;
1740 PerlIO_putc(file, '\n');
1741 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1743 PerlIO_putc(file, '\n');
1744 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1747 HE **ents = HvARRAY(sv);
1750 HE *const *const last = ents + HvMAX(sv);
1751 count = last + 1 - ents;
1756 } while (++ents <= last);
1760 struct xpvhv_aux *const aux = HvAUX(sv);
1761 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1762 " (cached = %"UVuf")\n",
1763 (UV)count, (UV)aux->xhv_fill_lazy);
1765 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1769 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1771 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1772 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1773 #ifdef PERL_HASH_RANDOMIZE_KEYS
1774 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1775 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1776 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1779 PerlIO_putc(file, '\n');
1782 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1783 if (mg && mg->mg_obj) {
1784 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1788 const char * const hvname = HvNAME_get(sv);
1790 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1791 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1792 generic_pv_escape( tmpsv, hvname,
1793 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1798 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1799 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1800 if (HvAUX(sv)->xhv_name_count)
1801 Perl_dump_indent(aTHX_
1802 level, file, " NAMECOUNT = %"IVdf"\n",
1803 (IV)HvAUX(sv)->xhv_name_count
1805 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1806 const I32 count = HvAUX(sv)->xhv_name_count;
1808 SV * const names = newSVpvs_flags("", SVs_TEMP);
1809 /* The starting point is the first element if count is
1810 positive and the second element if count is negative. */
1811 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1812 + (count < 0 ? 1 : 0);
1813 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1814 + (count < 0 ? -count : count);
1815 while (hekp < endp) {
1816 if (HEK_LEN(*hekp)) {
1817 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1818 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1819 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1821 /* This should never happen. */
1822 sv_catpvs(names, ", (null)");
1826 Perl_dump_indent(aTHX_
1827 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1831 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1832 const char *const hvename = HvENAME_get(sv);
1833 Perl_dump_indent(aTHX_
1834 level, file, " ENAME = \"%s\"\n",
1835 generic_pv_escape(tmp, hvename,
1836 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1840 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1842 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1846 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1847 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1848 generic_pv_escape( tmpsv, meta->mro_which->name,
1849 meta->mro_which->length,
1850 (meta->mro_which->kflags & HVhek_UTF8)),
1851 PTR2UV(meta->mro_which));
1852 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1853 (UV)meta->cache_gen);
1854 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1856 if (meta->mro_linear_all) {
1857 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1858 PTR2UV(meta->mro_linear_all));
1859 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1862 if (meta->mro_linear_current) {
1863 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1864 PTR2UV(meta->mro_linear_current));
1865 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1868 if (meta->mro_nextmethod) {
1869 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1870 PTR2UV(meta->mro_nextmethod));
1871 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1875 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1877 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1882 if (nest < maxnest) {
1883 HV * const hv = MUTABLE_HV(sv);
1888 int count = maxnest - nest;
1889 for (i=0; i <= HvMAX(hv); i++) {
1890 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1897 if (count-- <= 0) goto DONEHV;
1900 keysv = hv_iterkeysv(he);
1901 keypv = SvPV_const(keysv, len);
1904 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1906 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1907 if (HvEITER_get(hv) == he)
1908 PerlIO_printf(file, "[CURRENT] ");
1909 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1910 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1917 } /* case SVt_PVHV */
1920 if (CvAUTOLOAD(sv)) {
1921 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1923 const char *const name = SvPV_const(sv, len);
1924 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1925 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1928 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1929 const char *const proto = CvPROTO(sv);
1930 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1931 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1936 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1937 if (!CvISXSUB(sv)) {
1939 Perl_dump_indent(aTHX_ level, file,
1940 " START = 0x%"UVxf" ===> %"IVdf"\n",
1941 PTR2UV(CvSTART(sv)),
1942 (IV)sequence_num(CvSTART(sv)));
1944 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1945 PTR2UV(CvROOT(sv)));
1946 if (CvROOT(sv) && dumpops) {
1947 do_op_dump(level+1, file, CvROOT(sv));
1950 SV * const constant = cv_const_sv((const CV *)sv);
1952 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1955 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1957 PTR2UV(CvXSUBANY(sv).any_ptr));
1958 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1961 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1962 (IV)CvXSUBANY(sv).any_i32);
1966 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1967 HEK_KEY(CvNAME_HEK((CV *)sv)));
1968 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1969 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1970 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1971 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1972 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1973 if (!CvISXSUB(sv)) {
1974 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1975 if (nest < maxnest) {
1976 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1980 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
1982 const CV * const outside = CvOUTSIDE(sv);
1983 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1986 : CvANON(outside) ? "ANON"
1987 : (outside == PL_main_cv) ? "MAIN"
1988 : CvUNIQUE(outside) ? "UNIQUE"
1991 newSVpvs_flags("", SVs_TEMP),
1992 GvNAME(CvGV(outside)),
1993 GvNAMELEN(CvGV(outside)),
1994 GvNAMEUTF8(CvGV(outside)))
1998 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
1999 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2004 if (type == SVt_PVLV) {
2005 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2006 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2007 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2008 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2009 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2010 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2011 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2014 if (isREGEXP(sv)) goto dumpregexp;
2015 if (!isGV_with_GP(sv))
2018 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2019 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2020 generic_pv_escape(tmpsv, GvNAME(sv),
2024 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2025 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2026 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2027 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2030 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2031 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2032 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2033 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2038 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2041 GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2042 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2043 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2044 do_gv_dump (level, file, " EGV", GvEGV(sv));
2047 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2048 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2049 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2050 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2051 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2052 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2053 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2055 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2056 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2057 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2059 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2060 PTR2UV(IoTOP_GV(sv)));
2061 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2062 maxnest, dumpops, pvlim);
2064 /* Source filters hide things that are not GVs in these three, so let's
2065 be careful out there. */
2067 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2068 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2069 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2071 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2072 PTR2UV(IoFMT_GV(sv)));
2073 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2074 maxnest, dumpops, pvlim);
2076 if (IoBOTTOM_NAME(sv))
2077 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2078 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2079 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2081 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2082 PTR2UV(IoBOTTOM_GV(sv)));
2083 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2084 maxnest, dumpops, pvlim);
2086 if (isPRINT(IoTYPE(sv)))
2087 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2089 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2090 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2095 struct regexp * const r = ReANY((REGEXP*)sv);
2097 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2099 append_flags(d, flags, names); \
2100 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2101 SvCUR_set(d, SvCUR(d) - 1); \
2102 SvPVX(d)[SvCUR(d)] = '\0'; \
2105 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2106 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2107 (UV)(r->compflags), SvPVX_const(d));
2109 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2110 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2111 (UV)(r->extflags), SvPVX_const(d));
2113 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2114 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2115 if (r->engine == &PL_core_reg_engine) {
2116 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2117 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2118 (UV)(r->intflags), SvPVX_const(d));
2120 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2123 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2124 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2126 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2127 (UV)(r->lastparen));
2128 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2129 (UV)(r->lastcloseparen));
2130 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2132 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2133 (IV)(r->minlenret));
2134 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2136 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2137 (UV)(r->pre_prefix));
2138 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2140 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2141 (IV)(r->suboffset));
2142 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2143 (IV)(r->subcoffset));
2145 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2147 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2149 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2150 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2151 PTR2UV(r->mother_re));
2152 if (nest < maxnest && r->mother_re)
2153 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2154 maxnest, dumpops, pvlim);
2155 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2156 PTR2UV(r->paren_names));
2157 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2158 PTR2UV(r->substrs));
2159 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2160 PTR2UV(r->pprivate));
2161 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2163 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2164 PTR2UV(r->qr_anoncv));
2166 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2167 PTR2UV(r->saved_copy));
2178 Dumps the contents of an SV to the C<STDERR> filehandle.
2180 For an example of its output, see L<Devel::Peek>.
2186 Perl_sv_dump(pTHX_ SV *sv)
2188 PERL_ARGS_ASSERT_SV_DUMP;
2191 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2193 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2197 Perl_runops_debug(pTHX)
2200 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2204 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2206 #ifdef PERL_TRACE_OPS
2207 ++PL_op_exec_cnt[PL_op->op_type];
2210 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2211 PerlIO_printf(Perl_debug_log,
2212 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2213 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2214 PTR2UV(*PL_watchaddr));
2215 if (DEBUG_s_TEST_) {
2216 if (DEBUG_v_TEST_) {
2217 PerlIO_printf(Perl_debug_log, "\n");
2225 if (DEBUG_t_TEST_) debop(PL_op);
2226 if (DEBUG_P_TEST_) debprof(PL_op);
2229 OP_ENTRY_PROBE(OP_NAME(PL_op));
2230 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2231 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2239 /* print the names of the n lexical vars starting at pad offset off */
2242 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2245 CV * const cv = deb_curcv(cxstack_ix);
2246 PADNAMELIST *comppad = NULL;
2250 PADLIST * const padlist = CvPADLIST(cv);
2251 comppad = PadlistNAMES(padlist);
2254 PerlIO_printf(Perl_debug_log, "(");
2255 for (i = 0; i < n; i++) {
2256 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2257 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2259 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2262 PerlIO_printf(Perl_debug_log, ",");
2265 PerlIO_printf(Perl_debug_log, ")");
2269 /* append to the out SV, the name of the lexical at offset off in the CV
2273 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2274 bool paren, bool is_scalar)
2277 PADNAMELIST *namepad = NULL;
2281 PADLIST * const padlist = CvPADLIST(cv);
2282 namepad = PadlistNAMES(padlist);
2286 sv_catpvs_nomg(out, "(");
2287 for (i = 0; i < n; i++) {
2288 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2290 STRLEN cur = SvCUR(out);
2291 Perl_sv_catpvf(aTHX_ out, "[%"PNf, PNfARG(sv));
2293 SvPVX(out)[cur] = '$';
2296 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2298 sv_catpvs_nomg(out, ",");
2301 sv_catpvs_nomg(out, "(");
2306 S_append_gv_name(pTHX_ GV *gv, SV *out)
2310 sv_catpvs_nomg(out, "<NULLGV>");
2314 gv_fullname4(sv, gv, NULL, FALSE);
2315 Perl_sv_catpvf(aTHX_ out, "%c%-p", '$', sv);
2316 SvREFCNT_dec_NN(sv);
2320 # define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
2322 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2326 /* return a temporary SV containing a stringified representation of
2327 * the op_aux field of a UNOP_AUX op, associated with CV cv
2331 Perl_unop_aux_stringify(pTHX_ const OP *o, CV *cv)
2333 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2334 UV actions = items->uv;
2337 bool is_hash = FALSE;
2339 SV *out = sv_2mortal(newSVpv("",0));
2341 PADLIST * const padlist = CvPADLIST(cv);
2342 PAD *comppad = PadlistARRAY(padlist)[1];
2345 PERL_ARGS_ASSERT_UNOP_AUX_STRINGIFY;
2348 switch (actions & MDEREF_ACTION_MASK) {
2351 actions = (++items)->uv;
2354 case MDEREF_HV_padhv_helem:
2356 case MDEREF_AV_padav_aelem:
2358 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2361 case MDEREF_HV_gvhv_helem:
2363 case MDEREF_AV_gvav_aelem:
2365 sv = ITEM_SV(++items);
2366 S_append_gv_name(aTHX_ (GV*)sv, out);
2369 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2371 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2372 sv = ITEM_SV(++items);
2373 S_append_gv_name(aTHX_ (GV*)sv, out);
2374 goto do_vivify_rv2xv_elem;
2376 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2378 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2379 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2380 goto do_vivify_rv2xv_elem;
2382 case MDEREF_HV_pop_rv2hv_helem:
2383 case MDEREF_HV_vivify_rv2hv_helem:
2385 do_vivify_rv2xv_elem:
2386 case MDEREF_AV_pop_rv2av_aelem:
2387 case MDEREF_AV_vivify_rv2av_aelem:
2389 sv_catpvs_nomg(out, "->");
2391 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2392 sv_catpvs_nomg(out, "->");
2397 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2398 switch (actions & MDEREF_INDEX_MASK) {
2399 case MDEREF_INDEX_const:
2403 sv = ITEM_SV(++items);
2405 pv_pretty(out, s, cur, 30,
2407 (PERL_PV_PRETTY_NOCLEAR
2408 |PERL_PV_PRETTY_QUOTE
2409 |PERL_PV_PRETTY_ELLIPSES));
2412 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2414 case MDEREF_INDEX_padsv:
2415 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2417 case MDEREF_INDEX_gvsv:
2418 sv = ITEM_SV(++items);
2419 S_append_gv_name(aTHX_ (GV*)sv, out);
2422 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2424 if (actions & MDEREF_FLAG_last)
2431 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2432 (int)(actions & MDEREF_ACTION_MASK));
2438 actions >>= MDEREF_SHIFT;
2445 Perl_debop(pTHX_ const OP *o)
2447 PERL_ARGS_ASSERT_DEBOP;
2449 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2452 Perl_deb(aTHX_ "%s", OP_NAME(o));
2453 switch (o->op_type) {
2456 /* With ITHREADS, consts are stored in the pad, and the right pad
2457 * may not be active here, so check.
2458 * Looks like only during compiling the pads are illegal.
2461 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2463 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2467 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2468 SV * const sv = newSV(0);
2469 gv_fullname3(sv, cGVOPo_gv, NULL);
2470 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2471 SvREFCNT_dec_NN(sv);
2473 else if (cGVOPo_gv) {
2474 SV * const sv = newSV(0);
2475 assert(SvROK(cGVOPo_gv));
2476 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2477 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2478 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2479 SvREFCNT_dec_NN(sv);
2482 PerlIO_printf(Perl_debug_log, "(NULL)");
2488 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2492 S_deb_padvar(aTHX_ o->op_targ,
2493 o->op_private & OPpPADRANGE_COUNTMASK, 1);
2497 PerlIO_printf(Perl_debug_log, "(%-p)",
2498 unop_aux_stringify(o, deb_curcv(cxstack_ix)));
2504 PerlIO_printf(Perl_debug_log, "\n");
2509 S_deb_curcv(pTHX_ const I32 ix)
2511 const PERL_CONTEXT * const cx = &cxstack[ix];
2512 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2513 return cx->blk_sub.cv;
2514 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2515 return cx->blk_eval.cv;
2516 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2521 return deb_curcv(ix - 1);
2525 Perl_watch(pTHX_ char **addr)
2527 PERL_ARGS_ASSERT_WATCH;
2529 PL_watchaddr = addr;
2531 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2532 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2536 S_debprof(pTHX_ const OP *o)
2538 PERL_ARGS_ASSERT_DEBPROF;
2540 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2542 if (!PL_profiledata)
2543 Newxz(PL_profiledata, MAXO, U32);
2544 ++PL_profiledata[o->op_type];
2548 Perl_debprofdump(pTHX)
2551 if (!PL_profiledata)
2553 for (i = 0; i < MAXO; i++) {
2554 if (PL_profiledata[i])
2555 PerlIO_printf(Perl_debug_log,
2556 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2564 * c-indentation-style: bsd
2566 * indent-tabs-mode: nil
2569 * ex: set ts=8 sts=4 sw=4 et: