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.
26 #define PERL_IN_DUMP_C
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
75 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
76 const struct flag_to_name *const end)
79 if (flags & start->flag)
80 sv_catpv(sv, start->name);
81 } while (++start < end);
84 #define append_flags(sv, f, flags) \
85 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
87 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
88 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
89 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
90 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
95 Escapes at most the first "count" chars of pv and puts the results into
96 dsv such that the size of the escaped string will not exceed "max" chars
97 and will not contain any incomplete escape sequences.
99 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
100 will also be escaped.
102 Normally the SV will be cleared before the escaped string is prepared,
103 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
105 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
106 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
107 using C<is_utf8_string()> to determine if it is Unicode.
109 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
110 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
111 non-ASCII chars will be escaped using this style; otherwise, only chars above
112 255 will be so escaped; other non printable chars will use octal or
113 common escaped patterns like C<\n>.
114 Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
115 then all chars below 255 will be treated as printable and
116 will be output as literals.
118 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
119 string will be escaped, regardless of max. If the output is to be in hex,
120 then it will be returned as a plain hex
121 sequence. Thus the output will either be a single char,
122 an octal escape sequence, a special escape like C<\n> or a hex value.
124 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
125 not a '\\'. This is because regexes very often contain backslashed
126 sequences, whereas '%' is not a particularly common character in patterns.
128 Returns a pointer to the escaped text as held by dsv.
132 #define PV_ESCAPE_OCTBUFSIZE 32
135 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
136 const STRLEN count, const STRLEN max,
137 STRLEN * const escaped, const U32 flags )
139 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
140 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
141 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
142 STRLEN wrote = 0; /* chars written so far */
143 STRLEN chsize = 0; /* size of data to be written */
144 STRLEN readsize = 1; /* size of data just read */
145 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
146 const char *pv = str;
147 const char * const end = pv + count; /* end of string */
150 PERL_ARGS_ASSERT_PV_ESCAPE;
152 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
153 /* This won't alter the UTF-8 flag */
157 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
160 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
161 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
162 const U8 c = (U8)u & 0xFF;
165 || (flags & PERL_PV_ESCAPE_ALL)
166 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
168 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
169 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
172 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
173 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
175 : "%cx{%02"UVxf"}", esc, u);
177 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
180 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
184 case '\\' : /* fallthrough */
185 case '%' : if ( c == esc ) {
191 case '\v' : octbuf[1] = 'v'; break;
192 case '\t' : octbuf[1] = 't'; break;
193 case '\r' : octbuf[1] = 'r'; break;
194 case '\n' : octbuf[1] = 'n'; break;
195 case '\f' : octbuf[1] = 'f'; break;
203 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
204 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
205 isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
208 else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
212 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
219 if ( max && (wrote + chsize > max) ) {
221 } else if (chsize > 1) {
222 sv_catpvn(dsv, octbuf, chsize);
225 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
226 can be appended raw to the dsv. If dsv happens to be
227 UTF-8 then we need catpvf to upgrade them for us.
228 Or add a new API call sv_catpvc(). Think about that name, and
229 how to keep it clear that it's unlike the s of catpvs, which is
230 really an array of octets, not a string. */
231 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
234 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
242 =for apidoc pv_pretty
244 Converts a string into something presentable, handling escaping via
245 pv_escape() and supporting quoting and ellipses.
247 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
248 double quoted with any double quotes in the string escaped. Otherwise
249 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
252 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
253 string were output then an ellipsis C<...> will be appended to the
254 string. Note that this happens AFTER it has been quoted.
256 If start_color is non-null then it will be inserted after the opening
257 quote (if there is one) but before the escaped text. If end_color
258 is non-null then it will be inserted after the escaped text but before
259 any quotes or ellipses.
261 Returns a pointer to the prettified text as held by dsv.
267 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
268 const STRLEN max, char const * const start_color, char const * const end_color,
271 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
274 PERL_ARGS_ASSERT_PV_PRETTY;
276 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
277 /* This won't alter the UTF-8 flag */
282 sv_catpvs(dsv, "\"");
283 else if ( flags & PERL_PV_PRETTY_LTGT )
286 if ( start_color != NULL )
287 sv_catpv(dsv, start_color);
289 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
291 if ( end_color != NULL )
292 sv_catpv(dsv, end_color);
295 sv_catpvs( dsv, "\"");
296 else if ( flags & PERL_PV_PRETTY_LTGT )
299 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
300 sv_catpvs(dsv, "...");
306 =for apidoc pv_display
310 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
312 except that an additional "\0" will be appended to the string when
313 len > cur and pv[cur] is "\0".
315 Note that the final string may be up to 7 chars longer than pvlim.
321 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
323 PERL_ARGS_ASSERT_PV_DISPLAY;
325 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
326 if (len > cur && pv[cur] == '\0')
327 sv_catpvs( dsv, "\\0");
332 Perl_sv_peek(pTHX_ SV *sv)
335 SV * const t = sv_newmortal();
345 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
346 /* detect data corruption under memory poisoning */
350 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
351 if (sv == &PL_sv_undef) {
352 sv_catpv(t, "SV_UNDEF");
353 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
354 SVs_GMG|SVs_SMG|SVs_RMG)) &&
358 else if (sv == &PL_sv_no) {
359 sv_catpv(t, "SV_NO");
360 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
361 SVs_GMG|SVs_SMG|SVs_RMG)) &&
362 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
368 else if (sv == &PL_sv_yes) {
369 sv_catpv(t, "SV_YES");
370 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
371 SVs_GMG|SVs_SMG|SVs_RMG)) &&
372 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
375 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
380 sv_catpv(t, "SV_PLACEHOLDER");
381 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
382 SVs_GMG|SVs_SMG|SVs_RMG)) &&
388 else if (SvREFCNT(sv) == 0) {
392 else if (DEBUG_R_TEST_) {
395 /* is this SV on the tmps stack? */
396 for (ix=PL_tmps_ix; ix>=0; ix--) {
397 if (PL_tmps_stack[ix] == sv) {
402 if (SvREFCNT(sv) > 1)
403 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
411 if (SvCUR(t) + unref > 10) {
412 SvCUR_set(t, unref + 3);
421 if (type == SVt_PVCV) {
422 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
424 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
425 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
428 } else if (type < SVt_LAST) {
429 sv_catpv(t, svshorttypenames[type]);
431 if (type == SVt_NULL)
434 sv_catpv(t, "FREED");
439 if (!SvPVX_const(sv))
440 sv_catpv(t, "(null)");
442 SV * const tmp = newSVpvs("");
446 SvOOK_offset(sv, delta);
447 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
449 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
451 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
452 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
454 SvREFCNT_dec_NN(tmp);
457 else if (SvNOKp(sv)) {
458 STORE_NUMERIC_LOCAL_SET_STANDARD();
459 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
460 RESTORE_NUMERIC_LOCAL();
462 else if (SvIOKp(sv)) {
464 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
466 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
474 if (TAINTING_get && SvTAINTED(sv))
475 sv_catpv(t, " [tainted]");
476 return SvPV_nolen(t);
480 =head1 Debugging Utilities
484 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
487 PERL_ARGS_ASSERT_DUMP_INDENT;
489 dump_vindent(level, file, pat, &args);
494 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
497 PERL_ARGS_ASSERT_DUMP_VINDENT;
498 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
499 PerlIO_vprintf(file, pat, *args);
505 Dumps the entire optree of the current program starting at C<PL_main_root> to
506 C<STDERR>. Also dumps the optrees for all visible subroutines in
515 dump_all_perl(FALSE);
519 Perl_dump_all_perl(pTHX_ bool justperl)
523 PerlIO_setlinebuf(Perl_debug_log);
525 op_dump(PL_main_root);
526 dump_packsubs_perl(PL_defstash, justperl);
530 =for apidoc dump_packsubs
532 Dumps the optrees for all visible subroutines in C<stash>.
538 Perl_dump_packsubs(pTHX_ const HV *stash)
540 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
541 dump_packsubs_perl(stash, FALSE);
545 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
550 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
554 for (i = 0; i <= (I32) HvMAX(stash); i++) {
556 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
557 const GV * const gv = (const GV *)HeVAL(entry);
558 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
561 dump_sub_perl(gv, justperl);
564 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
565 const HV * const hv = GvHV(gv);
566 if (hv && (hv != PL_defstash))
567 dump_packsubs_perl(hv, justperl); /* nested package */
574 Perl_dump_sub(pTHX_ const GV *gv)
576 PERL_ARGS_ASSERT_DUMP_SUB;
577 dump_sub_perl(gv, FALSE);
581 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
584 SV * const sv = newSVpvs_flags("", SVs_TEMP);
588 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
590 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
593 tmpsv = newSVpvs_flags("", SVs_TEMP);
594 gv_fullname3(sv, gv, NULL);
595 name = SvPV_const(sv, len);
596 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
597 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
598 if (CvISXSUB(GvCV(gv)))
599 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
600 PTR2UV(CvXSUB(GvCV(gv))),
601 (int)CvXSUBANY(GvCV(gv)).any_i32);
602 else if (CvROOT(GvCV(gv)))
603 op_dump(CvROOT(GvCV(gv)));
605 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
609 Perl_dump_form(pTHX_ const GV *gv)
611 SV * const sv = sv_newmortal();
613 PERL_ARGS_ASSERT_DUMP_FORM;
615 gv_fullname3(sv, gv, NULL);
616 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
617 if (CvROOT(GvFORM(gv)))
618 op_dump(CvROOT(GvFORM(gv)));
620 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
627 op_dump(PL_eval_root);
631 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
635 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
638 Perl_dump_indent(aTHX_ level, file, "{}\n");
641 Perl_dump_indent(aTHX_ level, file, "{\n");
643 if (pm->op_pmflags & PMf_ONCE)
648 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
649 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
650 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
652 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
653 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
654 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
655 op_dump(pm->op_pmreplrootu.op_pmreplroot);
657 if (pm->op_code_list) {
658 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
659 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
660 do_op_dump(level, file, pm->op_code_list);
663 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
664 PTR2UV(pm->op_code_list));
666 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
667 SV * const tmpsv = pm_description(pm);
668 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
669 SvREFCNT_dec_NN(tmpsv);
672 Perl_dump_indent(aTHX_ level-1, file, "}\n");
675 const struct flag_to_name pmflags_flags_names[] = {
676 {PMf_CONST, ",CONST"},
678 {PMf_GLOBAL, ",GLOBAL"},
679 {PMf_CONTINUE, ",CONTINUE"},
680 {PMf_RETAINT, ",RETAINT"},
682 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
683 {PMf_HAS_CV, ",HAS_CV"},
684 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
685 {PMf_IS_QR, ",IS_QR"}
689 S_pm_description(pTHX_ const PMOP *pm)
691 SV * const desc = newSVpvs("");
692 const REGEXP * const regex = PM_GETRE(pm);
693 const U32 pmflags = pm->op_pmflags;
695 PERL_ARGS_ASSERT_PM_DESCRIPTION;
697 if (pmflags & PMf_ONCE)
698 sv_catpv(desc, ",ONCE");
700 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
701 sv_catpv(desc, ":USED");
703 if (pmflags & PMf_USED)
704 sv_catpv(desc, ":USED");
708 if (RX_ISTAINTED(regex))
709 sv_catpv(desc, ",TAINTED");
710 if (RX_CHECK_SUBSTR(regex)) {
711 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
712 sv_catpv(desc, ",SCANFIRST");
713 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
714 sv_catpv(desc, ",ALL");
716 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
717 sv_catpv(desc, ",SKIPWHITE");
720 append_flags(desc, pmflags, pmflags_flags_names);
725 Perl_pmop_dump(pTHX_ PMOP *pm)
727 do_pmop_dump(0, Perl_debug_log, pm);
730 /* Return a unique integer to represent the address of op o.
731 * If it already exists in PL_op_sequence, just return it;
733 * *** Note that this isn't thread-safe */
736 S_sequence_num(pTHX_ const OP *o)
745 op = newSVuv(PTR2UV(o));
747 key = SvPV_const(op, len);
749 PL_op_sequence = newHV();
750 seq = hv_fetch(PL_op_sequence, key, len, 0);
753 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
757 const struct flag_to_name op_flags_names[] = {
759 {OPf_PARENS, ",PARENS"},
762 {OPf_STACKED, ",STACKED"},
763 {OPf_SPECIAL, ",SPECIAL"}
766 const struct flag_to_name op_trans_names[] = {
767 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
768 {OPpTRANS_TO_UTF, ",TO_UTF"},
769 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
770 {OPpTRANS_SQUASH, ",SQUASH"},
771 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
772 {OPpTRANS_GROWS, ",GROWS"},
773 {OPpTRANS_DELETE, ",DELETE"}
776 const struct flag_to_name op_entersub_names[] = {
777 {OPpENTERSUB_DB, ",DB"},
778 {OPpENTERSUB_HASTARG, ",HASTARG"},
779 {OPpENTERSUB_AMPER, ",AMPER"},
780 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
781 {OPpENTERSUB_INARGS, ",INARGS"}
784 const struct flag_to_name op_const_names[] = {
785 {OPpCONST_NOVER, ",NOVER"},
786 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
787 {OPpCONST_STRICT, ",STRICT"},
788 {OPpCONST_ENTERED, ",ENTERED"},
789 {OPpCONST_BARE, ",BARE"}
792 const struct flag_to_name op_sort_names[] = {
793 {OPpSORT_NUMERIC, ",NUMERIC"},
794 {OPpSORT_INTEGER, ",INTEGER"},
795 {OPpSORT_REVERSE, ",REVERSE"},
796 {OPpSORT_INPLACE, ",INPLACE"},
797 {OPpSORT_DESCEND, ",DESCEND"},
798 {OPpSORT_QSORT, ",QSORT"},
799 {OPpSORT_STABLE, ",STABLE"}
802 const struct flag_to_name op_open_names[] = {
803 {OPpOPEN_IN_RAW, ",IN_RAW"},
804 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
805 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
806 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
809 const struct flag_to_name op_sassign_names[] = {
810 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
811 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
814 const struct flag_to_name op_leave_names[] = {
815 {OPpREFCOUNTED, ",REFCOUNTED"},
816 {OPpLVALUE, ",LVALUE"}
819 #define OP_PRIVATE_ONCE(op, flag, name) \
820 const struct flag_to_name CAT2(op, _names)[] = { \
824 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
825 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
826 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
827 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
828 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
829 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
830 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
831 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
832 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
833 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
834 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
835 OP_PRIVATE_ONCE(op_dbstate, OPpHUSH_VMSISH, ",HUSH_VMSISH");
837 struct op_private_by_op {
840 const struct flag_to_name *start;
843 const struct op_private_by_op op_private_names[] = {
844 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
845 {OP_LEAVE, C_ARRAY_LENGTH(op_leave_names), op_leave_names },
846 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
847 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
848 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
849 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
850 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
851 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
852 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
853 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
854 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
855 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
856 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
857 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
858 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
859 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
860 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
861 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
862 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
863 {OP_DBSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names },
864 {OP_NEXTSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names },
865 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
869 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
870 const struct op_private_by_op *start = op_private_names;
871 const struct op_private_by_op *const end
872 = op_private_names + C_ARRAY_LENGTH(op_private_names);
874 /* This is a linear search, but no worse than the code that it replaced.
875 It's debugging code - size is more important than speed. */
877 if (optype == start->op_type) {
878 S_append_flags(aTHX_ tmpsv, op_private, start->start,
879 start->start + start->len);
882 } while (++start < end);
886 #define DUMP_OP_FLAGS(o,xml,level,file) \
887 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
888 SV * const tmpsv = newSVpvs(""); \
889 switch (o->op_flags & OPf_WANT) { \
890 case OPf_WANT_VOID: \
891 sv_catpv(tmpsv, ",VOID"); \
893 case OPf_WANT_SCALAR: \
894 sv_catpv(tmpsv, ",SCALAR"); \
896 case OPf_WANT_LIST: \
897 sv_catpv(tmpsv, ",LIST"); \
900 sv_catpv(tmpsv, ",UNKNOWN"); \
903 append_flags(tmpsv, o->op_flags, op_flags_names); \
904 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
905 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
906 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
907 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
909 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
910 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
912 PerlIO_printf(file, " flags=\"%s\"", \
913 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
916 #if !defined(PERL_MAD)
917 # define xmldump_attr1(level, file, pat, arg)
919 # define xmldump_attr1(level, file, pat, arg) \
920 S_xmldump_attr(aTHX_ level, file, pat, arg)
923 #define DUMP_OP_PRIVATE(o,xml,level,file) \
924 if (o->op_private) { \
925 U32 optype = o->op_type; \
926 U32 oppriv = o->op_private; \
927 SV * const tmpsv = newSVpvs(""); \
928 if (PL_opargs[optype] & OA_TARGLEX) { \
929 if (oppriv & OPpTARGET_MY) \
930 sv_catpv(tmpsv, ",TARGET_MY"); \
932 else if (optype == OP_ENTERSUB || \
933 optype == OP_RV2SV || \
934 optype == OP_GVSV || \
935 optype == OP_RV2AV || \
936 optype == OP_RV2HV || \
937 optype == OP_RV2GV || \
938 optype == OP_AELEM || \
939 optype == OP_HELEM ) \
941 if (optype == OP_ENTERSUB) { \
942 append_flags(tmpsv, oppriv, op_entersub_names); \
945 switch (oppriv & OPpDEREF) { \
947 sv_catpv(tmpsv, ",SV"); \
950 sv_catpv(tmpsv, ",AV"); \
953 sv_catpv(tmpsv, ",HV"); \
956 if (oppriv & OPpMAYBE_LVSUB) \
957 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
959 if (optype == OP_AELEM || optype == OP_HELEM) { \
960 if (oppriv & OPpLVAL_DEFER) \
961 sv_catpv(tmpsv, ",LVAL_DEFER"); \
963 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
964 if (oppriv & OPpMAYBE_TRUEBOOL) \
965 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
966 if (oppriv & OPpTRUEBOOL) \
967 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
970 if (oppriv & HINT_STRICT_REFS) \
971 sv_catpv(tmpsv, ",STRICT_REFS"); \
972 if (oppriv & OPpOUR_INTRO) \
973 sv_catpv(tmpsv, ",OUR_INTRO"); \
976 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
978 else if (OP_IS_FILETEST(o->op_type)) { \
979 if (oppriv & OPpFT_ACCESS) \
980 sv_catpv(tmpsv, ",FT_ACCESS"); \
981 if (oppriv & OPpFT_STACKED) \
982 sv_catpv(tmpsv, ",FT_STACKED"); \
983 if (oppriv & OPpFT_STACKING) \
984 sv_catpv(tmpsv, ",FT_STACKING"); \
985 if (oppriv & OPpFT_AFTER_t) \
986 sv_catpv(tmpsv, ",AFTER_t"); \
988 else if (o->op_type == OP_AASSIGN) { \
989 if (oppriv & OPpASSIGN_COMMON) \
990 sv_catpvs(tmpsv, ",COMMON"); \
991 if (oppriv & OPpMAYBE_LVSUB) \
992 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
994 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
995 sv_catpv(tmpsv, ",INTRO"); \
996 if (o->op_type == OP_PADRANGE) \
997 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
998 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
999 if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
1000 o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
1001 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \
1002 && oppriv & OPpSLICEWARNING ) \
1003 sv_catpvs(tmpsv, ",SLICEWARNING"); \
1004 if (SvCUR(tmpsv)) { \
1006 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
1008 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
1010 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
1016 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1020 const OPCODE optype = o->op_type;
1022 PERL_ARGS_ASSERT_DO_OP_DUMP;
1024 Perl_dump_indent(aTHX_ level, file, "{\n");
1026 seq = sequence_num(o);
1028 PerlIO_printf(file, "%-4"UVuf, seq);
1030 PerlIO_printf(file, "????");
1032 "%*sTYPE = %s ===> ",
1033 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
1036 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
1037 sequence_num(o->op_next));
1039 PerlIO_printf(file, "NULL\n");
1041 if (optype == OP_NULL) {
1042 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
1043 if (o->op_targ == OP_NEXTSTATE) {
1045 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1046 (UV)CopLINE(cCOPo));
1047 if (CopSTASHPV(cCOPo)) {
1048 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1049 HV *stash = CopSTASH(cCOPo);
1050 const char * const hvname = HvNAME_get(stash);
1052 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1053 generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
1055 if (CopLABEL(cCOPo)) {
1056 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1059 const char *label = CopLABEL_len_flags(cCOPo,
1062 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1063 generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
1069 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1072 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1075 DUMP_OP_FLAGS(o,0,level,file);
1076 DUMP_OP_PRIVATE(o,0,level,file);
1079 if (PL_madskills && o->op_madprop) {
1080 SV * const tmpsv = newSVpvs("");
1081 MADPROP* mp = o->op_madprop;
1082 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1085 const char tmp = mp->mad_key;
1086 sv_setpvs(tmpsv,"'");
1088 sv_catpvn(tmpsv, &tmp, 1);
1089 sv_catpv(tmpsv, "'=");
1090 switch (mp->mad_type) {
1092 sv_catpv(tmpsv, "NULL");
1093 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1096 sv_catpv(tmpsv, "<");
1097 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1098 sv_catpv(tmpsv, ">");
1099 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1102 if ((OP*)mp->mad_val) {
1103 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1104 do_op_dump(level, file, (OP*)mp->mad_val);
1108 sv_catpv(tmpsv, "(UNK)");
1109 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1115 Perl_dump_indent(aTHX_ level, file, "}\n");
1124 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1126 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1127 if (cSVOPo->op_sv) {
1130 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1131 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
1133 /* FIXME - is this making unwarranted assumptions about the
1134 UTF-8 cleanliness of the dump file handle? */
1137 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1138 name = SvPV_const(tmpsv, len);
1139 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1140 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
1143 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1149 case OP_METHOD_NAMED:
1150 #ifndef USE_ITHREADS
1151 /* with ITHREADS, consts are stored in the pad, and the right pad
1152 * may not be active here, so skip */
1153 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1159 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1160 (UV)CopLINE(cCOPo));
1161 if (CopSTASHPV(cCOPo)) {
1162 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1163 HV *stash = CopSTASH(cCOPo);
1164 const char * const hvname = HvNAME_get(stash);
1166 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1167 generic_pv_escape(tmpsv, hvname,
1168 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1170 if (CopLABEL(cCOPo)) {
1171 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1174 const char *label = CopLABEL_len_flags(cCOPo,
1175 &label_len, &label_flags);
1176 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1177 generic_pv_escape( tmpsv, label, label_len,
1178 (label_flags & SVf_UTF8)));
1182 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1183 if (cLOOPo->op_redoop)
1184 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1186 PerlIO_printf(file, "DONE\n");
1187 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1188 if (cLOOPo->op_nextop)
1189 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1191 PerlIO_printf(file, "DONE\n");
1192 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1193 if (cLOOPo->op_lastop)
1194 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1196 PerlIO_printf(file, "DONE\n");
1204 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1205 if (cLOGOPo->op_other)
1206 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1208 PerlIO_printf(file, "DONE\n");
1214 do_pmop_dump(level, file, cPMOPo);
1222 if (o->op_private & OPpREFCOUNTED)
1223 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1228 if (o->op_flags & OPf_KIDS) {
1230 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1231 do_op_dump(level, file, kid);
1233 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1239 Dumps the optree starting at OP C<o> to C<STDERR>.
1245 Perl_op_dump(pTHX_ const OP *o)
1247 PERL_ARGS_ASSERT_OP_DUMP;
1248 do_op_dump(0, Perl_debug_log, o);
1252 Perl_gv_dump(pTHX_ GV *gv)
1256 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1259 PERL_ARGS_ASSERT_GV_DUMP;
1262 PerlIO_printf(Perl_debug_log, "{}\n");
1265 sv = sv_newmortal();
1266 PerlIO_printf(Perl_debug_log, "{\n");
1267 gv_fullname3(sv, gv, NULL);
1268 name = SvPV_const(sv, len);
1269 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1270 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1271 if (gv != GvEGV(gv)) {
1272 gv_efullname3(sv, GvEGV(gv), NULL);
1273 name = SvPV_const(sv, len);
1274 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1275 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1277 PerlIO_putc(Perl_debug_log, '\n');
1278 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1282 /* map magic types to the symbolic names
1283 * (with the PERL_MAGIC_ prefixed stripped)
1286 static const struct { const char type; const char *name; } magic_names[] = {
1287 #include "mg_names.c"
1288 /* this null string terminates the list */
1293 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1295 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1297 for (; mg; mg = mg->mg_moremagic) {
1298 Perl_dump_indent(aTHX_ level, file,
1299 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1300 if (mg->mg_virtual) {
1301 const MGVTBL * const v = mg->mg_virtual;
1302 if (v >= PL_magic_vtables
1303 && v < PL_magic_vtables + magic_vtable_max) {
1304 const U32 i = v - PL_magic_vtables;
1305 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1308 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1311 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1314 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1318 const char *name = NULL;
1319 for (n = 0; magic_names[n].name; n++) {
1320 if (mg->mg_type == magic_names[n].type) {
1321 name = magic_names[n].name;
1326 Perl_dump_indent(aTHX_ level, file,
1327 " MG_TYPE = PERL_MAGIC_%s\n", name);
1329 Perl_dump_indent(aTHX_ level, file,
1330 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1334 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1335 if (mg->mg_type == PERL_MAGIC_envelem &&
1336 mg->mg_flags & MGf_TAINTEDDIR)
1337 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1338 if (mg->mg_type == PERL_MAGIC_regex_global &&
1339 mg->mg_flags & MGf_MINMATCH)
1340 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1341 if (mg->mg_flags & MGf_REFCOUNTED)
1342 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1343 if (mg->mg_flags & MGf_GSKIP)
1344 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1345 if (mg->mg_flags & MGf_COPY)
1346 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1347 if (mg->mg_flags & MGf_DUP)
1348 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1349 if (mg->mg_flags & MGf_LOCAL)
1350 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1351 if (mg->mg_type == PERL_MAGIC_regex_global &&
1352 mg->mg_flags & MGf_BYTES)
1353 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1356 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1357 PTR2UV(mg->mg_obj));
1358 if (mg->mg_type == PERL_MAGIC_qr) {
1359 REGEXP* const re = (REGEXP *)mg->mg_obj;
1360 SV * const dsv = sv_newmortal();
1361 const char * const s
1362 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1364 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1365 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1367 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1368 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1371 if (mg->mg_flags & MGf_REFCOUNTED)
1372 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1375 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1377 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1378 if (mg->mg_len >= 0) {
1379 if (mg->mg_type != PERL_MAGIC_utf8) {
1380 SV * const sv = newSVpvs("");
1381 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1382 SvREFCNT_dec_NN(sv);
1385 else if (mg->mg_len == HEf_SVKEY) {
1386 PerlIO_puts(file, " => HEf_SVKEY\n");
1387 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1388 maxnest, dumpops, pvlim); /* MG is already +1 */
1391 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1396 " does not know how to handle this MG_LEN"
1398 PerlIO_putc(file, '\n');
1400 if (mg->mg_type == PERL_MAGIC_utf8) {
1401 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1404 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1405 Perl_dump_indent(aTHX_ level, file,
1406 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1409 (UV)cache[i * 2 + 1]);
1416 Perl_magic_dump(pTHX_ const MAGIC *mg)
1418 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1422 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1426 PERL_ARGS_ASSERT_DO_HV_DUMP;
1428 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1429 if (sv && (hvname = HvNAME_get(sv)))
1431 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1432 name which quite legally could contain insane things like tabs, newlines, nulls or
1433 other scary crap - this should produce sane results - except maybe for unicode package
1434 names - but we will wait for someone to file a bug on that - demerphq */
1435 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1436 PerlIO_printf(file, "\t\"%s\"\n",
1437 generic_pv_escape( tmpsv, hvname,
1438 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1441 PerlIO_putc(file, '\n');
1445 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1447 PERL_ARGS_ASSERT_DO_GV_DUMP;
1449 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1450 if (sv && GvNAME(sv)) {
1451 SV * const tmpsv = newSVpvs("");
1452 PerlIO_printf(file, "\t\"%s\"\n",
1453 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1456 PerlIO_putc(file, '\n');
1460 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1462 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1464 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1465 if (sv && GvNAME(sv)) {
1466 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1468 HV * const stash = GvSTASH(sv);
1469 PerlIO_printf(file, "\t");
1470 /* TODO might have an extra \" here */
1471 if (stash && (hvname = HvNAME_get(stash))) {
1472 PerlIO_printf(file, "\"%s\" :: \"",
1473 generic_pv_escape(tmp, hvname,
1474 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1476 PerlIO_printf(file, "%s\"\n",
1477 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1480 PerlIO_putc(file, '\n');
1483 const struct flag_to_name first_sv_flags_names[] = {
1484 {SVs_TEMP, "TEMP,"},
1485 {SVs_OBJECT, "OBJECT,"},
1494 const struct flag_to_name second_sv_flags_names[] = {
1496 {SVf_FAKE, "FAKE,"},
1497 {SVf_READONLY, "READONLY,"},
1498 {SVf_IsCOW, "IsCOW,"},
1499 {SVf_BREAK, "BREAK,"},
1500 {SVf_AMAGIC, "OVERLOAD,"},
1506 const struct flag_to_name cv_flags_names[] = {
1507 {CVf_ANON, "ANON,"},
1508 {CVf_UNIQUE, "UNIQUE,"},
1509 {CVf_CLONE, "CLONE,"},
1510 {CVf_CLONED, "CLONED,"},
1511 {CVf_CONST, "CONST,"},
1512 {CVf_NODEBUG, "NODEBUG,"},
1513 {CVf_LVALUE, "LVALUE,"},
1514 {CVf_METHOD, "METHOD,"},
1515 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1516 {CVf_CVGV_RC, "CVGV_RC,"},
1517 {CVf_DYNFILE, "DYNFILE,"},
1518 {CVf_AUTOLOAD, "AUTOLOAD,"},
1519 {CVf_HASEVAL, "HASEVAL"},
1520 {CVf_SLABBED, "SLABBED,"},
1521 {CVf_ISXSUB, "ISXSUB,"}
1524 const struct flag_to_name hv_flags_names[] = {
1525 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1526 {SVphv_LAZYDEL, "LAZYDEL,"},
1527 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1528 {SVphv_CLONEABLE, "CLONEABLE,"}
1531 const struct flag_to_name gp_flags_names[] = {
1532 {GVf_INTRO, "INTRO,"},
1533 {GVf_MULTI, "MULTI,"},
1534 {GVf_ASSUMECV, "ASSUMECV,"},
1535 {GVf_IN_PAD, "IN_PAD,"}
1538 const struct flag_to_name gp_flags_imported_names[] = {
1539 {GVf_IMPORTED_SV, " SV"},
1540 {GVf_IMPORTED_AV, " AV"},
1541 {GVf_IMPORTED_HV, " HV"},
1542 {GVf_IMPORTED_CV, " CV"},
1545 /* NOTE: this structure is mostly duplicative of one generated by
1546 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1547 * the two. - Yves */
1548 const struct flag_to_name regexp_extflags_names[] = {
1549 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1550 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1551 {RXf_PMf_FOLD, "PMf_FOLD,"},
1552 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1553 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1554 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1555 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1556 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1557 {RXf_CHECK_ALL, "CHECK_ALL,"},
1558 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1559 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1560 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1561 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1562 {RXf_SPLIT, "SPLIT,"},
1563 {RXf_COPY_DONE, "COPY_DONE,"},
1564 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1565 {RXf_TAINTED, "TAINTED,"},
1566 {RXf_START_ONLY, "START_ONLY,"},
1567 {RXf_SKIPWHITE, "SKIPWHITE,"},
1568 {RXf_WHITE, "WHITE,"},
1569 {RXf_NULL, "NULL,"},
1572 /* NOTE: this structure is mostly duplicative of one generated by
1573 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1574 * the two. - Yves */
1575 const struct flag_to_name regexp_core_intflags_names[] = {
1576 {PREGf_SKIP, "SKIP,"},
1577 {PREGf_IMPLICIT, "IMPLICIT,"},
1578 {PREGf_NAUGHTY, "NAUGHTY,"},
1579 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1580 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1581 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1582 {PREGf_NOSCAN, "NOSCAN,"},
1583 {PREGf_CANY_SEEN, "CANY_SEEN,"},
1584 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1585 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1586 {PREGf_ANCH_BOL, "ANCH_BOL,"},
1587 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1588 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1589 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1593 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1601 PERL_ARGS_ASSERT_DO_SV_DUMP;
1604 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1608 flags = SvFLAGS(sv);
1611 /* process general SV flags */
1613 d = Perl_newSVpvf(aTHX_
1614 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1615 PTR2UV(SvANY(sv)), PTR2UV(sv),
1616 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1617 (int)(PL_dumpindent*level), "");
1619 if (!((flags & SVpad_NAME) == SVpad_NAME
1620 && (type == SVt_PVMG || type == SVt_PVNV))) {
1621 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1622 sv_catpv(d, "PADSTALE,");
1624 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1625 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1626 sv_catpv(d, "PADTMP,");
1627 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1629 append_flags(d, flags, first_sv_flags_names);
1630 if (flags & SVf_ROK) {
1631 sv_catpv(d, "ROK,");
1632 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1634 append_flags(d, flags, second_sv_flags_names);
1635 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1636 && type != SVt_PVAV) {
1637 if (SvPCS_IMPORTED(sv))
1638 sv_catpv(d, "PCS_IMPORTED,");
1640 sv_catpv(d, "SCREAM,");
1643 /* process type-specific SV flags */
1648 append_flags(d, CvFLAGS(sv), cv_flags_names);
1651 append_flags(d, flags, hv_flags_names);
1655 if (isGV_with_GP(sv)) {
1656 append_flags(d, GvFLAGS(sv), gp_flags_names);
1658 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1659 sv_catpv(d, "IMPORT");
1660 if (GvIMPORTED(sv) == GVf_IMPORTED)
1661 sv_catpv(d, "ALL,");
1664 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1671 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1672 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1675 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1676 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1677 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1678 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1681 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1684 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1687 /* SVphv_SHAREKEYS is also 0x20000000 */
1688 if ((type != SVt_PVHV) && SvUTF8(sv))
1689 sv_catpv(d, "UTF8");
1691 if (*(SvEND(d) - 1) == ',') {
1692 SvCUR_set(d, SvCUR(d) - 1);
1693 SvPVX(d)[SvCUR(d)] = '\0';
1698 /* dump initial SV details */
1700 #ifdef DEBUG_LEAKING_SCALARS
1701 Perl_dump_indent(aTHX_ level, file,
1702 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1703 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1705 sv->sv_debug_inpad ? "for" : "by",
1706 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1707 PTR2UV(sv->sv_debug_parent),
1711 Perl_dump_indent(aTHX_ level, file, "SV = ");
1715 if (type < SVt_LAST) {
1716 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1718 if (type == SVt_NULL) {
1723 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1728 /* Dump general SV fields */
1730 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1731 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1732 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1733 || (type == SVt_IV && !SvROK(sv))) {
1735 #ifdef PERL_OLD_COPY_ON_WRITE
1739 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1741 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1742 #ifdef PERL_OLD_COPY_ON_WRITE
1743 if (SvIsCOW_shared_hash(sv))
1744 PerlIO_printf(file, " (HASH)");
1745 else if (SvIsCOW_normal(sv))
1746 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1748 PerlIO_putc(file, '\n');
1751 if ((type == SVt_PVNV || type == SVt_PVMG)
1752 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1753 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1754 (UV) COP_SEQ_RANGE_LOW(sv));
1755 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1756 (UV) COP_SEQ_RANGE_HIGH(sv));
1757 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1758 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1759 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1760 || type == SVt_NV) {
1761 STORE_NUMERIC_LOCAL_SET_STANDARD();
1762 /* %Vg doesn't work? --jhi */
1763 #ifdef USE_LONG_DOUBLE
1764 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1766 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1768 RESTORE_NUMERIC_LOCAL();
1772 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1774 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1777 if (type < SVt_PV) {
1782 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1783 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1784 const bool re = isREGEXP(sv);
1785 const char * const ptr =
1786 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1790 SvOOK_offset(sv, delta);
1791 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1796 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1798 PerlIO_printf(file, "( %s . ) ",
1799 pv_display(d, ptr - delta, delta, 0,
1802 if (type == SVt_INVLIST) {
1803 PerlIO_printf(file, "\n");
1804 /* 4 blanks indents 2 beyond the PV, etc */
1805 _invlist_dump(file, level, " ", sv);
1808 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1811 if (SvUTF8(sv)) /* the 6? \x{....} */
1812 PerlIO_printf(file, " [UTF8 \"%s\"]",
1813 sv_uni_display(d, sv, 6 * SvCUR(sv),
1815 PerlIO_printf(file, "\n");
1817 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1819 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1821 #ifdef PERL_NEW_COPY_ON_WRITE
1822 if (SvIsCOW(sv) && SvLEN(sv))
1823 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1828 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1831 if (type >= SVt_PVMG) {
1832 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1833 HV * const ost = SvOURSTASH(sv);
1835 do_hv_dump(level, file, " OURSTASH", ost);
1836 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1837 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1838 (UV)PadnamelistMAXNAMED(sv));
1841 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1844 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1846 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1847 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1851 /* Dump type-specific SV fields */
1855 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1856 if (AvARRAY(sv) != AvALLOC(sv)) {
1857 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1858 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1861 PerlIO_putc(file, '\n');
1862 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1863 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1864 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1866 if (!AvPAD_NAMELIST(sv))
1867 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1868 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
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 && av_len(MUTABLE_AV(sv)) >= 0) {
1876 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1877 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1879 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1881 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1886 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1887 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1888 /* Show distribution of HEs in the ARRAY */
1890 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1893 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1894 NV theoret, sum = 0;
1896 PerlIO_printf(file, " (");
1897 Zero(freq, FREQ_MAX + 1, int);
1898 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1901 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1903 if (count > FREQ_MAX)
1909 for (i = 0; i <= max; i++) {
1911 PerlIO_printf(file, "%d%s:%d", i,
1912 (i == FREQ_MAX) ? "+" : "",
1915 PerlIO_printf(file, ", ");
1918 PerlIO_putc(file, ')');
1919 /* The "quality" of a hash is defined as the total number of
1920 comparisons needed to access every element once, relative
1921 to the expected number needed for a random hash.
1923 The total number of comparisons is equal to the sum of
1924 the squares of the number of entries in each bucket.
1925 For a random hash of n keys into k buckets, the expected
1930 for (i = max; i > 0; i--) { /* Precision: count down. */
1931 sum += freq[i] * i * i;
1933 while ((keys = keys >> 1))
1935 theoret = HvUSEDKEYS(sv);
1936 theoret += theoret * (theoret-1)/pow2;
1937 PerlIO_putc(file, '\n');
1938 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1940 PerlIO_putc(file, '\n');
1941 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1944 HE **ents = HvARRAY(sv);
1947 HE *const *const last = ents + HvMAX(sv);
1948 count = last + 1 - ents;
1953 } while (++ents <= last);
1957 struct xpvhv_aux *const aux = HvAUX(sv);
1958 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1959 " (cached = %"UVuf")\n",
1960 (UV)count, (UV)aux->xhv_fill_lazy);
1962 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1966 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1968 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1969 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1970 #ifdef PERL_HASH_RANDOMIZE_KEYS
1971 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1972 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1973 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1976 PerlIO_putc(file, '\n');
1979 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1980 if (mg && mg->mg_obj) {
1981 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1985 const char * const hvname = HvNAME_get(sv);
1987 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1988 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1989 generic_pv_escape( tmpsv, hvname,
1990 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1995 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1996 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1997 if (HvAUX(sv)->xhv_name_count)
1998 Perl_dump_indent(aTHX_
1999 level, file, " NAMECOUNT = %"IVdf"\n",
2000 (IV)HvAUX(sv)->xhv_name_count
2002 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2003 const I32 count = HvAUX(sv)->xhv_name_count;
2005 SV * const names = newSVpvs_flags("", SVs_TEMP);
2006 /* The starting point is the first element if count is
2007 positive and the second element if count is negative. */
2008 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2009 + (count < 0 ? 1 : 0);
2010 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2011 + (count < 0 ? -count : count);
2012 while (hekp < endp) {
2013 if (HEK_LEN(*hekp)) {
2014 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2015 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2016 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2018 /* This should never happen. */
2019 sv_catpvs(names, ", (null)");
2023 Perl_dump_indent(aTHX_
2024 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2028 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2029 const char *const hvename = HvENAME_get(sv);
2030 Perl_dump_indent(aTHX_
2031 level, file, " ENAME = \"%s\"\n",
2032 generic_pv_escape(tmp, hvename,
2033 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
2039 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2043 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2044 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
2045 generic_pv_escape( tmpsv, meta->mro_which->name,
2046 meta->mro_which->length,
2047 (meta->mro_which->kflags & HVhek_UTF8)),
2048 PTR2UV(meta->mro_which));
2049 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
2050 (UV)meta->cache_gen);
2051 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
2053 if (meta->mro_linear_all) {
2054 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
2055 PTR2UV(meta->mro_linear_all));
2056 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2059 if (meta->mro_linear_current) {
2060 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
2061 PTR2UV(meta->mro_linear_current));
2062 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2065 if (meta->mro_nextmethod) {
2066 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
2067 PTR2UV(meta->mro_nextmethod));
2068 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2072 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
2074 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2079 if (nest < maxnest) {
2080 HV * const hv = MUTABLE_HV(sv);
2085 int count = maxnest - nest;
2086 for (i=0; i <= HvMAX(hv); i++) {
2087 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2094 if (count-- <= 0) goto DONEHV;
2097 keysv = hv_iterkeysv(he);
2098 keypv = SvPV_const(keysv, len);
2101 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2103 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2104 if (HvEITER_get(hv) == he)
2105 PerlIO_printf(file, "[CURRENT] ");
2106 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
2107 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2116 if (CvAUTOLOAD(sv)) {
2117 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2119 const char *const name = SvPV_const(sv, len);
2120 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2121 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2124 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2125 const char *const proto = CvPROTO(sv);
2126 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2127 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2132 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2133 if (!CvISXSUB(sv)) {
2135 Perl_dump_indent(aTHX_ level, file,
2136 " START = 0x%"UVxf" ===> %"IVdf"\n",
2137 PTR2UV(CvSTART(sv)),
2138 (IV)sequence_num(CvSTART(sv)));
2140 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2141 PTR2UV(CvROOT(sv)));
2142 if (CvROOT(sv) && dumpops) {
2143 do_op_dump(level+1, file, CvROOT(sv));
2146 SV * const constant = cv_const_sv((const CV *)sv);
2148 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2151 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2153 PTR2UV(CvXSUBANY(sv).any_ptr));
2154 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2157 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2158 (IV)CvXSUBANY(sv).any_i32);
2162 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2163 HEK_KEY(CvNAME_HEK((CV *)sv)));
2164 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2165 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2166 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2167 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2168 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2169 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2170 if (nest < maxnest) {
2171 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2174 const CV * const outside = CvOUTSIDE(sv);
2175 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2178 : CvANON(outside) ? "ANON"
2179 : (outside == PL_main_cv) ? "MAIN"
2180 : CvUNIQUE(outside) ? "UNIQUE"
2183 newSVpvs_flags("", SVs_TEMP),
2184 GvNAME(CvGV(outside)),
2185 GvNAMELEN(CvGV(outside)),
2186 GvNAMEUTF8(CvGV(outside)))
2189 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2190 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2195 if (type == SVt_PVLV) {
2196 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2197 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2198 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2199 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2200 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2201 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2202 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2205 if (isREGEXP(sv)) goto dumpregexp;
2206 if (!isGV_with_GP(sv))
2209 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2210 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2211 generic_pv_escape(tmpsv, GvNAME(sv),
2215 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2216 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2217 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2220 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2221 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2222 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2223 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2224 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2225 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2226 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2227 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2228 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2229 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2230 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2231 do_gv_dump (level, file, " EGV", GvEGV(sv));
2234 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2235 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2236 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2237 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2238 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2239 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2240 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2242 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2243 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2244 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2246 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2247 PTR2UV(IoTOP_GV(sv)));
2248 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2249 maxnest, dumpops, pvlim);
2251 /* Source filters hide things that are not GVs in these three, so let's
2252 be careful out there. */
2254 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2255 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2256 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2258 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2259 PTR2UV(IoFMT_GV(sv)));
2260 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2261 maxnest, dumpops, pvlim);
2263 if (IoBOTTOM_NAME(sv))
2264 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2265 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2266 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2268 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2269 PTR2UV(IoBOTTOM_GV(sv)));
2270 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2271 maxnest, dumpops, pvlim);
2273 if (isPRINT(IoTYPE(sv)))
2274 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2276 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2277 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2282 struct regexp * const r = ReANY((REGEXP*)sv);
2284 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2286 append_flags(d, flags, names); \
2287 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2288 SvCUR_set(d, SvCUR(d) - 1); \
2289 SvPVX(d)[SvCUR(d)] = '\0'; \
2292 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2293 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2294 (UV)(r->compflags), SvPVX_const(d));
2296 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2297 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2298 (UV)(r->extflags), SvPVX_const(d));
2300 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2301 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2302 if (r->engine == &PL_core_reg_engine) {
2303 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2304 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2305 (UV)(r->intflags), SvPVX_const(d));
2307 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2310 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2311 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2313 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2314 (UV)(r->lastparen));
2315 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2316 (UV)(r->lastcloseparen));
2317 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2319 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2320 (IV)(r->minlenret));
2321 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2323 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2324 (UV)(r->pre_prefix));
2325 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2327 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2328 (IV)(r->suboffset));
2329 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2330 (IV)(r->subcoffset));
2332 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2334 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2336 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2337 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2338 PTR2UV(r->mother_re));
2339 if (nest < maxnest && r->mother_re)
2340 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2341 maxnest, dumpops, pvlim);
2342 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2343 PTR2UV(r->paren_names));
2344 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2345 PTR2UV(r->substrs));
2346 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2347 PTR2UV(r->pprivate));
2348 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2350 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2351 PTR2UV(r->qr_anoncv));
2353 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2354 PTR2UV(r->saved_copy));
2365 Dumps the contents of an SV to the C<STDERR> filehandle.
2367 For an example of its output, see L<Devel::Peek>.
2373 Perl_sv_dump(pTHX_ SV *sv)
2377 PERL_ARGS_ASSERT_SV_DUMP;
2380 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2382 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2386 Perl_runops_debug(pTHX)
2390 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2394 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2396 #ifdef PERL_TRACE_OPS
2397 ++PL_op_exec_cnt[PL_op->op_type];
2400 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2401 PerlIO_printf(Perl_debug_log,
2402 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2403 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2404 PTR2UV(*PL_watchaddr));
2405 if (DEBUG_s_TEST_) {
2406 if (DEBUG_v_TEST_) {
2407 PerlIO_printf(Perl_debug_log, "\n");
2415 if (DEBUG_t_TEST_) debop(PL_op);
2416 if (DEBUG_P_TEST_) debprof(PL_op);
2419 OP_ENTRY_PROBE(OP_NAME(PL_op));
2420 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2421 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2429 Perl_debop(pTHX_ const OP *o)
2433 PERL_ARGS_ASSERT_DEBOP;
2435 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2438 Perl_deb(aTHX_ "%s", OP_NAME(o));
2439 switch (o->op_type) {
2442 /* With ITHREADS, consts are stored in the pad, and the right pad
2443 * may not be active here, so check.
2444 * Looks like only during compiling the pads are illegal.
2447 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2449 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2454 SV * const sv = newSV(0);
2456 /* FIXME - is this making unwarranted assumptions about the
2457 UTF-8 cleanliness of the dump file handle? */
2460 gv_fullname3(sv, cGVOPo_gv, NULL);
2461 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2462 SvREFCNT_dec_NN(sv);
2465 PerlIO_printf(Perl_debug_log, "(NULL)");
2477 count = o->op_private & OPpPADRANGE_COUNTMASK;
2479 /* print the lexical's name */
2481 CV * const cv = deb_curcv(cxstack_ix);
2483 PAD * comppad = NULL;
2487 PADLIST * const padlist = CvPADLIST(cv);
2488 comppad = *PadlistARRAY(padlist);
2490 PerlIO_printf(Perl_debug_log, "(");
2491 for (i = 0; i < count; i++) {
2493 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2494 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2496 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2499 PerlIO_printf(Perl_debug_log, ",");
2501 PerlIO_printf(Perl_debug_log, ")");
2509 PerlIO_printf(Perl_debug_log, "\n");
2514 S_deb_curcv(pTHX_ const I32 ix)
2517 const PERL_CONTEXT * const cx = &cxstack[ix];
2518 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2519 return cx->blk_sub.cv;
2520 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2521 return cx->blk_eval.cv;
2522 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2527 return deb_curcv(ix - 1);
2531 Perl_watch(pTHX_ char **addr)
2535 PERL_ARGS_ASSERT_WATCH;
2537 PL_watchaddr = addr;
2539 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2540 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2544 S_debprof(pTHX_ const OP *o)
2548 PERL_ARGS_ASSERT_DEBPROF;
2550 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2552 if (!PL_profiledata)
2553 Newxz(PL_profiledata, MAXO, U32);
2554 ++PL_profiledata[o->op_type];
2558 Perl_debprofdump(pTHX)
2562 if (!PL_profiledata)
2564 for (i = 0; i < MAXO; i++) {
2565 if (PL_profiledata[i])
2566 PerlIO_printf(Perl_debug_log,
2567 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2574 * XML variants of most of the above routines
2578 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2582 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2584 PerlIO_printf(file, "\n ");
2585 va_start(args, pat);
2586 xmldump_vindent(level, file, pat, &args);
2592 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2595 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2596 va_start(args, pat);
2597 xmldump_vindent(level, file, pat, &args);
2602 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2604 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2606 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2607 PerlIO_vprintf(file, pat, *args);
2611 Perl_xmldump_all(pTHX)
2613 xmldump_all_perl(FALSE);
2617 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2619 PerlIO_setlinebuf(PL_xmlfp);
2621 op_xmldump(PL_main_root);
2622 /* someday we might call this, when it outputs XML: */
2623 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2624 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2625 PerlIO_close(PL_xmlfp);
2630 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2632 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2633 xmldump_packsubs_perl(stash, FALSE);
2637 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2642 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2644 if (!HvARRAY(stash))
2646 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2647 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2648 GV *gv = MUTABLE_GV(HeVAL(entry));
2650 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2653 xmldump_sub_perl(gv, justperl);
2656 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2657 && (hv = GvHV(gv)) && hv != PL_defstash)
2658 xmldump_packsubs_perl(hv, justperl); /* nested package */
2664 Perl_xmldump_sub(pTHX_ const GV *gv)
2666 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2667 xmldump_sub_perl(gv, FALSE);
2671 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2675 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2677 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2680 sv = sv_newmortal();
2681 gv_fullname3(sv, gv, NULL);
2682 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2683 if (CvXSUB(GvCV(gv)))
2684 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2685 PTR2UV(CvXSUB(GvCV(gv))),
2686 (int)CvXSUBANY(GvCV(gv)).any_i32);
2687 else if (CvROOT(GvCV(gv)))
2688 op_xmldump(CvROOT(GvCV(gv)));
2690 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2694 Perl_xmldump_form(pTHX_ const GV *gv)
2696 SV * const sv = sv_newmortal();
2698 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2700 gv_fullname3(sv, gv, NULL);
2701 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2702 if (CvROOT(GvFORM(gv)))
2703 op_xmldump(CvROOT(GvFORM(gv)));
2705 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2709 Perl_xmldump_eval(pTHX)
2711 op_xmldump(PL_eval_root);
2715 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2717 PERL_ARGS_ASSERT_SV_CATXMLSV;
2718 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2722 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2724 PERL_ARGS_ASSERT_SV_CATXMLPV;
2725 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2729 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2732 const char * const e = pv + len;
2733 const char * const start = pv;
2737 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2740 dsvcur = SvCUR(dsv); /* in case we have to restart */
2745 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2747 SvCUR(dsv) = dsvcur;
2760 && c != LATIN1_TO_NATIVE(0x85))
2762 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2766 sv_catpvs(dsv, "<");
2769 sv_catpvs(dsv, ">");
2772 sv_catpvs(dsv, "&");
2775 sv_catpvs(dsv, """);
2780 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2783 const char string = (char) c;
2784 sv_catpvn(dsv, &string, 1);
2788 if ((c >= 0xD800 && c <= 0xDB7F) ||
2789 (c >= 0xDC00 && c <= 0xDFFF) ||
2790 (c >= 0xFFF0 && c <= 0xFFFF) ||
2792 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2794 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2807 Perl_sv_xmlpeek(pTHX_ SV *sv)
2809 SV * const t = sv_newmortal();
2813 PERL_ARGS_ASSERT_SV_XMLPEEK;
2819 sv_catpv(t, "VOID=\"\"");
2822 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2823 sv_catpv(t, "WILD=\"\"");
2826 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2827 if (sv == &PL_sv_undef) {
2828 sv_catpv(t, "SV_UNDEF=\"1\"");
2829 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2830 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2834 else if (sv == &PL_sv_no) {
2835 sv_catpv(t, "SV_NO=\"1\"");
2836 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2837 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2838 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2839 SVp_POK|SVp_NOK)) &&
2844 else if (sv == &PL_sv_yes) {
2845 sv_catpv(t, "SV_YES=\"1\"");
2846 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2847 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2848 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2849 SVp_POK|SVp_NOK)) &&
2851 SvPVX(sv) && *SvPVX(sv) == '1' &&
2856 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2857 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2858 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2862 sv_catpv(t, " XXX=\"\" ");
2864 else if (SvREFCNT(sv) == 0) {
2865 sv_catpv(t, " refcnt=\"0\"");
2868 else if (DEBUG_R_TEST_) {
2871 /* is this SV on the tmps stack? */
2872 for (ix=PL_tmps_ix; ix>=0; ix--) {
2873 if (PL_tmps_stack[ix] == sv) {
2878 if (SvREFCNT(sv) > 1)
2879 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2882 sv_catpv(t, " DRT=\"<T>\"");
2886 sv_catpv(t, " ROK=\"\"");
2888 switch (SvTYPE(sv)) {
2890 sv_catpv(t, " FREED=\"1\"");
2894 sv_catpv(t, " UNDEF=\"1\"");
2897 sv_catpv(t, " IV=\"");
2900 sv_catpv(t, " NV=\"");
2903 sv_catpv(t, " PV=\"");
2906 sv_catpv(t, " PVIV=\"");
2909 sv_catpv(t, " PVNV=\"");
2912 sv_catpv(t, " PVMG=\"");
2915 sv_catpv(t, " PVLV=\"");
2918 sv_catpv(t, " AV=\"");
2921 sv_catpv(t, " HV=\"");
2925 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2927 sv_catpv(t, " CV=\"()\"");
2930 sv_catpv(t, " GV=\"");
2933 sv_catpv(t, " DUMMY=\"");
2936 sv_catpv(t, " REGEXP=\"");
2939 sv_catpv(t, " FM=\"");
2942 sv_catpv(t, " IO=\"");
2951 else if (SvNOKp(sv)) {
2952 STORE_NUMERIC_LOCAL_SET_STANDARD();
2953 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2954 RESTORE_NUMERIC_LOCAL();
2956 else if (SvIOKp(sv)) {
2958 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2960 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2969 return SvPV(t, n_a);
2973 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2975 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2978 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2981 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2984 REGEXP *const r = PM_GETRE(pm);
2985 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2986 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2987 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2989 SvREFCNT_dec_NN(tmpsv);
2990 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2991 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2994 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2995 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2996 SV * const tmpsv = pm_description(pm);
2997 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2998 SvREFCNT_dec_NN(tmpsv);
3002 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3003 Perl_xmldump_indent(aTHX_ level, file, ">\n");
3004 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
3005 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3006 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
3007 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
3010 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
3014 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
3016 do_pmop_xmldump(0, PL_xmlfp, pm);
3020 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
3024 const OPCODE optype = o->op_type;
3026 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
3030 seq = sequence_num(o);
3031 Perl_xmldump_indent(aTHX_ level, file,
3032 "<op_%s seq=\"%"UVuf" -> ",
3037 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
3038 sequence_num(o->op_next));
3040 PerlIO_printf(file, "DONE\"");
3043 if (optype == OP_NULL)
3045 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
3046 if (o->op_targ == OP_NEXTSTATE)
3049 PerlIO_printf(file, " line=\"%"UVuf"\"",
3050 (UV)CopLINE(cCOPo));
3051 if (CopSTASHPV(cCOPo))
3052 PerlIO_printf(file, " package=\"%s\"",
3054 if (CopLABEL(cCOPo))
3055 PerlIO_printf(file, " label=\"%s\"",
3060 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
3063 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
3066 DUMP_OP_FLAGS(o,1,0,file);
3067 DUMP_OP_PRIVATE(o,1,0,file);
3071 if (o->op_flags & OPf_SPECIAL) {
3077 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3079 if (cSVOPo->op_sv) {
3080 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3081 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3087 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3088 s = SvPV(tmpsv1,len);
3089 sv_catxmlpvn(tmpsv2, s, len, 1);
3090 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3094 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3099 case OP_METHOD_NAMED:
3100 #ifndef USE_ITHREADS
3101 /* with ITHREADS, consts are stored in the pad, and the right pad
3102 * may not be active here, so skip */
3103 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3109 PerlIO_printf(file, ">\n");
3111 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3116 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3117 (UV)CopLINE(cCOPo));
3118 if (CopSTASHPV(cCOPo))
3119 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3121 if (CopLABEL(cCOPo))
3122 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3126 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3127 if (cLOOPo->op_redoop)
3128 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3130 PerlIO_printf(file, "DONE\"");
3131 S_xmldump_attr(aTHX_ level, file, "next=\"");
3132 if (cLOOPo->op_nextop)
3133 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3135 PerlIO_printf(file, "DONE\"");
3136 S_xmldump_attr(aTHX_ level, file, "last=\"");
3137 if (cLOOPo->op_lastop)
3138 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3140 PerlIO_printf(file, "DONE\"");
3148 S_xmldump_attr(aTHX_ level, file, "other=\"");
3149 if (cLOGOPo->op_other)
3150 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3152 PerlIO_printf(file, "DONE\"");
3160 if (o->op_private & OPpREFCOUNTED)
3161 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3167 if (PL_madskills && o->op_madprop) {
3168 char prevkey = '\0';
3169 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3170 const MADPROP* mp = o->op_madprop;
3174 PerlIO_printf(file, ">\n");
3176 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3179 char tmp = mp->mad_key;
3180 sv_setpvs(tmpsv,"\"");
3182 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3183 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3184 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3187 sv_catpv(tmpsv, "\"");
3188 switch (mp->mad_type) {
3190 sv_catpv(tmpsv, "NULL");
3191 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3194 sv_catpv(tmpsv, " val=\"");
3195 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3196 sv_catpv(tmpsv, "\"");
3197 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3200 sv_catpv(tmpsv, " val=\"");
3201 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3202 sv_catpv(tmpsv, "\"");
3203 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3206 if ((OP*)mp->mad_val) {
3207 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3208 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3209 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3213 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3219 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3221 SvREFCNT_dec_NN(tmpsv);
3231 PerlIO_printf(file, ">\n");
3233 do_pmop_xmldump(level, file, cPMOPo);
3239 if (o->op_flags & OPf_KIDS) {
3243 PerlIO_printf(file, ">\n");
3245 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3246 do_op_xmldump(level, file, kid);
3250 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3252 PerlIO_printf(file, " />\n");
3256 Perl_op_xmldump(pTHX_ const OP *o)
3258 PERL_ARGS_ASSERT_OP_XMLDUMP;
3260 do_op_xmldump(0, PL_xmlfp, o);
3266 * c-indentation-style: bsd
3268 * indent-tabs-mode: nil
3271 * ex: set ts=8 sts=4 sw=4 et: