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 = C_ARRAY_END(op_private_names);
873 /* This is a linear search, but no worse than the code that it replaced.
874 It's debugging code - size is more important than speed. */
876 if (optype == start->op_type) {
877 S_append_flags(aTHX_ tmpsv, op_private, start->start,
878 start->start + start->len);
881 } while (++start < end);
885 #define DUMP_OP_FLAGS(o,xml,level,file) \
886 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
887 SV * const tmpsv = newSVpvs(""); \
888 switch (o->op_flags & OPf_WANT) { \
889 case OPf_WANT_VOID: \
890 sv_catpv(tmpsv, ",VOID"); \
892 case OPf_WANT_SCALAR: \
893 sv_catpv(tmpsv, ",SCALAR"); \
895 case OPf_WANT_LIST: \
896 sv_catpv(tmpsv, ",LIST"); \
899 sv_catpv(tmpsv, ",UNKNOWN"); \
902 append_flags(tmpsv, o->op_flags, op_flags_names); \
903 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
904 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
905 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
906 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
908 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
909 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
911 PerlIO_printf(file, " flags=\"%s\"", \
912 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
915 #if !defined(PERL_MAD)
916 # define xmldump_attr1(level, file, pat, arg)
918 # define xmldump_attr1(level, file, pat, arg) \
919 S_xmldump_attr(aTHX_ level, file, pat, arg)
922 #define DUMP_OP_PRIVATE(o,xml,level,file) \
923 if (o->op_private) { \
924 U32 optype = o->op_type; \
925 U32 oppriv = o->op_private; \
926 SV * const tmpsv = newSVpvs(""); \
927 if (PL_opargs[optype] & OA_TARGLEX) { \
928 if (oppriv & OPpTARGET_MY) \
929 sv_catpv(tmpsv, ",TARGET_MY"); \
931 else if (optype == OP_ENTERSUB || \
932 optype == OP_RV2SV || \
933 optype == OP_GVSV || \
934 optype == OP_RV2AV || \
935 optype == OP_RV2HV || \
936 optype == OP_RV2GV || \
937 optype == OP_AELEM || \
938 optype == OP_HELEM ) \
940 if (optype == OP_ENTERSUB) { \
941 append_flags(tmpsv, oppriv, op_entersub_names); \
944 switch (oppriv & OPpDEREF) { \
946 sv_catpv(tmpsv, ",SV"); \
949 sv_catpv(tmpsv, ",AV"); \
952 sv_catpv(tmpsv, ",HV"); \
955 if (oppriv & OPpMAYBE_LVSUB) \
956 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
958 if (optype == OP_AELEM || optype == OP_HELEM) { \
959 if (oppriv & OPpLVAL_DEFER) \
960 sv_catpv(tmpsv, ",LVAL_DEFER"); \
962 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
963 if (oppriv & OPpMAYBE_TRUEBOOL) \
964 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
965 if (oppriv & OPpTRUEBOOL) \
966 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
969 if (oppriv & HINT_STRICT_REFS) \
970 sv_catpv(tmpsv, ",STRICT_REFS"); \
971 if (oppriv & OPpOUR_INTRO) \
972 sv_catpv(tmpsv, ",OUR_INTRO"); \
975 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
977 else if (OP_IS_FILETEST(o->op_type)) { \
978 if (oppriv & OPpFT_ACCESS) \
979 sv_catpv(tmpsv, ",FT_ACCESS"); \
980 if (oppriv & OPpFT_STACKED) \
981 sv_catpv(tmpsv, ",FT_STACKED"); \
982 if (oppriv & OPpFT_STACKING) \
983 sv_catpv(tmpsv, ",FT_STACKING"); \
984 if (oppriv & OPpFT_AFTER_t) \
985 sv_catpv(tmpsv, ",AFTER_t"); \
987 else if (o->op_type == OP_AASSIGN) { \
988 if (oppriv & OPpASSIGN_COMMON) \
989 sv_catpvs(tmpsv, ",COMMON"); \
990 if (oppriv & OPpMAYBE_LVSUB) \
991 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
993 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
994 sv_catpv(tmpsv, ",INTRO"); \
995 if (o->op_type == OP_PADRANGE) \
996 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
997 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
998 if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
999 o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
1000 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \
1001 && oppriv & OPpSLICEWARNING ) \
1002 sv_catpvs(tmpsv, ",SLICEWARNING"); \
1003 if (SvCUR(tmpsv)) { \
1005 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
1007 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
1009 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
1015 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1019 const OPCODE optype = o->op_type;
1021 PERL_ARGS_ASSERT_DO_OP_DUMP;
1023 Perl_dump_indent(aTHX_ level, file, "{\n");
1025 seq = sequence_num(o);
1027 PerlIO_printf(file, "%-4"UVuf, seq);
1029 PerlIO_printf(file, "????");
1031 "%*sTYPE = %s ===> ",
1032 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
1035 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
1036 sequence_num(o->op_next));
1038 PerlIO_printf(file, "NULL\n");
1040 if (optype == OP_NULL) {
1041 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
1042 if (o->op_targ == OP_NEXTSTATE) {
1044 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1045 (UV)CopLINE(cCOPo));
1046 if (CopSTASHPV(cCOPo)) {
1047 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1048 HV *stash = CopSTASH(cCOPo);
1049 const char * const hvname = HvNAME_get(stash);
1051 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1052 generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
1054 if (CopLABEL(cCOPo)) {
1055 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1058 const char *label = CopLABEL_len_flags(cCOPo,
1061 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1062 generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
1068 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1071 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1074 DUMP_OP_FLAGS(o,0,level,file);
1075 DUMP_OP_PRIVATE(o,0,level,file);
1078 if (PL_madskills && o->op_madprop) {
1079 SV * const tmpsv = newSVpvs("");
1080 MADPROP* mp = o->op_madprop;
1081 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1084 const char tmp = mp->mad_key;
1085 sv_setpvs(tmpsv,"'");
1087 sv_catpvn(tmpsv, &tmp, 1);
1088 sv_catpv(tmpsv, "'=");
1089 switch (mp->mad_type) {
1091 sv_catpv(tmpsv, "NULL");
1092 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1095 sv_catpv(tmpsv, "<");
1096 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1097 sv_catpv(tmpsv, ">");
1098 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1101 if ((OP*)mp->mad_val) {
1102 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1103 do_op_dump(level, file, (OP*)mp->mad_val);
1107 sv_catpv(tmpsv, "(UNK)");
1108 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1114 Perl_dump_indent(aTHX_ level, file, "}\n");
1123 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1125 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1126 if (cSVOPo->op_sv) {
1129 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1130 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
1132 /* FIXME - is this making unwarranted assumptions about the
1133 UTF-8 cleanliness of the dump file handle? */
1136 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1137 name = SvPV_const(tmpsv, len);
1138 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1139 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
1142 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1148 case OP_METHOD_NAMED:
1149 #ifndef USE_ITHREADS
1150 /* with ITHREADS, consts are stored in the pad, and the right pad
1151 * may not be active here, so skip */
1152 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1158 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1159 (UV)CopLINE(cCOPo));
1160 if (CopSTASHPV(cCOPo)) {
1161 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1162 HV *stash = CopSTASH(cCOPo);
1163 const char * const hvname = HvNAME_get(stash);
1165 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1166 generic_pv_escape(tmpsv, hvname,
1167 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1169 if (CopLABEL(cCOPo)) {
1170 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1173 const char *label = CopLABEL_len_flags(cCOPo,
1174 &label_len, &label_flags);
1175 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1176 generic_pv_escape( tmpsv, label, label_len,
1177 (label_flags & SVf_UTF8)));
1181 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1182 if (cLOOPo->op_redoop)
1183 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1185 PerlIO_printf(file, "DONE\n");
1186 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1187 if (cLOOPo->op_nextop)
1188 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1190 PerlIO_printf(file, "DONE\n");
1191 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1192 if (cLOOPo->op_lastop)
1193 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1195 PerlIO_printf(file, "DONE\n");
1203 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1204 if (cLOGOPo->op_other)
1205 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1207 PerlIO_printf(file, "DONE\n");
1213 do_pmop_dump(level, file, cPMOPo);
1221 if (o->op_private & OPpREFCOUNTED)
1222 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1227 if (o->op_flags & OPf_KIDS) {
1229 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1230 do_op_dump(level, file, kid);
1232 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1238 Dumps the optree starting at OP C<o> to C<STDERR>.
1244 Perl_op_dump(pTHX_ const OP *o)
1246 PERL_ARGS_ASSERT_OP_DUMP;
1247 do_op_dump(0, Perl_debug_log, o);
1251 Perl_gv_dump(pTHX_ GV *gv)
1255 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1258 PERL_ARGS_ASSERT_GV_DUMP;
1261 PerlIO_printf(Perl_debug_log, "{}\n");
1264 sv = sv_newmortal();
1265 PerlIO_printf(Perl_debug_log, "{\n");
1266 gv_fullname3(sv, gv, NULL);
1267 name = SvPV_const(sv, len);
1268 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1269 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1270 if (gv != GvEGV(gv)) {
1271 gv_efullname3(sv, GvEGV(gv), NULL);
1272 name = SvPV_const(sv, len);
1273 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1274 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1276 PerlIO_putc(Perl_debug_log, '\n');
1277 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1281 /* map magic types to the symbolic names
1282 * (with the PERL_MAGIC_ prefixed stripped)
1285 static const struct { const char type; const char *name; } magic_names[] = {
1286 #include "mg_names.c"
1287 /* this null string terminates the list */
1292 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1294 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1296 for (; mg; mg = mg->mg_moremagic) {
1297 Perl_dump_indent(aTHX_ level, file,
1298 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1299 if (mg->mg_virtual) {
1300 const MGVTBL * const v = mg->mg_virtual;
1301 if (v >= PL_magic_vtables
1302 && v < PL_magic_vtables + magic_vtable_max) {
1303 const U32 i = v - PL_magic_vtables;
1304 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1307 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1310 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1313 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1317 const char *name = NULL;
1318 for (n = 0; magic_names[n].name; n++) {
1319 if (mg->mg_type == magic_names[n].type) {
1320 name = magic_names[n].name;
1325 Perl_dump_indent(aTHX_ level, file,
1326 " MG_TYPE = PERL_MAGIC_%s\n", name);
1328 Perl_dump_indent(aTHX_ level, file,
1329 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1333 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1334 if (mg->mg_type == PERL_MAGIC_envelem &&
1335 mg->mg_flags & MGf_TAINTEDDIR)
1336 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1337 if (mg->mg_type == PERL_MAGIC_regex_global &&
1338 mg->mg_flags & MGf_MINMATCH)
1339 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1340 if (mg->mg_flags & MGf_REFCOUNTED)
1341 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1342 if (mg->mg_flags & MGf_GSKIP)
1343 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1344 if (mg->mg_flags & MGf_COPY)
1345 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1346 if (mg->mg_flags & MGf_DUP)
1347 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1348 if (mg->mg_flags & MGf_LOCAL)
1349 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1350 if (mg->mg_type == PERL_MAGIC_regex_global &&
1351 mg->mg_flags & MGf_BYTES)
1352 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1355 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1356 PTR2UV(mg->mg_obj));
1357 if (mg->mg_type == PERL_MAGIC_qr) {
1358 REGEXP* const re = (REGEXP *)mg->mg_obj;
1359 SV * const dsv = sv_newmortal();
1360 const char * const s
1361 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1363 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1364 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1366 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1367 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1370 if (mg->mg_flags & MGf_REFCOUNTED)
1371 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1374 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1376 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1377 if (mg->mg_len >= 0) {
1378 if (mg->mg_type != PERL_MAGIC_utf8) {
1379 SV * const sv = newSVpvs("");
1380 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1381 SvREFCNT_dec_NN(sv);
1384 else if (mg->mg_len == HEf_SVKEY) {
1385 PerlIO_puts(file, " => HEf_SVKEY\n");
1386 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1387 maxnest, dumpops, pvlim); /* MG is already +1 */
1390 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1395 " does not know how to handle this MG_LEN"
1397 PerlIO_putc(file, '\n');
1399 if (mg->mg_type == PERL_MAGIC_utf8) {
1400 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1403 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1404 Perl_dump_indent(aTHX_ level, file,
1405 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1408 (UV)cache[i * 2 + 1]);
1415 Perl_magic_dump(pTHX_ const MAGIC *mg)
1417 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1421 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1425 PERL_ARGS_ASSERT_DO_HV_DUMP;
1427 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1428 if (sv && (hvname = HvNAME_get(sv)))
1430 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1431 name which quite legally could contain insane things like tabs, newlines, nulls or
1432 other scary crap - this should produce sane results - except maybe for unicode package
1433 names - but we will wait for someone to file a bug on that - demerphq */
1434 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1435 PerlIO_printf(file, "\t\"%s\"\n",
1436 generic_pv_escape( tmpsv, hvname,
1437 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1440 PerlIO_putc(file, '\n');
1444 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1446 PERL_ARGS_ASSERT_DO_GV_DUMP;
1448 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1449 if (sv && GvNAME(sv)) {
1450 SV * const tmpsv = newSVpvs("");
1451 PerlIO_printf(file, "\t\"%s\"\n",
1452 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1455 PerlIO_putc(file, '\n');
1459 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1461 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1463 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1464 if (sv && GvNAME(sv)) {
1465 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1467 HV * const stash = GvSTASH(sv);
1468 PerlIO_printf(file, "\t");
1469 /* TODO might have an extra \" here */
1470 if (stash && (hvname = HvNAME_get(stash))) {
1471 PerlIO_printf(file, "\"%s\" :: \"",
1472 generic_pv_escape(tmp, hvname,
1473 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1475 PerlIO_printf(file, "%s\"\n",
1476 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1479 PerlIO_putc(file, '\n');
1482 const struct flag_to_name first_sv_flags_names[] = {
1483 {SVs_TEMP, "TEMP,"},
1484 {SVs_OBJECT, "OBJECT,"},
1493 const struct flag_to_name second_sv_flags_names[] = {
1495 {SVf_FAKE, "FAKE,"},
1496 {SVf_READONLY, "READONLY,"},
1497 {SVf_IsCOW, "IsCOW,"},
1498 {SVf_BREAK, "BREAK,"},
1499 {SVf_AMAGIC, "OVERLOAD,"},
1505 const struct flag_to_name cv_flags_names[] = {
1506 {CVf_ANON, "ANON,"},
1507 {CVf_UNIQUE, "UNIQUE,"},
1508 {CVf_CLONE, "CLONE,"},
1509 {CVf_CLONED, "CLONED,"},
1510 {CVf_CONST, "CONST,"},
1511 {CVf_NODEBUG, "NODEBUG,"},
1512 {CVf_LVALUE, "LVALUE,"},
1513 {CVf_METHOD, "METHOD,"},
1514 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1515 {CVf_CVGV_RC, "CVGV_RC,"},
1516 {CVf_DYNFILE, "DYNFILE,"},
1517 {CVf_AUTOLOAD, "AUTOLOAD,"},
1518 {CVf_HASEVAL, "HASEVAL"},
1519 {CVf_SLABBED, "SLABBED,"},
1520 {CVf_ISXSUB, "ISXSUB,"}
1523 const struct flag_to_name hv_flags_names[] = {
1524 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1525 {SVphv_LAZYDEL, "LAZYDEL,"},
1526 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1527 {SVphv_CLONEABLE, "CLONEABLE,"}
1530 const struct flag_to_name gp_flags_names[] = {
1531 {GVf_INTRO, "INTRO,"},
1532 {GVf_MULTI, "MULTI,"},
1533 {GVf_ASSUMECV, "ASSUMECV,"},
1534 {GVf_IN_PAD, "IN_PAD,"}
1537 const struct flag_to_name gp_flags_imported_names[] = {
1538 {GVf_IMPORTED_SV, " SV"},
1539 {GVf_IMPORTED_AV, " AV"},
1540 {GVf_IMPORTED_HV, " HV"},
1541 {GVf_IMPORTED_CV, " CV"},
1544 /* NOTE: this structure is mostly duplicative of one generated by
1545 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1546 * the two. - Yves */
1547 const struct flag_to_name regexp_extflags_names[] = {
1548 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1549 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1550 {RXf_PMf_FOLD, "PMf_FOLD,"},
1551 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1552 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1553 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1554 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1555 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1556 {RXf_CHECK_ALL, "CHECK_ALL,"},
1557 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1558 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1559 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1560 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1561 {RXf_SPLIT, "SPLIT,"},
1562 {RXf_COPY_DONE, "COPY_DONE,"},
1563 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1564 {RXf_TAINTED, "TAINTED,"},
1565 {RXf_START_ONLY, "START_ONLY,"},
1566 {RXf_SKIPWHITE, "SKIPWHITE,"},
1567 {RXf_WHITE, "WHITE,"},
1568 {RXf_NULL, "NULL,"},
1571 /* NOTE: this structure is mostly duplicative of one generated by
1572 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1573 * the two. - Yves */
1574 const struct flag_to_name regexp_core_intflags_names[] = {
1575 {PREGf_SKIP, "SKIP,"},
1576 {PREGf_IMPLICIT, "IMPLICIT,"},
1577 {PREGf_NAUGHTY, "NAUGHTY,"},
1578 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1579 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1580 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1581 {PREGf_NOSCAN, "NOSCAN,"},
1582 {PREGf_CANY_SEEN, "CANY_SEEN,"},
1583 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1584 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1585 {PREGf_ANCH_BOL, "ANCH_BOL,"},
1586 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1587 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1588 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1592 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1600 PERL_ARGS_ASSERT_DO_SV_DUMP;
1603 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1607 flags = SvFLAGS(sv);
1610 /* process general SV flags */
1612 d = Perl_newSVpvf(aTHX_
1613 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1614 PTR2UV(SvANY(sv)), PTR2UV(sv),
1615 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1616 (int)(PL_dumpindent*level), "");
1618 if (!((flags & SVpad_NAME) == SVpad_NAME
1619 && (type == SVt_PVMG || type == SVt_PVNV))) {
1620 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1621 sv_catpv(d, "PADSTALE,");
1623 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1624 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1625 sv_catpv(d, "PADTMP,");
1626 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1628 append_flags(d, flags, first_sv_flags_names);
1629 if (flags & SVf_ROK) {
1630 sv_catpv(d, "ROK,");
1631 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1633 append_flags(d, flags, second_sv_flags_names);
1634 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1635 && type != SVt_PVAV) {
1636 if (SvPCS_IMPORTED(sv))
1637 sv_catpv(d, "PCS_IMPORTED,");
1639 sv_catpv(d, "SCREAM,");
1642 /* process type-specific SV flags */
1647 append_flags(d, CvFLAGS(sv), cv_flags_names);
1650 append_flags(d, flags, hv_flags_names);
1654 if (isGV_with_GP(sv)) {
1655 append_flags(d, GvFLAGS(sv), gp_flags_names);
1657 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1658 sv_catpv(d, "IMPORT");
1659 if (GvIMPORTED(sv) == GVf_IMPORTED)
1660 sv_catpv(d, "ALL,");
1663 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1670 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1671 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1674 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1675 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1676 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1677 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1680 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1683 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1686 /* SVphv_SHAREKEYS is also 0x20000000 */
1687 if ((type != SVt_PVHV) && SvUTF8(sv))
1688 sv_catpv(d, "UTF8");
1690 if (*(SvEND(d) - 1) == ',') {
1691 SvCUR_set(d, SvCUR(d) - 1);
1692 SvPVX(d)[SvCUR(d)] = '\0';
1697 /* dump initial SV details */
1699 #ifdef DEBUG_LEAKING_SCALARS
1700 Perl_dump_indent(aTHX_ level, file,
1701 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1702 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1704 sv->sv_debug_inpad ? "for" : "by",
1705 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1706 PTR2UV(sv->sv_debug_parent),
1710 Perl_dump_indent(aTHX_ level, file, "SV = ");
1714 if (type < SVt_LAST) {
1715 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1717 if (type == SVt_NULL) {
1722 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1727 /* Dump general SV fields */
1729 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1730 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1731 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1732 || (type == SVt_IV && !SvROK(sv))) {
1734 #ifdef PERL_OLD_COPY_ON_WRITE
1738 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1740 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1741 #ifdef PERL_OLD_COPY_ON_WRITE
1742 if (SvIsCOW_shared_hash(sv))
1743 PerlIO_printf(file, " (HASH)");
1744 else if (SvIsCOW_normal(sv))
1745 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1747 PerlIO_putc(file, '\n');
1750 if ((type == SVt_PVNV || type == SVt_PVMG)
1751 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1752 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1753 (UV) COP_SEQ_RANGE_LOW(sv));
1754 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1755 (UV) COP_SEQ_RANGE_HIGH(sv));
1756 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1757 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1758 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1759 || type == SVt_NV) {
1760 STORE_NUMERIC_LOCAL_SET_STANDARD();
1761 /* %Vg doesn't work? --jhi */
1762 #ifdef USE_LONG_DOUBLE
1763 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1765 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1767 RESTORE_NUMERIC_LOCAL();
1771 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1773 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1776 if (type < SVt_PV) {
1781 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1782 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1783 const bool re = isREGEXP(sv);
1784 const char * const ptr =
1785 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1789 SvOOK_offset(sv, delta);
1790 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1795 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1797 PerlIO_printf(file, "( %s . ) ",
1798 pv_display(d, ptr - delta, delta, 0,
1801 if (type == SVt_INVLIST) {
1802 PerlIO_printf(file, "\n");
1803 /* 4 blanks indents 2 beyond the PV, etc */
1804 _invlist_dump(file, level, " ", sv);
1807 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1810 if (SvUTF8(sv)) /* the 6? \x{....} */
1811 PerlIO_printf(file, " [UTF8 \"%s\"]",
1812 sv_uni_display(d, sv, 6 * SvCUR(sv),
1814 PerlIO_printf(file, "\n");
1816 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1818 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1820 #ifdef PERL_NEW_COPY_ON_WRITE
1821 if (SvIsCOW(sv) && SvLEN(sv))
1822 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1827 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1830 if (type >= SVt_PVMG) {
1831 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1832 HV * const ost = SvOURSTASH(sv);
1834 do_hv_dump(level, file, " OURSTASH", ost);
1835 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1836 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1837 (UV)PadnamelistMAXNAMED(sv));
1840 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1843 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1845 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1846 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1850 /* Dump type-specific SV fields */
1854 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1855 if (AvARRAY(sv) != AvALLOC(sv)) {
1856 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1857 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1860 PerlIO_putc(file, '\n');
1861 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1862 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1863 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1865 if (!AvPAD_NAMELIST(sv))
1866 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1867 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1869 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1870 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1871 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1872 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1873 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1875 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1876 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1878 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1880 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1887 struct xpvhv_aux *const aux = HvAUX(sv);
1888 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1889 (UV)aux->xhv_aux_flags);
1891 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1892 usedkeys = HvUSEDKEYS(sv);
1893 if (HvARRAY(sv) && usedkeys) {
1894 /* Show distribution of HEs in the ARRAY */
1896 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1899 U32 pow2 = 2, keys = usedkeys;
1900 NV theoret, sum = 0;
1902 PerlIO_printf(file, " (");
1903 Zero(freq, FREQ_MAX + 1, int);
1904 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1907 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1909 if (count > FREQ_MAX)
1915 for (i = 0; i <= max; i++) {
1917 PerlIO_printf(file, "%d%s:%d", i,
1918 (i == FREQ_MAX) ? "+" : "",
1921 PerlIO_printf(file, ", ");
1924 PerlIO_putc(file, ')');
1925 /* The "quality" of a hash is defined as the total number of
1926 comparisons needed to access every element once, relative
1927 to the expected number needed for a random hash.
1929 The total number of comparisons is equal to the sum of
1930 the squares of the number of entries in each bucket.
1931 For a random hash of n keys into k buckets, the expected
1936 for (i = max; i > 0; i--) { /* Precision: count down. */
1937 sum += freq[i] * i * i;
1939 while ((keys = keys >> 1))
1942 theoret += theoret * (theoret-1)/pow2;
1943 PerlIO_putc(file, '\n');
1944 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1946 PerlIO_putc(file, '\n');
1947 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
1950 HE **ents = HvARRAY(sv);
1953 HE *const *const last = ents + HvMAX(sv);
1954 count = last + 1 - ents;
1959 } while (++ents <= last);
1963 struct xpvhv_aux *const aux = HvAUX(sv);
1964 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1965 " (cached = %"UVuf")\n",
1966 (UV)count, (UV)aux->xhv_fill_lazy);
1968 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1972 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1974 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1975 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1976 #ifdef PERL_HASH_RANDOMIZE_KEYS
1977 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1978 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1979 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1982 PerlIO_putc(file, '\n');
1985 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1986 if (mg && mg->mg_obj) {
1987 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1991 const char * const hvname = HvNAME_get(sv);
1993 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1994 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1995 generic_pv_escape( tmpsv, hvname,
1996 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2001 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2002 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2003 if (HvAUX(sv)->xhv_name_count)
2004 Perl_dump_indent(aTHX_
2005 level, file, " NAMECOUNT = %"IVdf"\n",
2006 (IV)HvAUX(sv)->xhv_name_count
2008 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2009 const I32 count = HvAUX(sv)->xhv_name_count;
2011 SV * const names = newSVpvs_flags("", SVs_TEMP);
2012 /* The starting point is the first element if count is
2013 positive and the second element if count is negative. */
2014 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2015 + (count < 0 ? 1 : 0);
2016 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2017 + (count < 0 ? -count : count);
2018 while (hekp < endp) {
2019 if (HEK_LEN(*hekp)) {
2020 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2021 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2022 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2024 /* This should never happen. */
2025 sv_catpvs(names, ", (null)");
2029 Perl_dump_indent(aTHX_
2030 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2034 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2035 const char *const hvename = HvENAME_get(sv);
2036 Perl_dump_indent(aTHX_
2037 level, file, " ENAME = \"%s\"\n",
2038 generic_pv_escape(tmp, hvename,
2039 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
2045 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2049 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2050 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
2051 generic_pv_escape( tmpsv, meta->mro_which->name,
2052 meta->mro_which->length,
2053 (meta->mro_which->kflags & HVhek_UTF8)),
2054 PTR2UV(meta->mro_which));
2055 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
2056 (UV)meta->cache_gen);
2057 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
2059 if (meta->mro_linear_all) {
2060 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
2061 PTR2UV(meta->mro_linear_all));
2062 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2065 if (meta->mro_linear_current) {
2066 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
2067 PTR2UV(meta->mro_linear_current));
2068 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2071 if (meta->mro_nextmethod) {
2072 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
2073 PTR2UV(meta->mro_nextmethod));
2074 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2078 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
2080 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2085 if (nest < maxnest) {
2086 HV * const hv = MUTABLE_HV(sv);
2091 int count = maxnest - nest;
2092 for (i=0; i <= HvMAX(hv); i++) {
2093 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2100 if (count-- <= 0) goto DONEHV;
2103 keysv = hv_iterkeysv(he);
2104 keypv = SvPV_const(keysv, len);
2107 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2109 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2110 if (HvEITER_get(hv) == he)
2111 PerlIO_printf(file, "[CURRENT] ");
2112 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
2113 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2120 } /* case SVt_PVHV */
2123 if (CvAUTOLOAD(sv)) {
2124 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2126 const char *const name = SvPV_const(sv, len);
2127 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2128 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2131 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2132 const char *const proto = CvPROTO(sv);
2133 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2134 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2139 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2140 if (!CvISXSUB(sv)) {
2142 Perl_dump_indent(aTHX_ level, file,
2143 " START = 0x%"UVxf" ===> %"IVdf"\n",
2144 PTR2UV(CvSTART(sv)),
2145 (IV)sequence_num(CvSTART(sv)));
2147 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2148 PTR2UV(CvROOT(sv)));
2149 if (CvROOT(sv) && dumpops) {
2150 do_op_dump(level+1, file, CvROOT(sv));
2153 SV * const constant = cv_const_sv((const CV *)sv);
2155 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2158 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2160 PTR2UV(CvXSUBANY(sv).any_ptr));
2161 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2164 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2165 (IV)CvXSUBANY(sv).any_i32);
2169 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2170 HEK_KEY(CvNAME_HEK((CV *)sv)));
2171 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2172 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2173 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2174 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2175 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2176 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2177 if (nest < maxnest) {
2178 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2181 const CV * const outside = CvOUTSIDE(sv);
2182 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2185 : CvANON(outside) ? "ANON"
2186 : (outside == PL_main_cv) ? "MAIN"
2187 : CvUNIQUE(outside) ? "UNIQUE"
2190 newSVpvs_flags("", SVs_TEMP),
2191 GvNAME(CvGV(outside)),
2192 GvNAMELEN(CvGV(outside)),
2193 GvNAMEUTF8(CvGV(outside)))
2196 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2197 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2202 if (type == SVt_PVLV) {
2203 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2204 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2205 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2206 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2207 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2208 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2209 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2212 if (isREGEXP(sv)) goto dumpregexp;
2213 if (!isGV_with_GP(sv))
2216 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2217 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2218 generic_pv_escape(tmpsv, GvNAME(sv),
2222 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2223 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2224 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2227 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2228 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2229 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2230 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2231 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2232 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2233 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2234 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2235 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2236 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2237 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2238 do_gv_dump (level, file, " EGV", GvEGV(sv));
2241 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2242 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2243 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2244 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2245 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2246 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2247 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2249 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2250 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2251 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2253 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2254 PTR2UV(IoTOP_GV(sv)));
2255 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2256 maxnest, dumpops, pvlim);
2258 /* Source filters hide things that are not GVs in these three, so let's
2259 be careful out there. */
2261 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2262 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2263 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2265 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2266 PTR2UV(IoFMT_GV(sv)));
2267 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2268 maxnest, dumpops, pvlim);
2270 if (IoBOTTOM_NAME(sv))
2271 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2272 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2273 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2275 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2276 PTR2UV(IoBOTTOM_GV(sv)));
2277 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2278 maxnest, dumpops, pvlim);
2280 if (isPRINT(IoTYPE(sv)))
2281 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2283 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2284 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2289 struct regexp * const r = ReANY((REGEXP*)sv);
2291 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2293 append_flags(d, flags, names); \
2294 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2295 SvCUR_set(d, SvCUR(d) - 1); \
2296 SvPVX(d)[SvCUR(d)] = '\0'; \
2299 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2300 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2301 (UV)(r->compflags), SvPVX_const(d));
2303 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2304 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2305 (UV)(r->extflags), SvPVX_const(d));
2307 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2308 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2309 if (r->engine == &PL_core_reg_engine) {
2310 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2311 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2312 (UV)(r->intflags), SvPVX_const(d));
2314 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2317 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2318 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2320 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2321 (UV)(r->lastparen));
2322 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2323 (UV)(r->lastcloseparen));
2324 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2326 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2327 (IV)(r->minlenret));
2328 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2330 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2331 (UV)(r->pre_prefix));
2332 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2334 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2335 (IV)(r->suboffset));
2336 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2337 (IV)(r->subcoffset));
2339 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2341 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2343 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2344 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2345 PTR2UV(r->mother_re));
2346 if (nest < maxnest && r->mother_re)
2347 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2348 maxnest, dumpops, pvlim);
2349 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2350 PTR2UV(r->paren_names));
2351 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2352 PTR2UV(r->substrs));
2353 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2354 PTR2UV(r->pprivate));
2355 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2357 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2358 PTR2UV(r->qr_anoncv));
2360 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2361 PTR2UV(r->saved_copy));
2372 Dumps the contents of an SV to the C<STDERR> filehandle.
2374 For an example of its output, see L<Devel::Peek>.
2380 Perl_sv_dump(pTHX_ SV *sv)
2384 PERL_ARGS_ASSERT_SV_DUMP;
2387 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2389 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2393 Perl_runops_debug(pTHX)
2397 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2401 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2403 #ifdef PERL_TRACE_OPS
2404 ++PL_op_exec_cnt[PL_op->op_type];
2407 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2408 PerlIO_printf(Perl_debug_log,
2409 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2410 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2411 PTR2UV(*PL_watchaddr));
2412 if (DEBUG_s_TEST_) {
2413 if (DEBUG_v_TEST_) {
2414 PerlIO_printf(Perl_debug_log, "\n");
2422 if (DEBUG_t_TEST_) debop(PL_op);
2423 if (DEBUG_P_TEST_) debprof(PL_op);
2426 OP_ENTRY_PROBE(OP_NAME(PL_op));
2427 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2428 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2436 Perl_debop(pTHX_ const OP *o)
2440 PERL_ARGS_ASSERT_DEBOP;
2442 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2445 Perl_deb(aTHX_ "%s", OP_NAME(o));
2446 switch (o->op_type) {
2449 /* With ITHREADS, consts are stored in the pad, and the right pad
2450 * may not be active here, so check.
2451 * Looks like only during compiling the pads are illegal.
2454 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2456 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2461 SV * const sv = newSV(0);
2463 /* FIXME - is this making unwarranted assumptions about the
2464 UTF-8 cleanliness of the dump file handle? */
2467 gv_fullname3(sv, cGVOPo_gv, NULL);
2468 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2469 SvREFCNT_dec_NN(sv);
2472 PerlIO_printf(Perl_debug_log, "(NULL)");
2484 count = o->op_private & OPpPADRANGE_COUNTMASK;
2486 /* print the lexical's name */
2488 CV * const cv = deb_curcv(cxstack_ix);
2490 PAD * comppad = NULL;
2494 PADLIST * const padlist = CvPADLIST(cv);
2495 comppad = *PadlistARRAY(padlist);
2497 PerlIO_printf(Perl_debug_log, "(");
2498 for (i = 0; i < count; i++) {
2500 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2501 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2503 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2506 PerlIO_printf(Perl_debug_log, ",");
2508 PerlIO_printf(Perl_debug_log, ")");
2516 PerlIO_printf(Perl_debug_log, "\n");
2521 S_deb_curcv(pTHX_ const I32 ix)
2524 const PERL_CONTEXT * const cx = &cxstack[ix];
2525 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2526 return cx->blk_sub.cv;
2527 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2528 return cx->blk_eval.cv;
2529 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2534 return deb_curcv(ix - 1);
2538 Perl_watch(pTHX_ char **addr)
2542 PERL_ARGS_ASSERT_WATCH;
2544 PL_watchaddr = addr;
2546 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2547 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2551 S_debprof(pTHX_ const OP *o)
2555 PERL_ARGS_ASSERT_DEBPROF;
2557 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2559 if (!PL_profiledata)
2560 Newxz(PL_profiledata, MAXO, U32);
2561 ++PL_profiledata[o->op_type];
2565 Perl_debprofdump(pTHX)
2569 if (!PL_profiledata)
2571 for (i = 0; i < MAXO; i++) {
2572 if (PL_profiledata[i])
2573 PerlIO_printf(Perl_debug_log,
2574 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2581 * XML variants of most of the above routines
2585 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2589 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2591 PerlIO_printf(file, "\n ");
2592 va_start(args, pat);
2593 xmldump_vindent(level, file, pat, &args);
2599 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2602 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2603 va_start(args, pat);
2604 xmldump_vindent(level, file, pat, &args);
2609 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2611 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2613 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2614 PerlIO_vprintf(file, pat, *args);
2618 Perl_xmldump_all(pTHX)
2620 xmldump_all_perl(FALSE);
2624 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2626 PerlIO_setlinebuf(PL_xmlfp);
2628 op_xmldump(PL_main_root);
2629 /* someday we might call this, when it outputs XML: */
2630 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2631 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2632 PerlIO_close(PL_xmlfp);
2637 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2639 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2640 xmldump_packsubs_perl(stash, FALSE);
2644 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2649 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2651 if (!HvARRAY(stash))
2653 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2654 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2655 GV *gv = MUTABLE_GV(HeVAL(entry));
2657 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2660 xmldump_sub_perl(gv, justperl);
2663 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2664 && (hv = GvHV(gv)) && hv != PL_defstash)
2665 xmldump_packsubs_perl(hv, justperl); /* nested package */
2671 Perl_xmldump_sub(pTHX_ const GV *gv)
2673 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2674 xmldump_sub_perl(gv, FALSE);
2678 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2682 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2684 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2687 sv = sv_newmortal();
2688 gv_fullname3(sv, gv, NULL);
2689 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2690 if (CvXSUB(GvCV(gv)))
2691 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2692 PTR2UV(CvXSUB(GvCV(gv))),
2693 (int)CvXSUBANY(GvCV(gv)).any_i32);
2694 else if (CvROOT(GvCV(gv)))
2695 op_xmldump(CvROOT(GvCV(gv)));
2697 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2701 Perl_xmldump_form(pTHX_ const GV *gv)
2703 SV * const sv = sv_newmortal();
2705 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2707 gv_fullname3(sv, gv, NULL);
2708 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2709 if (CvROOT(GvFORM(gv)))
2710 op_xmldump(CvROOT(GvFORM(gv)));
2712 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2716 Perl_xmldump_eval(pTHX)
2718 op_xmldump(PL_eval_root);
2722 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2724 PERL_ARGS_ASSERT_SV_CATXMLSV;
2725 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2729 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2731 PERL_ARGS_ASSERT_SV_CATXMLPV;
2732 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2736 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2739 const char * const e = pv + len;
2740 const char * const start = pv;
2744 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2747 dsvcur = SvCUR(dsv); /* in case we have to restart */
2752 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2754 SvCUR(dsv) = dsvcur;
2767 && c != LATIN1_TO_NATIVE(0x85))
2769 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2773 sv_catpvs(dsv, "<");
2776 sv_catpvs(dsv, ">");
2779 sv_catpvs(dsv, "&");
2782 sv_catpvs(dsv, """);
2787 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2790 const char string = (char) c;
2791 sv_catpvn(dsv, &string, 1);
2795 if ((c >= 0xD800 && c <= 0xDB7F) ||
2796 (c >= 0xDC00 && c <= 0xDFFF) ||
2797 (c >= 0xFFF0 && c <= 0xFFFF) ||
2799 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2801 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2814 Perl_sv_xmlpeek(pTHX_ SV *sv)
2816 SV * const t = sv_newmortal();
2820 PERL_ARGS_ASSERT_SV_XMLPEEK;
2826 sv_catpv(t, "VOID=\"\"");
2829 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2830 sv_catpv(t, "WILD=\"\"");
2833 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2834 if (sv == &PL_sv_undef) {
2835 sv_catpv(t, "SV_UNDEF=\"1\"");
2836 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2837 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2841 else if (sv == &PL_sv_no) {
2842 sv_catpv(t, "SV_NO=\"1\"");
2843 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2844 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2845 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2846 SVp_POK|SVp_NOK)) &&
2851 else if (sv == &PL_sv_yes) {
2852 sv_catpv(t, "SV_YES=\"1\"");
2853 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2854 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2855 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2856 SVp_POK|SVp_NOK)) &&
2858 SvPVX(sv) && *SvPVX(sv) == '1' &&
2863 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2864 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2865 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2869 sv_catpv(t, " XXX=\"\" ");
2871 else if (SvREFCNT(sv) == 0) {
2872 sv_catpv(t, " refcnt=\"0\"");
2875 else if (DEBUG_R_TEST_) {
2878 /* is this SV on the tmps stack? */
2879 for (ix=PL_tmps_ix; ix>=0; ix--) {
2880 if (PL_tmps_stack[ix] == sv) {
2885 if (SvREFCNT(sv) > 1)
2886 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2889 sv_catpv(t, " DRT=\"<T>\"");
2893 sv_catpv(t, " ROK=\"\"");
2895 switch (SvTYPE(sv)) {
2897 sv_catpv(t, " FREED=\"1\"");
2901 sv_catpv(t, " UNDEF=\"1\"");
2904 sv_catpv(t, " IV=\"");
2907 sv_catpv(t, " NV=\"");
2910 sv_catpv(t, " PV=\"");
2913 sv_catpv(t, " PVIV=\"");
2916 sv_catpv(t, " PVNV=\"");
2919 sv_catpv(t, " PVMG=\"");
2922 sv_catpv(t, " PVLV=\"");
2925 sv_catpv(t, " AV=\"");
2928 sv_catpv(t, " HV=\"");
2932 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2934 sv_catpv(t, " CV=\"()\"");
2937 sv_catpv(t, " GV=\"");
2940 sv_catpv(t, " DUMMY=\"");
2943 sv_catpv(t, " REGEXP=\"");
2946 sv_catpv(t, " FM=\"");
2949 sv_catpv(t, " IO=\"");
2958 else if (SvNOKp(sv)) {
2959 STORE_NUMERIC_LOCAL_SET_STANDARD();
2960 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2961 RESTORE_NUMERIC_LOCAL();
2963 else if (SvIOKp(sv)) {
2965 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2967 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2976 return SvPV(t, n_a);
2980 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2982 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2985 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2988 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2991 REGEXP *const r = PM_GETRE(pm);
2992 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2993 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2994 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2996 SvREFCNT_dec_NN(tmpsv);
2997 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2998 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
3001 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
3002 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3003 SV * const tmpsv = pm_description(pm);
3004 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
3005 SvREFCNT_dec_NN(tmpsv);
3009 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3010 Perl_xmldump_indent(aTHX_ level, file, ">\n");
3011 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
3012 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3013 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
3014 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
3017 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
3021 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
3023 do_pmop_xmldump(0, PL_xmlfp, pm);
3027 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
3031 const OPCODE optype = o->op_type;
3033 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
3037 seq = sequence_num(o);
3038 Perl_xmldump_indent(aTHX_ level, file,
3039 "<op_%s seq=\"%"UVuf" -> ",
3044 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
3045 sequence_num(o->op_next));
3047 PerlIO_printf(file, "DONE\"");
3050 if (optype == OP_NULL)
3052 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
3053 if (o->op_targ == OP_NEXTSTATE)
3056 PerlIO_printf(file, " line=\"%"UVuf"\"",
3057 (UV)CopLINE(cCOPo));
3058 if (CopSTASHPV(cCOPo))
3059 PerlIO_printf(file, " package=\"%s\"",
3061 if (CopLABEL(cCOPo))
3062 PerlIO_printf(file, " label=\"%s\"",
3067 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
3070 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
3073 DUMP_OP_FLAGS(o,1,0,file);
3074 DUMP_OP_PRIVATE(o,1,0,file);
3078 if (o->op_flags & OPf_SPECIAL) {
3084 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3086 if (cSVOPo->op_sv) {
3087 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3088 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3094 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3095 s = SvPV(tmpsv1,len);
3096 sv_catxmlpvn(tmpsv2, s, len, 1);
3097 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3101 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3106 case OP_METHOD_NAMED:
3107 #ifndef USE_ITHREADS
3108 /* with ITHREADS, consts are stored in the pad, and the right pad
3109 * may not be active here, so skip */
3110 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3116 PerlIO_printf(file, ">\n");
3118 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3123 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3124 (UV)CopLINE(cCOPo));
3125 if (CopSTASHPV(cCOPo))
3126 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3128 if (CopLABEL(cCOPo))
3129 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3133 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3134 if (cLOOPo->op_redoop)
3135 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3137 PerlIO_printf(file, "DONE\"");
3138 S_xmldump_attr(aTHX_ level, file, "next=\"");
3139 if (cLOOPo->op_nextop)
3140 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3142 PerlIO_printf(file, "DONE\"");
3143 S_xmldump_attr(aTHX_ level, file, "last=\"");
3144 if (cLOOPo->op_lastop)
3145 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3147 PerlIO_printf(file, "DONE\"");
3155 S_xmldump_attr(aTHX_ level, file, "other=\"");
3156 if (cLOGOPo->op_other)
3157 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3159 PerlIO_printf(file, "DONE\"");
3167 if (o->op_private & OPpREFCOUNTED)
3168 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3174 if (PL_madskills && o->op_madprop) {
3175 char prevkey = '\0';
3176 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3177 const MADPROP* mp = o->op_madprop;
3181 PerlIO_printf(file, ">\n");
3183 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3186 char tmp = mp->mad_key;
3187 sv_setpvs(tmpsv,"\"");
3189 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3190 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3191 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3194 sv_catpv(tmpsv, "\"");
3195 switch (mp->mad_type) {
3197 sv_catpv(tmpsv, "NULL");
3198 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3201 sv_catpv(tmpsv, " val=\"");
3202 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3203 sv_catpv(tmpsv, "\"");
3204 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3207 sv_catpv(tmpsv, " val=\"");
3208 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3209 sv_catpv(tmpsv, "\"");
3210 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3213 if ((OP*)mp->mad_val) {
3214 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3215 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3216 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3220 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3226 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3228 SvREFCNT_dec_NN(tmpsv);
3238 PerlIO_printf(file, ">\n");
3240 do_pmop_xmldump(level, file, cPMOPo);
3246 if (o->op_flags & OPf_KIDS) {
3250 PerlIO_printf(file, ">\n");
3252 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3253 do_op_xmldump(level, file, kid);
3257 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3259 PerlIO_printf(file, " />\n");
3263 Perl_op_xmldump(pTHX_ const OP *o)
3265 PERL_ARGS_ASSERT_OP_XMLDUMP;
3267 do_op_xmldump(0, PL_xmlfp, o);
3273 * c-indentation-style: bsd
3275 * indent-tabs-mode: nil
3278 * ex: set ts=8 sts=4 sw=4 et: