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
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
92 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
95 PERL_ARGS_ASSERT_DUMP_INDENT;
97 dump_vindent(level, file, pat, &args);
102 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
105 PERL_ARGS_ASSERT_DUMP_VINDENT;
106 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
107 PerlIO_vprintf(file, pat, *args);
113 dump_all_perl(FALSE);
117 Perl_dump_all_perl(pTHX_ bool justperl)
121 PerlIO_setlinebuf(Perl_debug_log);
123 op_dump(PL_main_root);
124 dump_packsubs_perl(PL_defstash, justperl);
128 Perl_dump_packsubs(pTHX_ const HV *stash)
130 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
131 dump_packsubs_perl(stash, FALSE);
135 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
140 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
144 for (i = 0; i <= (I32) HvMAX(stash); i++) {
146 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
147 const GV * const gv = (const GV *)HeVAL(entry);
148 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
151 dump_sub_perl(gv, justperl);
154 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
155 const HV * const hv = GvHV(gv);
156 if (hv && (hv != PL_defstash))
157 dump_packsubs_perl(hv, justperl); /* nested package */
164 Perl_dump_sub(pTHX_ const GV *gv)
166 PERL_ARGS_ASSERT_DUMP_SUB;
167 dump_sub_perl(gv, FALSE);
171 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
175 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
177 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
181 gv_fullname3(sv, gv, NULL);
182 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
183 if (CvISXSUB(GvCV(gv)))
184 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
185 PTR2UV(CvXSUB(GvCV(gv))),
186 (int)CvXSUBANY(GvCV(gv)).any_i32);
187 else if (CvROOT(GvCV(gv)))
188 op_dump(CvROOT(GvCV(gv)));
190 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
194 Perl_dump_form(pTHX_ const GV *gv)
196 SV * const sv = sv_newmortal();
198 PERL_ARGS_ASSERT_DUMP_FORM;
200 gv_fullname3(sv, gv, NULL);
201 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
202 if (CvROOT(GvFORM(gv)))
203 op_dump(CvROOT(GvFORM(gv)));
205 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
212 op_dump(PL_eval_root);
217 =for apidoc pv_escape
219 Escapes at most the first "count" chars of pv and puts the results into
220 dsv such that the size of the escaped string will not exceed "max" chars
221 and will not contain any incomplete escape sequences.
223 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
224 will also be escaped.
226 Normally the SV will be cleared before the escaped string is prepared,
227 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
229 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
230 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
231 using C<is_utf8_string()> to determine if it is Unicode.
233 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
234 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
235 chars above 127 will be escaped using this style; otherwise, only chars above
236 255 will be so escaped; other non printable chars will use octal or
237 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardless of max. If the output is to be in hex,
243 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a hex value.
247 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
248 not a '\\'. This is because regexes very often contain backslashed
249 sequences, whereas '%' is not a particularly common character in patterns.
251 Returns a pointer to the escaped text as held by dsv.
255 #define PV_ESCAPE_OCTBUFSIZE 32
258 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
259 const STRLEN count, const STRLEN max,
260 STRLEN * const escaped, const U32 flags )
262 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
263 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
264 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
265 STRLEN wrote = 0; /* chars written so far */
266 STRLEN chsize = 0; /* size of data to be written */
267 STRLEN readsize = 1; /* size of data just read */
268 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
269 const char *pv = str;
270 const char * const end = pv + count; /* end of string */
273 PERL_ARGS_ASSERT_PV_ESCAPE;
275 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
276 /* This won't alter the UTF-8 flag */
280 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
283 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
284 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
285 const U8 c = (U8)u & 0xFF;
288 || (flags & PERL_PV_ESCAPE_ALL)
289 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
291 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
292 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
295 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 "%cx{%"UVxf"}", esc, u);
297 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
300 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
304 case '\\' : /* fallthrough */
305 case '%' : if ( c == esc ) {
311 case '\v' : octbuf[1] = 'v'; break;
312 case '\t' : octbuf[1] = 't'; break;
313 case '\r' : octbuf[1] = 'r'; break;
314 case '\n' : octbuf[1] = 'n'; break;
315 case '\f' : octbuf[1] = 'f'; break;
323 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
324 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
327 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
334 if ( max && (wrote + chsize > max) ) {
336 } else if (chsize > 1) {
337 sv_catpvn(dsv, octbuf, chsize);
340 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
341 128-255 can be appended raw to the dsv. If dsv happens to be
342 UTF-8 then we need catpvf to upgrade them for us.
343 Or add a new API call sv_catpvc(). Think about that name, and
344 how to keep it clear that it's unlike the s of catpvs, which is
345 really an array octets, not a string. */
346 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
349 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
357 =for apidoc pv_pretty
359 Converts a string into something presentable, handling escaping via
360 pv_escape() and supporting quoting and ellipses.
362 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
363 double quoted with any double quotes in the string escaped. Otherwise
364 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
367 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
368 string were output then an ellipsis C<...> will be appended to the
369 string. Note that this happens AFTER it has been quoted.
371 If start_color is non-null then it will be inserted after the opening
372 quote (if there is one) but before the escaped text. If end_color
373 is non-null then it will be inserted after the escaped text but before
374 any quotes or ellipses.
376 Returns a pointer to the prettified text as held by dsv.
382 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
383 const STRLEN max, char const * const start_color, char const * const end_color,
386 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
389 PERL_ARGS_ASSERT_PV_PRETTY;
391 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
392 /* This won't alter the UTF-8 flag */
397 sv_catpvs(dsv, "\"");
398 else if ( flags & PERL_PV_PRETTY_LTGT )
401 if ( start_color != NULL )
402 sv_catpv(dsv, start_color);
404 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
406 if ( end_color != NULL )
407 sv_catpv(dsv, end_color);
410 sv_catpvs( dsv, "\"");
411 else if ( flags & PERL_PV_PRETTY_LTGT )
414 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
415 sv_catpvs(dsv, "...");
421 =for apidoc pv_display
425 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
427 except that an additional "\0" will be appended to the string when
428 len > cur and pv[cur] is "\0".
430 Note that the final string may be up to 7 chars longer than pvlim.
436 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
438 PERL_ARGS_ASSERT_PV_DISPLAY;
440 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
441 if (len > cur && pv[cur] == '\0')
442 sv_catpvs( dsv, "\\0");
447 Perl_sv_peek(pTHX_ SV *sv)
450 SV * const t = sv_newmortal();
460 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
464 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
465 if (sv == &PL_sv_undef) {
466 sv_catpv(t, "SV_UNDEF");
467 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
468 SVs_GMG|SVs_SMG|SVs_RMG)) &&
472 else if (sv == &PL_sv_no) {
473 sv_catpv(t, "SV_NO");
474 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
475 SVs_GMG|SVs_SMG|SVs_RMG)) &&
476 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
482 else if (sv == &PL_sv_yes) {
483 sv_catpv(t, "SV_YES");
484 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
486 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
489 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
494 sv_catpv(t, "SV_PLACEHOLDER");
495 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
496 SVs_GMG|SVs_SMG|SVs_RMG)) &&
502 else if (SvREFCNT(sv) == 0) {
506 else if (DEBUG_R_TEST_) {
509 /* is this SV on the tmps stack? */
510 for (ix=PL_tmps_ix; ix>=0; ix--) {
511 if (PL_tmps_stack[ix] == sv) {
516 if (SvREFCNT(sv) > 1)
517 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
525 if (SvCUR(t) + unref > 10) {
526 SvCUR_set(t, unref + 3);
535 if (type == SVt_PVCV) {
536 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
538 } else if (type < SVt_LAST) {
539 sv_catpv(t, svshorttypenames[type]);
541 if (type == SVt_NULL)
544 sv_catpv(t, "FREED");
549 if (!SvPVX_const(sv))
550 sv_catpv(t, "(null)");
552 SV * const tmp = newSVpvs("");
556 SvOOK_offset(sv, delta);
557 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
559 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
561 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
562 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
567 else if (SvNOKp(sv)) {
568 STORE_NUMERIC_LOCAL_SET_STANDARD();
569 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
570 RESTORE_NUMERIC_LOCAL();
572 else if (SvIOKp(sv)) {
574 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
576 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
584 if (TAINTING_get && SvTAINTED(sv))
585 sv_catpv(t, " [tainted]");
586 return SvPV_nolen(t);
590 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
594 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
597 Perl_dump_indent(aTHX_ level, file, "{}\n");
600 Perl_dump_indent(aTHX_ level, file, "{\n");
602 if (pm->op_pmflags & PMf_ONCE)
607 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
608 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
609 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
611 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
612 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
613 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
614 op_dump(pm->op_pmreplrootu.op_pmreplroot);
616 if (pm->op_code_list) {
617 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
618 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
619 do_op_dump(level, file, pm->op_code_list);
622 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
623 PTR2UV(pm->op_code_list));
625 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
626 SV * const tmpsv = pm_description(pm);
627 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
631 Perl_dump_indent(aTHX_ level-1, file, "}\n");
634 const struct flag_to_name pmflags_flags_names[] = {
635 {PMf_CONST, ",CONST"},
637 {PMf_GLOBAL, ",GLOBAL"},
638 {PMf_CONTINUE, ",CONTINUE"},
639 {PMf_RETAINT, ",RETAINT"},
641 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
642 {PMf_HAS_CV, ",HAS_CV"},
643 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
644 {PMf_IS_QR, ",IS_QR"}
648 S_pm_description(pTHX_ const PMOP *pm)
650 SV * const desc = newSVpvs("");
651 const REGEXP * const regex = PM_GETRE(pm);
652 const U32 pmflags = pm->op_pmflags;
654 PERL_ARGS_ASSERT_PM_DESCRIPTION;
656 if (pmflags & PMf_ONCE)
657 sv_catpv(desc, ",ONCE");
659 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
660 sv_catpv(desc, ":USED");
662 if (pmflags & PMf_USED)
663 sv_catpv(desc, ":USED");
667 if (RX_ISTAINTED(regex))
668 sv_catpv(desc, ",TAINTED");
669 if (RX_CHECK_SUBSTR(regex)) {
670 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
671 sv_catpv(desc, ",SCANFIRST");
672 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
673 sv_catpv(desc, ",ALL");
677 append_flags(desc, pmflags, pmflags_flags_names);
682 Perl_pmop_dump(pTHX_ PMOP *pm)
684 do_pmop_dump(0, Perl_debug_log, pm);
687 /* Return a unique integer to represent the address of op o.
688 * If it already exists in PL_op_sequence, just return it;
690 * *** Note that this isn't thread-safe */
693 S_sequence_num(pTHX_ const OP *o)
702 op = newSVuv(PTR2UV(o));
704 key = SvPV_const(op, len);
706 PL_op_sequence = newHV();
707 seq = hv_fetch(PL_op_sequence, key, len, 0);
710 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
714 const struct flag_to_name op_flags_names[] = {
716 {OPf_PARENS, ",PARENS"},
719 {OPf_STACKED, ",STACKED"},
720 {OPf_SPECIAL, ",SPECIAL"}
723 const struct flag_to_name op_trans_names[] = {
724 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
725 {OPpTRANS_TO_UTF, ",TO_UTF"},
726 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
727 {OPpTRANS_SQUASH, ",SQUASH"},
728 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
729 {OPpTRANS_GROWS, ",GROWS"},
730 {OPpTRANS_DELETE, ",DELETE"}
733 const struct flag_to_name op_entersub_names[] = {
734 {OPpENTERSUB_DB, ",DB"},
735 {OPpENTERSUB_HASTARG, ",HASTARG"},
736 {OPpENTERSUB_AMPER, ",AMPER"},
737 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
738 {OPpENTERSUB_INARGS, ",INARGS"}
741 const struct flag_to_name op_const_names[] = {
742 {OPpCONST_NOVER, ",NOVER"},
743 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
744 {OPpCONST_STRICT, ",STRICT"},
745 {OPpCONST_ENTERED, ",ENTERED"},
746 {OPpCONST_FOLDED, ",FOLDED"},
747 {OPpCONST_BARE, ",BARE"}
750 const struct flag_to_name op_sort_names[] = {
751 {OPpSORT_NUMERIC, ",NUMERIC"},
752 {OPpSORT_INTEGER, ",INTEGER"},
753 {OPpSORT_REVERSE, ",REVERSE"},
754 {OPpSORT_INPLACE, ",INPLACE"},
755 {OPpSORT_DESCEND, ",DESCEND"},
756 {OPpSORT_QSORT, ",QSORT"},
757 {OPpSORT_STABLE, ",STABLE"}
760 const struct flag_to_name op_open_names[] = {
761 {OPpOPEN_IN_RAW, ",IN_RAW"},
762 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
763 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
764 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
767 const struct flag_to_name op_exit_names[] = {
768 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
769 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
772 const struct flag_to_name op_sassign_names[] = {
773 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
774 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
777 #define OP_PRIVATE_ONCE(op, flag, name) \
778 const struct flag_to_name CAT2(op, _names)[] = { \
782 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
783 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
784 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
785 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
786 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
787 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
788 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
789 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
790 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
791 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
792 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
794 struct op_private_by_op {
797 const struct flag_to_name *start;
800 const struct op_private_by_op op_private_names[] = {
801 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
806 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
807 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
808 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
809 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
810 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
811 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
812 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
813 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
814 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
815 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
816 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
817 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
818 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
819 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
820 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
821 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
825 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
826 const struct op_private_by_op *start = op_private_names;
827 const struct op_private_by_op *const end
828 = op_private_names + C_ARRAY_LENGTH(op_private_names);
830 /* This is a linear search, but no worse than the code that it replaced.
831 It's debugging code - size is more important than speed. */
833 if (optype == start->op_type) {
834 S_append_flags(aTHX_ tmpsv, op_private, start->start,
835 start->start + start->len);
838 } while (++start < end);
842 #define DUMP_OP_FLAGS(o,xml,level,file) \
843 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
844 SV * const tmpsv = newSVpvs(""); \
845 switch (o->op_flags & OPf_WANT) { \
846 case OPf_WANT_VOID: \
847 sv_catpv(tmpsv, ",VOID"); \
849 case OPf_WANT_SCALAR: \
850 sv_catpv(tmpsv, ",SCALAR"); \
852 case OPf_WANT_LIST: \
853 sv_catpv(tmpsv, ",LIST"); \
856 sv_catpv(tmpsv, ",UNKNOWN"); \
859 append_flags(tmpsv, o->op_flags, op_flags_names); \
860 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
861 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
862 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
864 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
865 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
867 PerlIO_printf(file, " flags=\"%s\"", \
868 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
869 SvREFCNT_dec(tmpsv); \
872 #if !defined(PERL_MAD)
873 # define xmldump_attr1(level, file, pat, arg)
875 # define xmldump_attr1(level, file, pat, arg) \
876 S_xmldump_attr(aTHX_ level, file, pat, arg)
879 #define DUMP_OP_PRIVATE(o,xml,level,file) \
880 if (o->op_private) { \
881 U32 optype = o->op_type; \
882 U32 oppriv = o->op_private; \
883 SV * const tmpsv = newSVpvs(""); \
884 if (PL_opargs[optype] & OA_TARGLEX) { \
885 if (oppriv & OPpTARGET_MY) \
886 sv_catpv(tmpsv, ",TARGET_MY"); \
888 else if (optype == OP_ENTERSUB || \
889 optype == OP_RV2SV || \
890 optype == OP_GVSV || \
891 optype == OP_RV2AV || \
892 optype == OP_RV2HV || \
893 optype == OP_RV2GV || \
894 optype == OP_AELEM || \
895 optype == OP_HELEM ) \
897 if (optype == OP_ENTERSUB) { \
898 append_flags(tmpsv, oppriv, op_entersub_names); \
901 switch (oppriv & OPpDEREF) { \
903 sv_catpv(tmpsv, ",SV"); \
906 sv_catpv(tmpsv, ",AV"); \
909 sv_catpv(tmpsv, ",HV"); \
912 if (oppriv & OPpMAYBE_LVSUB) \
913 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
915 if (optype == OP_AELEM || optype == OP_HELEM) { \
916 if (oppriv & OPpLVAL_DEFER) \
917 sv_catpv(tmpsv, ",LVAL_DEFER"); \
919 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
920 if (oppriv & OPpMAYBE_TRUEBOOL) \
921 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
922 if (oppriv & OPpTRUEBOOL) \
923 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
926 if (oppriv & HINT_STRICT_REFS) \
927 sv_catpv(tmpsv, ",STRICT_REFS"); \
928 if (oppriv & OPpOUR_INTRO) \
929 sv_catpv(tmpsv, ",OUR_INTRO"); \
932 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
934 else if (OP_IS_FILETEST(o->op_type)) { \
935 if (oppriv & OPpFT_ACCESS) \
936 sv_catpv(tmpsv, ",FT_ACCESS"); \
937 if (oppriv & OPpFT_STACKED) \
938 sv_catpv(tmpsv, ",FT_STACKED"); \
939 if (oppriv & OPpFT_STACKING) \
940 sv_catpv(tmpsv, ",FT_STACKING"); \
941 if (oppriv & OPpFT_AFTER_t) \
942 sv_catpv(tmpsv, ",AFTER_t"); \
944 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
945 sv_catpv(tmpsv, ",INTRO"); \
946 if (o->op_type == OP_PADRANGE) \
947 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
948 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
949 if (SvCUR(tmpsv)) { \
951 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
953 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
955 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
957 SvREFCNT_dec(tmpsv); \
962 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
966 const OPCODE optype = o->op_type;
968 PERL_ARGS_ASSERT_DO_OP_DUMP;
970 Perl_dump_indent(aTHX_ level, file, "{\n");
972 seq = sequence_num(o);
974 PerlIO_printf(file, "%-4"UVuf, seq);
976 PerlIO_printf(file, "????");
978 "%*sTYPE = %s ===> ",
979 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
982 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
983 sequence_num(o->op_next));
985 PerlIO_printf(file, "NULL\n");
987 if (optype == OP_NULL) {
988 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
989 if (o->op_targ == OP_NEXTSTATE) {
991 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
993 if (CopSTASHPV(cCOPo))
994 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
997 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1002 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1005 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1008 DUMP_OP_FLAGS(o,0,level,file);
1009 DUMP_OP_PRIVATE(o,0,level,file);
1012 if (PL_madskills && o->op_madprop) {
1013 SV * const tmpsv = newSVpvs("");
1014 MADPROP* mp = o->op_madprop;
1015 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1018 const char tmp = mp->mad_key;
1019 sv_setpvs(tmpsv,"'");
1021 sv_catpvn(tmpsv, &tmp, 1);
1022 sv_catpv(tmpsv, "'=");
1023 switch (mp->mad_type) {
1025 sv_catpv(tmpsv, "NULL");
1026 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1029 sv_catpv(tmpsv, "<");
1030 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1031 sv_catpv(tmpsv, ">");
1032 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1035 if ((OP*)mp->mad_val) {
1036 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1037 do_op_dump(level, file, (OP*)mp->mad_val);
1041 sv_catpv(tmpsv, "(UNK)");
1042 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1048 Perl_dump_indent(aTHX_ level, file, "}\n");
1050 SvREFCNT_dec(tmpsv);
1059 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1061 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1062 if (cSVOPo->op_sv) {
1063 SV * const tmpsv = newSV(0);
1067 /* FIXME - is this making unwarranted assumptions about the
1068 UTF-8 cleanliness of the dump file handle? */
1071 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1072 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1073 SvPV_nolen_const(tmpsv));
1077 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1083 case OP_METHOD_NAMED:
1084 #ifndef USE_ITHREADS
1085 /* with ITHREADS, consts are stored in the pad, and the right pad
1086 * may not be active here, so skip */
1087 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1093 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1094 (UV)CopLINE(cCOPo));
1095 if (CopSTASHPV(cCOPo))
1096 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1098 if (CopLABEL(cCOPo))
1099 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1103 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1104 if (cLOOPo->op_redoop)
1105 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1107 PerlIO_printf(file, "DONE\n");
1108 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1109 if (cLOOPo->op_nextop)
1110 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1112 PerlIO_printf(file, "DONE\n");
1113 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1114 if (cLOOPo->op_lastop)
1115 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1117 PerlIO_printf(file, "DONE\n");
1125 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1126 if (cLOGOPo->op_other)
1127 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1129 PerlIO_printf(file, "DONE\n");
1135 do_pmop_dump(level, file, cPMOPo);
1143 if (o->op_private & OPpREFCOUNTED)
1144 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1149 if (o->op_flags & OPf_KIDS) {
1151 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1152 do_op_dump(level, file, kid);
1154 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1158 Perl_op_dump(pTHX_ const OP *o)
1160 PERL_ARGS_ASSERT_OP_DUMP;
1161 do_op_dump(0, Perl_debug_log, o);
1165 Perl_gv_dump(pTHX_ GV *gv)
1169 PERL_ARGS_ASSERT_GV_DUMP;
1172 PerlIO_printf(Perl_debug_log, "{}\n");
1175 sv = sv_newmortal();
1176 PerlIO_printf(Perl_debug_log, "{\n");
1177 gv_fullname3(sv, gv, NULL);
1178 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1179 if (gv != GvEGV(gv)) {
1180 gv_efullname3(sv, GvEGV(gv), NULL);
1181 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1183 PerlIO_putc(Perl_debug_log, '\n');
1184 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1188 /* map magic types to the symbolic names
1189 * (with the PERL_MAGIC_ prefixed stripped)
1192 static const struct { const char type; const char *name; } magic_names[] = {
1193 #include "mg_names.c"
1194 /* this null string terminates the list */
1199 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1201 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1203 for (; mg; mg = mg->mg_moremagic) {
1204 Perl_dump_indent(aTHX_ level, file,
1205 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1206 if (mg->mg_virtual) {
1207 const MGVTBL * const v = mg->mg_virtual;
1208 if (v >= PL_magic_vtables
1209 && v < PL_magic_vtables + magic_vtable_max) {
1210 const U32 i = v - PL_magic_vtables;
1211 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1214 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1217 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1220 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1224 const char *name = NULL;
1225 for (n = 0; magic_names[n].name; n++) {
1226 if (mg->mg_type == magic_names[n].type) {
1227 name = magic_names[n].name;
1232 Perl_dump_indent(aTHX_ level, file,
1233 " MG_TYPE = PERL_MAGIC_%s\n", name);
1235 Perl_dump_indent(aTHX_ level, file,
1236 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1240 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1241 if (mg->mg_type == PERL_MAGIC_envelem &&
1242 mg->mg_flags & MGf_TAINTEDDIR)
1243 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1244 if (mg->mg_type == PERL_MAGIC_regex_global &&
1245 mg->mg_flags & MGf_MINMATCH)
1246 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1247 if (mg->mg_flags & MGf_REFCOUNTED)
1248 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1249 if (mg->mg_flags & MGf_GSKIP)
1250 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1251 if (mg->mg_flags & MGf_COPY)
1252 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1253 if (mg->mg_flags & MGf_DUP)
1254 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1255 if (mg->mg_flags & MGf_LOCAL)
1256 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1259 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1260 PTR2UV(mg->mg_obj));
1261 if (mg->mg_type == PERL_MAGIC_qr) {
1262 REGEXP* const re = (REGEXP *)mg->mg_obj;
1263 SV * const dsv = sv_newmortal();
1264 const char * const s
1265 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1267 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1268 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1270 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1271 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1274 if (mg->mg_flags & MGf_REFCOUNTED)
1275 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1278 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1280 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1281 if (mg->mg_len >= 0) {
1282 if (mg->mg_type != PERL_MAGIC_utf8) {
1283 SV * const sv = newSVpvs("");
1284 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1288 else if (mg->mg_len == HEf_SVKEY) {
1289 PerlIO_puts(file, " => HEf_SVKEY\n");
1290 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1291 maxnest, dumpops, pvlim); /* MG is already +1 */
1294 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1299 " does not know how to handle this MG_LEN"
1301 PerlIO_putc(file, '\n');
1303 if (mg->mg_type == PERL_MAGIC_utf8) {
1304 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1307 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1308 Perl_dump_indent(aTHX_ level, file,
1309 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1312 (UV)cache[i * 2 + 1]);
1319 Perl_magic_dump(pTHX_ const MAGIC *mg)
1321 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1325 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1329 PERL_ARGS_ASSERT_DO_HV_DUMP;
1331 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1332 if (sv && (hvname = HvNAME_get(sv)))
1334 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1335 name which quite legally could contain insane things like tabs, newlines, nulls or
1336 other scary crap - this should produce sane results - except maybe for unicode package
1337 names - but we will wait for someone to file a bug on that - demerphq */
1338 SV * const tmpsv = newSVpvs("");
1339 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1342 PerlIO_putc(file, '\n');
1346 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1348 PERL_ARGS_ASSERT_DO_GV_DUMP;
1350 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1351 if (sv && GvNAME(sv))
1352 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1354 PerlIO_putc(file, '\n');
1358 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1360 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1362 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1363 if (sv && GvNAME(sv)) {
1365 PerlIO_printf(file, "\t\"");
1366 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1367 PerlIO_printf(file, "%s\" :: \"", hvname);
1368 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1371 PerlIO_putc(file, '\n');
1374 const struct flag_to_name first_sv_flags_names[] = {
1375 {SVs_TEMP, "TEMP,"},
1376 {SVs_OBJECT, "OBJECT,"},
1385 const struct flag_to_name second_sv_flags_names[] = {
1387 {SVf_FAKE, "FAKE,"},
1388 {SVf_READONLY, "READONLY,"},
1389 {SVf_IsCOW, "IsCOW,"},
1390 {SVf_BREAK, "BREAK,"},
1391 {SVf_AMAGIC, "OVERLOAD,"},
1397 const struct flag_to_name cv_flags_names[] = {
1398 {CVf_ANON, "ANON,"},
1399 {CVf_UNIQUE, "UNIQUE,"},
1400 {CVf_CLONE, "CLONE,"},
1401 {CVf_CLONED, "CLONED,"},
1402 {CVf_CONST, "CONST,"},
1403 {CVf_NODEBUG, "NODEBUG,"},
1404 {CVf_LVALUE, "LVALUE,"},
1405 {CVf_METHOD, "METHOD,"},
1406 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1407 {CVf_CVGV_RC, "CVGV_RC,"},
1408 {CVf_DYNFILE, "DYNFILE,"},
1409 {CVf_AUTOLOAD, "AUTOLOAD,"},
1410 {CVf_HASEVAL, "HASEVAL"},
1411 {CVf_SLABBED, "SLABBED,"},
1412 {CVf_ISXSUB, "ISXSUB,"}
1415 const struct flag_to_name hv_flags_names[] = {
1416 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1417 {SVphv_LAZYDEL, "LAZYDEL,"},
1418 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1419 {SVphv_CLONEABLE, "CLONEABLE,"}
1422 const struct flag_to_name gp_flags_names[] = {
1423 {GVf_INTRO, "INTRO,"},
1424 {GVf_MULTI, "MULTI,"},
1425 {GVf_ASSUMECV, "ASSUMECV,"},
1426 {GVf_IN_PAD, "IN_PAD,"}
1429 const struct flag_to_name gp_flags_imported_names[] = {
1430 {GVf_IMPORTED_SV, " SV"},
1431 {GVf_IMPORTED_AV, " AV"},
1432 {GVf_IMPORTED_HV, " HV"},
1433 {GVf_IMPORTED_CV, " CV"},
1436 const struct flag_to_name regexp_flags_names[] = {
1437 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1438 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1439 {RXf_PMf_FOLD, "PMf_FOLD,"},
1440 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1441 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1442 {RXf_ANCH_BOL, "ANCH_BOL,"},
1443 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1444 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1445 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1446 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1447 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1448 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1449 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1450 {RXf_CANY_SEEN, "CANY_SEEN,"},
1451 {RXf_NOSCAN, "NOSCAN,"},
1452 {RXf_CHECK_ALL, "CHECK_ALL,"},
1453 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1454 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1455 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1456 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1457 {RXf_COPY_DONE, "COPY_DONE,"},
1458 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1459 {RXf_TAINTED, "TAINTED,"},
1460 {RXf_START_ONLY, "START_ONLY,"},
1461 {RXf_WHITE, "WHITE,"},
1462 {RXf_NULL, "NULL,"},
1466 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1474 PERL_ARGS_ASSERT_DO_SV_DUMP;
1477 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1481 flags = SvFLAGS(sv);
1484 /* process general SV flags */
1486 d = Perl_newSVpvf(aTHX_
1487 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1488 PTR2UV(SvANY(sv)), PTR2UV(sv),
1489 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1490 (int)(PL_dumpindent*level), "");
1492 if (!((flags & SVpad_NAME) == SVpad_NAME
1493 && (type == SVt_PVMG || type == SVt_PVNV))) {
1494 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1495 sv_catpv(d, "PADSTALE,");
1497 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1498 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1499 sv_catpv(d, "PADTMP,");
1500 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1502 append_flags(d, flags, first_sv_flags_names);
1503 if (flags & SVf_ROK) {
1504 sv_catpv(d, "ROK,");
1505 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1507 append_flags(d, flags, second_sv_flags_names);
1508 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1509 if (SvPCS_IMPORTED(sv))
1510 sv_catpv(d, "PCS_IMPORTED,");
1512 sv_catpv(d, "SCREAM,");
1515 /* process type-specific SV flags */
1520 append_flags(d, CvFLAGS(sv), cv_flags_names);
1523 append_flags(d, flags, hv_flags_names);
1527 if (isGV_with_GP(sv)) {
1528 append_flags(d, GvFLAGS(sv), gp_flags_names);
1530 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1531 sv_catpv(d, "IMPORT");
1532 if (GvIMPORTED(sv) == GVf_IMPORTED)
1533 sv_catpv(d, "ALL,");
1536 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1543 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1544 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1547 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1548 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1549 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1550 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1553 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1558 /* SVphv_SHAREKEYS is also 0x20000000 */
1559 if ((type != SVt_PVHV) && SvUTF8(sv))
1560 sv_catpv(d, "UTF8");
1562 if (*(SvEND(d) - 1) == ',') {
1563 SvCUR_set(d, SvCUR(d) - 1);
1564 SvPVX(d)[SvCUR(d)] = '\0';
1569 /* dump initial SV details */
1571 #ifdef DEBUG_LEAKING_SCALARS
1572 Perl_dump_indent(aTHX_ level, file,
1573 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1574 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1576 sv->sv_debug_inpad ? "for" : "by",
1577 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1578 PTR2UV(sv->sv_debug_parent),
1582 Perl_dump_indent(aTHX_ level, file, "SV = ");
1586 if (type < SVt_LAST) {
1587 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1589 if (type == SVt_NULL) {
1594 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1599 /* Dump general SV fields */
1601 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1602 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1603 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1604 || (type == SVt_IV && !SvROK(sv))) {
1606 #ifdef PERL_OLD_COPY_ON_WRITE
1610 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1612 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1613 #ifdef PERL_OLD_COPY_ON_WRITE
1614 if (SvIsCOW_shared_hash(sv))
1615 PerlIO_printf(file, " (HASH)");
1616 else if (SvIsCOW_normal(sv))
1617 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1619 PerlIO_putc(file, '\n');
1622 if ((type == SVt_PVNV || type == SVt_PVMG)
1623 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1624 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1625 (UV) COP_SEQ_RANGE_LOW(sv));
1626 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1627 (UV) COP_SEQ_RANGE_HIGH(sv));
1628 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1629 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1630 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1631 || type == SVt_NV) {
1632 STORE_NUMERIC_LOCAL_SET_STANDARD();
1633 /* %Vg doesn't work? --jhi */
1634 #ifdef USE_LONG_DOUBLE
1635 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1637 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1639 RESTORE_NUMERIC_LOCAL();
1643 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1645 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1648 if (type < SVt_PV) {
1653 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1654 const bool re = isREGEXP(sv);
1655 const char * const ptr =
1656 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1660 SvOOK_offset(sv, delta);
1661 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1666 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1668 PerlIO_printf(file, "( %s . ) ",
1669 pv_display(d, ptr - delta, delta, 0,
1672 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1675 if (SvUTF8(sv)) /* the 6? \x{....} */
1676 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1677 PerlIO_printf(file, "\n");
1678 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1680 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1684 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1687 if (type >= SVt_PVMG) {
1688 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1689 HV * const ost = SvOURSTASH(sv);
1691 do_hv_dump(level, file, " OURSTASH", ost);
1694 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1697 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1699 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1700 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1701 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1702 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1706 /* Dump type-specific SV fields */
1710 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1711 if (AvARRAY(sv) != AvALLOC(sv)) {
1712 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1713 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1716 PerlIO_putc(file, '\n');
1717 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1718 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1719 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1721 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1722 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1723 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1724 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1725 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1727 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1728 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1730 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1732 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1737 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1738 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1739 /* Show distribution of HEs in the ARRAY */
1741 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1744 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1745 NV theoret, sum = 0;
1747 PerlIO_printf(file, " (");
1748 Zero(freq, FREQ_MAX + 1, int);
1749 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1752 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1754 if (count > FREQ_MAX)
1760 for (i = 0; i <= max; i++) {
1762 PerlIO_printf(file, "%d%s:%d", i,
1763 (i == FREQ_MAX) ? "+" : "",
1766 PerlIO_printf(file, ", ");
1769 PerlIO_putc(file, ')');
1770 /* The "quality" of a hash is defined as the total number of
1771 comparisons needed to access every element once, relative
1772 to the expected number needed for a random hash.
1774 The total number of comparisons is equal to the sum of
1775 the squares of the number of entries in each bucket.
1776 For a random hash of n keys into k buckets, the expected
1781 for (i = max; i > 0; i--) { /* Precision: count down. */
1782 sum += freq[i] * i * i;
1784 while ((keys = keys >> 1))
1786 theoret = HvUSEDKEYS(sv);
1787 theoret += theoret * (theoret-1)/pow2;
1788 PerlIO_putc(file, '\n');
1789 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1791 PerlIO_putc(file, '\n');
1792 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1793 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1794 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1795 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1796 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1798 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1799 if (mg && mg->mg_obj) {
1800 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1804 const char * const hvname = HvNAME_get(sv);
1806 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1810 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1811 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1812 if (HvAUX(sv)->xhv_name_count)
1813 Perl_dump_indent(aTHX_
1814 level, file, " NAMECOUNT = %"IVdf"\n",
1815 (IV)HvAUX(sv)->xhv_name_count
1817 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1818 const I32 count = HvAUX(sv)->xhv_name_count;
1820 SV * const names = newSVpvs_flags("", SVs_TEMP);
1821 /* The starting point is the first element if count is
1822 positive and the second element if count is negative. */
1823 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1824 + (count < 0 ? 1 : 0);
1825 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1826 + (count < 0 ? -count : count);
1827 while (hekp < endp) {
1829 sv_catpvs(names, ", \"");
1830 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1831 sv_catpvs(names, "\"");
1833 /* This should never happen. */
1834 sv_catpvs(names, ", (null)");
1838 Perl_dump_indent(aTHX_
1839 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1843 Perl_dump_indent(aTHX_
1844 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1848 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1850 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1854 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1855 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1856 (int)meta->mro_which->length,
1857 meta->mro_which->name,
1858 PTR2UV(meta->mro_which));
1859 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1860 (UV)meta->cache_gen);
1861 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1863 if (meta->mro_linear_all) {
1864 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1865 PTR2UV(meta->mro_linear_all));
1866 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1869 if (meta->mro_linear_current) {
1870 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1871 PTR2UV(meta->mro_linear_current));
1872 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1875 if (meta->mro_nextmethod) {
1876 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1877 PTR2UV(meta->mro_nextmethod));
1878 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1882 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1884 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1889 if (nest < maxnest) {
1890 HV * const hv = MUTABLE_HV(sv);
1895 int count = maxnest - nest;
1896 for (i=0; i <= HvMAX(hv); i++) {
1897 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1904 if (count-- <= 0) goto DONEHV;
1907 keysv = hv_iterkeysv(he);
1908 keypv = SvPV_const(keysv, len);
1911 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1913 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1914 if (HvEITER_get(hv) == he)
1915 PerlIO_printf(file, "[CURRENT] ");
1916 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1917 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1926 if (CvAUTOLOAD(sv)) {
1928 const char *const name = SvPV_const(sv, len);
1929 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1933 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1934 (int) CvPROTOLEN(sv), CvPROTO(sv));
1938 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1939 if (!CvISXSUB(sv)) {
1941 Perl_dump_indent(aTHX_ level, file,
1942 " START = 0x%"UVxf" ===> %"IVdf"\n",
1943 PTR2UV(CvSTART(sv)),
1944 (IV)sequence_num(CvSTART(sv)));
1946 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1947 PTR2UV(CvROOT(sv)));
1948 if (CvROOT(sv) && dumpops) {
1949 do_op_dump(level+1, file, CvROOT(sv));
1952 SV * const constant = cv_const_sv((const CV *)sv);
1954 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1957 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1959 PTR2UV(CvXSUBANY(sv).any_ptr));
1960 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1963 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1964 (IV)CvXSUBANY(sv).any_i32);
1968 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1969 HEK_KEY(CvNAME_HEK((CV *)sv)));
1970 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1971 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1972 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1973 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1974 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1975 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1976 if (nest < maxnest) {
1977 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1980 const CV * const outside = CvOUTSIDE(sv);
1981 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1984 : CvANON(outside) ? "ANON"
1985 : (outside == PL_main_cv) ? "MAIN"
1986 : CvUNIQUE(outside) ? "UNIQUE"
1987 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1989 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1990 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1995 if (type == SVt_PVLV) {
1996 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1997 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1998 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1999 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2000 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2001 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2002 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2005 if (isREGEXP(sv)) goto dumpregexp;
2006 if (!isGV_with_GP(sv))
2008 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2009 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2010 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2011 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2014 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2015 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2016 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2017 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2018 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2019 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2020 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2021 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2022 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2023 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2024 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2025 do_gv_dump (level, file, " EGV", GvEGV(sv));
2028 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2029 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2030 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2031 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2032 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2033 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2034 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2036 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2037 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2038 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2040 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2041 PTR2UV(IoTOP_GV(sv)));
2042 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2043 maxnest, dumpops, pvlim);
2045 /* Source filters hide things that are not GVs in these three, so let's
2046 be careful out there. */
2048 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2049 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2050 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2052 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2053 PTR2UV(IoFMT_GV(sv)));
2054 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2055 maxnest, dumpops, pvlim);
2057 if (IoBOTTOM_NAME(sv))
2058 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2059 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2060 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2062 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2063 PTR2UV(IoBOTTOM_GV(sv)));
2064 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2065 maxnest, dumpops, pvlim);
2067 if (isPRINT(IoTYPE(sv)))
2068 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2070 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2071 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2076 struct regexp * const r = ReANY((REGEXP*)sv);
2077 flags = RX_EXTFLAGS((REGEXP*)sv);
2079 append_flags(d, flags, regexp_flags_names);
2080 if (*(SvEND(d) - 1) == ',') {
2081 SvCUR_set(d, SvCUR(d) - 1);
2082 SvPVX(d)[SvCUR(d)] = '\0';
2084 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2085 (UV)flags, SvPVX_const(d));
2086 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2088 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2090 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2091 (UV)(r->lastparen));
2092 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2093 (UV)(r->lastcloseparen));
2094 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2096 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2097 (IV)(r->minlenret));
2098 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2100 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2101 (UV)(r->pre_prefix));
2102 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2104 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2105 (IV)(r->suboffset));
2106 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2107 (IV)(r->subcoffset));
2109 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2111 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2113 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2114 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2116 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2117 PTR2UV(r->mother_re));
2118 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2119 PTR2UV(r->paren_names));
2120 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2121 PTR2UV(r->substrs));
2122 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2123 PTR2UV(r->pprivate));
2124 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2126 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2127 PTR2UV(r->qr_anoncv));
2128 #ifdef PERL_OLD_COPY_ON_WRITE
2129 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2130 PTR2UV(r->saved_copy));
2139 Perl_sv_dump(pTHX_ SV *sv)
2143 PERL_ARGS_ASSERT_SV_DUMP;
2146 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2148 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2152 Perl_runops_debug(pTHX)
2156 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2160 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2163 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2164 PerlIO_printf(Perl_debug_log,
2165 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2166 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2167 PTR2UV(*PL_watchaddr));
2168 if (DEBUG_s_TEST_) {
2169 if (DEBUG_v_TEST_) {
2170 PerlIO_printf(Perl_debug_log, "\n");
2178 if (DEBUG_t_TEST_) debop(PL_op);
2179 if (DEBUG_P_TEST_) debprof(PL_op);
2182 OP_ENTRY_PROBE(OP_NAME(PL_op));
2183 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2184 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2191 Perl_debop(pTHX_ const OP *o)
2195 PERL_ARGS_ASSERT_DEBOP;
2197 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2200 Perl_deb(aTHX_ "%s", OP_NAME(o));
2201 switch (o->op_type) {
2204 /* With ITHREADS, consts are stored in the pad, and the right pad
2205 * may not be active here, so check.
2206 * Looks like only during compiling the pads are illegal.
2209 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2211 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2216 SV * const sv = newSV(0);
2218 /* FIXME - is this making unwarranted assumptions about the
2219 UTF-8 cleanliness of the dump file handle? */
2222 gv_fullname3(sv, cGVOPo_gv, NULL);
2223 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2227 PerlIO_printf(Perl_debug_log, "(NULL)");
2239 count = o->op_private & OPpPADRANGE_COUNTMASK;
2241 /* print the lexical's name */
2243 CV * const cv = deb_curcv(cxstack_ix);
2245 PAD * comppad = NULL;
2249 PADLIST * const padlist = CvPADLIST(cv);
2250 comppad = *PadlistARRAY(padlist);
2252 PerlIO_printf(Perl_debug_log, "(");
2253 for (i = 0; i < count; i++) {
2255 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2256 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2258 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2261 PerlIO_printf(Perl_debug_log, ",");
2263 PerlIO_printf(Perl_debug_log, ")");
2271 PerlIO_printf(Perl_debug_log, "\n");
2276 S_deb_curcv(pTHX_ const I32 ix)
2279 const PERL_CONTEXT * const cx = &cxstack[ix];
2280 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2281 return cx->blk_sub.cv;
2282 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2283 return cx->blk_eval.cv;
2284 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2289 return deb_curcv(ix - 1);
2293 Perl_watch(pTHX_ char **addr)
2297 PERL_ARGS_ASSERT_WATCH;
2299 PL_watchaddr = addr;
2301 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2302 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2306 S_debprof(pTHX_ const OP *o)
2310 PERL_ARGS_ASSERT_DEBPROF;
2312 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2314 if (!PL_profiledata)
2315 Newxz(PL_profiledata, MAXO, U32);
2316 ++PL_profiledata[o->op_type];
2320 Perl_debprofdump(pTHX)
2324 if (!PL_profiledata)
2326 for (i = 0; i < MAXO; i++) {
2327 if (PL_profiledata[i])
2328 PerlIO_printf(Perl_debug_log,
2329 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2336 * XML variants of most of the above routines
2340 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2344 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2346 PerlIO_printf(file, "\n ");
2347 va_start(args, pat);
2348 xmldump_vindent(level, file, pat, &args);
2354 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2357 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2358 va_start(args, pat);
2359 xmldump_vindent(level, file, pat, &args);
2364 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2366 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2368 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2369 PerlIO_vprintf(file, pat, *args);
2373 Perl_xmldump_all(pTHX)
2375 xmldump_all_perl(FALSE);
2379 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2381 PerlIO_setlinebuf(PL_xmlfp);
2383 op_xmldump(PL_main_root);
2384 /* someday we might call this, when it outputs XML: */
2385 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2386 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2387 PerlIO_close(PL_xmlfp);
2392 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2394 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2395 xmldump_packsubs_perl(stash, FALSE);
2399 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2404 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2406 if (!HvARRAY(stash))
2408 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2409 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2410 GV *gv = MUTABLE_GV(HeVAL(entry));
2412 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2415 xmldump_sub_perl(gv, justperl);
2418 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2419 && (hv = GvHV(gv)) && hv != PL_defstash)
2420 xmldump_packsubs_perl(hv, justperl); /* nested package */
2426 Perl_xmldump_sub(pTHX_ const GV *gv)
2428 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2429 xmldump_sub_perl(gv, FALSE);
2433 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2437 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2439 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2442 sv = sv_newmortal();
2443 gv_fullname3(sv, gv, NULL);
2444 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2445 if (CvXSUB(GvCV(gv)))
2446 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2447 PTR2UV(CvXSUB(GvCV(gv))),
2448 (int)CvXSUBANY(GvCV(gv)).any_i32);
2449 else if (CvROOT(GvCV(gv)))
2450 op_xmldump(CvROOT(GvCV(gv)));
2452 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2456 Perl_xmldump_form(pTHX_ const GV *gv)
2458 SV * const sv = sv_newmortal();
2460 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2462 gv_fullname3(sv, gv, NULL);
2463 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2464 if (CvROOT(GvFORM(gv)))
2465 op_xmldump(CvROOT(GvFORM(gv)));
2467 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2471 Perl_xmldump_eval(pTHX)
2473 op_xmldump(PL_eval_root);
2477 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2479 PERL_ARGS_ASSERT_SV_CATXMLSV;
2480 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2484 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2486 PERL_ARGS_ASSERT_SV_CATXMLPV;
2487 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2491 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2494 const char * const e = pv + len;
2495 const char * const start = pv;
2499 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2502 dsvcur = SvCUR(dsv); /* in case we have to restart */
2507 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2509 SvCUR(dsv) = dsvcur;
2574 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2577 sv_catpvs(dsv, "<");
2580 sv_catpvs(dsv, ">");
2583 sv_catpvs(dsv, "&");
2586 sv_catpvs(dsv, """);
2590 if (c < 32 || c > 127) {
2591 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2594 const char string = (char) c;
2595 sv_catpvn(dsv, &string, 1);
2599 if ((c >= 0xD800 && c <= 0xDB7F) ||
2600 (c >= 0xDC00 && c <= 0xDFFF) ||
2601 (c >= 0xFFF0 && c <= 0xFFFF) ||
2603 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2605 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2618 Perl_sv_xmlpeek(pTHX_ SV *sv)
2620 SV * const t = sv_newmortal();
2624 PERL_ARGS_ASSERT_SV_XMLPEEK;
2630 sv_catpv(t, "VOID=\"\"");
2633 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2634 sv_catpv(t, "WILD=\"\"");
2637 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2638 if (sv == &PL_sv_undef) {
2639 sv_catpv(t, "SV_UNDEF=\"1\"");
2640 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2641 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2645 else if (sv == &PL_sv_no) {
2646 sv_catpv(t, "SV_NO=\"1\"");
2647 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2648 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2649 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2650 SVp_POK|SVp_NOK)) &&
2655 else if (sv == &PL_sv_yes) {
2656 sv_catpv(t, "SV_YES=\"1\"");
2657 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2658 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2659 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2660 SVp_POK|SVp_NOK)) &&
2662 SvPVX(sv) && *SvPVX(sv) == '1' &&
2667 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2668 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2669 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2673 sv_catpv(t, " XXX=\"\" ");
2675 else if (SvREFCNT(sv) == 0) {
2676 sv_catpv(t, " refcnt=\"0\"");
2679 else if (DEBUG_R_TEST_) {
2682 /* is this SV on the tmps stack? */
2683 for (ix=PL_tmps_ix; ix>=0; ix--) {
2684 if (PL_tmps_stack[ix] == sv) {
2689 if (SvREFCNT(sv) > 1)
2690 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2693 sv_catpv(t, " DRT=\"<T>\"");
2697 sv_catpv(t, " ROK=\"\"");
2699 switch (SvTYPE(sv)) {
2701 sv_catpv(t, " FREED=\"1\"");
2705 sv_catpv(t, " UNDEF=\"1\"");
2708 sv_catpv(t, " IV=\"");
2711 sv_catpv(t, " NV=\"");
2714 sv_catpv(t, " PV=\"");
2717 sv_catpv(t, " PVIV=\"");
2720 sv_catpv(t, " PVNV=\"");
2723 sv_catpv(t, " PVMG=\"");
2726 sv_catpv(t, " PVLV=\"");
2729 sv_catpv(t, " AV=\"");
2732 sv_catpv(t, " HV=\"");
2736 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2738 sv_catpv(t, " CV=\"()\"");
2741 sv_catpv(t, " GV=\"");
2744 sv_catpv(t, " BIND=\"");
2747 sv_catpv(t, " REGEXP=\"");
2750 sv_catpv(t, " FM=\"");
2753 sv_catpv(t, " IO=\"");
2762 else if (SvNOKp(sv)) {
2763 STORE_NUMERIC_LOCAL_SET_STANDARD();
2764 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2765 RESTORE_NUMERIC_LOCAL();
2767 else if (SvIOKp(sv)) {
2769 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2771 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2780 return SvPV(t, n_a);
2784 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2786 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2789 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2792 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2795 REGEXP *const r = PM_GETRE(pm);
2796 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2797 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2798 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2800 SvREFCNT_dec(tmpsv);
2801 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2802 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2805 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2806 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2807 SV * const tmpsv = pm_description(pm);
2808 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2809 SvREFCNT_dec(tmpsv);
2813 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2814 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2815 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2816 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2817 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2818 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2821 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2825 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2827 do_pmop_xmldump(0, PL_xmlfp, pm);
2831 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2835 const OPCODE optype = o->op_type;
2837 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2841 seq = sequence_num(o);
2842 Perl_xmldump_indent(aTHX_ level, file,
2843 "<op_%s seq=\"%"UVuf" -> ",
2848 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2849 sequence_num(o->op_next));
2851 PerlIO_printf(file, "DONE\"");
2854 if (optype == OP_NULL)
2856 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2857 if (o->op_targ == OP_NEXTSTATE)
2860 PerlIO_printf(file, " line=\"%"UVuf"\"",
2861 (UV)CopLINE(cCOPo));
2862 if (CopSTASHPV(cCOPo))
2863 PerlIO_printf(file, " package=\"%s\"",
2865 if (CopLABEL(cCOPo))
2866 PerlIO_printf(file, " label=\"%s\"",
2871 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2874 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2877 DUMP_OP_FLAGS(o,1,0,file);
2878 DUMP_OP_PRIVATE(o,1,0,file);
2882 if (o->op_flags & OPf_SPECIAL) {
2888 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2890 if (cSVOPo->op_sv) {
2891 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2892 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2898 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2899 s = SvPV(tmpsv1,len);
2900 sv_catxmlpvn(tmpsv2, s, len, 1);
2901 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2905 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2910 case OP_METHOD_NAMED:
2911 #ifndef USE_ITHREADS
2912 /* with ITHREADS, consts are stored in the pad, and the right pad
2913 * may not be active here, so skip */
2914 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2920 PerlIO_printf(file, ">\n");
2922 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2927 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2928 (UV)CopLINE(cCOPo));
2929 if (CopSTASHPV(cCOPo))
2930 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2932 if (CopLABEL(cCOPo))
2933 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2937 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2938 if (cLOOPo->op_redoop)
2939 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2941 PerlIO_printf(file, "DONE\"");
2942 S_xmldump_attr(aTHX_ level, file, "next=\"");
2943 if (cLOOPo->op_nextop)
2944 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2946 PerlIO_printf(file, "DONE\"");
2947 S_xmldump_attr(aTHX_ level, file, "last=\"");
2948 if (cLOOPo->op_lastop)
2949 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2951 PerlIO_printf(file, "DONE\"");
2959 S_xmldump_attr(aTHX_ level, file, "other=\"");
2960 if (cLOGOPo->op_other)
2961 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2963 PerlIO_printf(file, "DONE\"");
2971 if (o->op_private & OPpREFCOUNTED)
2972 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2978 if (PL_madskills && o->op_madprop) {
2979 char prevkey = '\0';
2980 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2981 const MADPROP* mp = o->op_madprop;
2985 PerlIO_printf(file, ">\n");
2987 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2990 char tmp = mp->mad_key;
2991 sv_setpvs(tmpsv,"\"");
2993 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2994 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2995 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2998 sv_catpv(tmpsv, "\"");
2999 switch (mp->mad_type) {
3001 sv_catpv(tmpsv, "NULL");
3002 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3005 sv_catpv(tmpsv, " val=\"");
3006 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3007 sv_catpv(tmpsv, "\"");
3008 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3011 sv_catpv(tmpsv, " val=\"");
3012 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3013 sv_catpv(tmpsv, "\"");
3014 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3017 if ((OP*)mp->mad_val) {
3018 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3019 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3020 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3024 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3030 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3032 SvREFCNT_dec(tmpsv);
3042 PerlIO_printf(file, ">\n");
3044 do_pmop_xmldump(level, file, cPMOPo);
3050 if (o->op_flags & OPf_KIDS) {
3054 PerlIO_printf(file, ">\n");
3056 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3057 do_op_xmldump(level, file, kid);
3061 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3063 PerlIO_printf(file, " />\n");
3067 Perl_op_xmldump(pTHX_ const OP *o)
3069 PERL_ARGS_ASSERT_OP_XMLDUMP;
3071 do_op_xmldump(0, PL_xmlfp, o);
3077 * c-indentation-style: bsd
3079 * indent-tabs-mode: nil
3082 * ex: set ts=8 sts=4 sw=4 et: