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
31 static const char* const svtypenames[SVt_LAST] = {
51 static const char* const svshorttypenames[SVt_LAST] = {
76 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
77 const struct flag_to_name *const end)
80 if (flags & start->flag)
81 sv_catpv(sv, start->name);
82 } while (++start < end);
85 #define append_flags(sv, f, flags) \
86 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
91 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
94 PERL_ARGS_ASSERT_DUMP_INDENT;
96 dump_vindent(level, file, pat, &args);
101 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
104 PERL_ARGS_ASSERT_DUMP_VINDENT;
105 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
106 PerlIO_vprintf(file, pat, *args);
112 dump_all_perl(FALSE);
116 Perl_dump_all_perl(pTHX_ bool justperl)
120 PerlIO_setlinebuf(Perl_debug_log);
122 op_dump(PL_main_root);
123 dump_packsubs_perl(PL_defstash, justperl);
127 Perl_dump_packsubs(pTHX_ const HV *stash)
129 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
130 dump_packsubs_perl(stash, FALSE);
134 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
139 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
143 for (i = 0; i <= (I32) HvMAX(stash); i++) {
145 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
146 const GV * const gv = (const GV *)HeVAL(entry);
147 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
150 dump_sub_perl(gv, justperl);
153 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
154 const HV * const hv = GvHV(gv);
155 if (hv && (hv != PL_defstash))
156 dump_packsubs_perl(hv, justperl); /* nested package */
163 Perl_dump_sub(pTHX_ const GV *gv)
165 PERL_ARGS_ASSERT_DUMP_SUB;
166 dump_sub_perl(gv, FALSE);
170 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
174 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
176 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
180 gv_fullname3(sv, gv, NULL);
181 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
182 if (CvISXSUB(GvCV(gv)))
183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
184 PTR2UV(CvXSUB(GvCV(gv))),
185 (int)CvXSUBANY(GvCV(gv)).any_i32);
186 else if (CvROOT(GvCV(gv)))
187 op_dump(CvROOT(GvCV(gv)));
189 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
193 Perl_dump_form(pTHX_ const GV *gv)
195 SV * const sv = sv_newmortal();
197 PERL_ARGS_ASSERT_DUMP_FORM;
199 gv_fullname3(sv, gv, NULL);
200 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
201 if (CvROOT(GvFORM(gv)))
202 op_dump(CvROOT(GvFORM(gv)));
204 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
211 op_dump(PL_eval_root);
216 =for apidoc pv_escape
218 Escapes at most the first "count" chars of pv and puts the results into
219 dsv such that the size of the escaped string will not exceed "max" chars
220 and will not contain any incomplete escape sequences.
222 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
223 will also be escaped.
225 Normally the SV will be cleared before the escaped string is prepared,
226 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
228 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
229 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
230 using C<is_utf8_string()> to determine if it is Unicode.
232 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
233 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
234 chars above 127 will be escaped using this style; otherwise, only chars above
235 255 will be so escaped; other non printable chars will use octal or
236 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
237 then all chars below 255 will be treated as printable and
238 will be output as literals.
240 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
241 string will be escaped, regardless of max. If the output is to be in hex,
242 then it will be returned as a plain hex
243 sequence. Thus the output will either be a single char,
244 an octal escape sequence, a special escape like C<\n> or a hex value.
246 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
247 not a '\\'. This is because regexes very often contain backslashed
248 sequences, whereas '%' is not a particularly common character in patterns.
250 Returns a pointer to the escaped text as held by dsv.
254 #define PV_ESCAPE_OCTBUFSIZE 32
257 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
258 const STRLEN count, const STRLEN max,
259 STRLEN * const escaped, const U32 flags )
261 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
262 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
263 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
264 STRLEN wrote = 0; /* chars written so far */
265 STRLEN chsize = 0; /* size of data to be written */
266 STRLEN readsize = 1; /* size of data just read */
267 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
268 const char *pv = str;
269 const char * const end = pv + count; /* end of string */
272 PERL_ARGS_ASSERT_PV_ESCAPE;
274 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
275 /* This won't alter the UTF-8 flag */
279 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
282 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
283 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
284 const U8 c = (U8)u & 0xFF;
287 || (flags & PERL_PV_ESCAPE_ALL)
288 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
290 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
291 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
295 "%cx{%"UVxf"}", esc, u);
296 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
299 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
303 case '\\' : /* fallthrough */
304 case '%' : if ( c == esc ) {
310 case '\v' : octbuf[1] = 'v'; break;
311 case '\t' : octbuf[1] = 't'; break;
312 case '\r' : octbuf[1] = 'r'; break;
313 case '\n' : octbuf[1] = 'n'; break;
314 case '\f' : octbuf[1] = 'f'; break;
322 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
323 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
326 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
333 if ( max && (wrote + chsize > max) ) {
335 } else if (chsize > 1) {
336 sv_catpvn(dsv, octbuf, chsize);
339 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
340 128-255 can be appended raw to the dsv. If dsv happens to be
341 UTF-8 then we need catpvf to upgrade them for us.
342 Or add a new API call sv_catpvc(). Think about that name, and
343 how to keep it clear that it's unlike the s of catpvs, which is
344 really an array octets, not a string. */
345 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
348 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
356 =for apidoc pv_pretty
358 Converts a string into something presentable, handling escaping via
359 pv_escape() and supporting quoting and ellipses.
361 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
362 double quoted with any double quotes in the string escaped. Otherwise
363 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
366 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
367 string were output then an ellipsis C<...> will be appended to the
368 string. Note that this happens AFTER it has been quoted.
370 If start_color is non-null then it will be inserted after the opening
371 quote (if there is one) but before the escaped text. If end_color
372 is non-null then it will be inserted after the escaped text but before
373 any quotes or ellipses.
375 Returns a pointer to the prettified text as held by dsv.
381 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
382 const STRLEN max, char const * const start_color, char const * const end_color,
385 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
388 PERL_ARGS_ASSERT_PV_PRETTY;
390 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
391 /* This won't alter the UTF-8 flag */
396 sv_catpvs(dsv, "\"");
397 else if ( flags & PERL_PV_PRETTY_LTGT )
400 if ( start_color != NULL )
401 sv_catpv(dsv, start_color);
403 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
405 if ( end_color != NULL )
406 sv_catpv(dsv, end_color);
409 sv_catpvs( dsv, "\"");
410 else if ( flags & PERL_PV_PRETTY_LTGT )
413 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
414 sv_catpvs(dsv, "...");
420 =for apidoc pv_display
424 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
426 except that an additional "\0" will be appended to the string when
427 len > cur and pv[cur] is "\0".
429 Note that the final string may be up to 7 chars longer than pvlim.
435 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
437 PERL_ARGS_ASSERT_PV_DISPLAY;
439 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
440 if (len > cur && pv[cur] == '\0')
441 sv_catpvs( dsv, "\\0");
446 Perl_sv_peek(pTHX_ SV *sv)
449 SV * const t = sv_newmortal();
459 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
460 /* detect data corruption under memory poisoning */
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),
564 SvREFCNT_dec_NN(tmp);
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 : "");
628 SvREFCNT_dec_NN(tmpsv);
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");
675 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
676 sv_catpv(desc, ",SKIPWHITE");
679 append_flags(desc, pmflags, pmflags_flags_names);
684 Perl_pmop_dump(pTHX_ PMOP *pm)
686 do_pmop_dump(0, Perl_debug_log, pm);
689 /* Return a unique integer to represent the address of op o.
690 * If it already exists in PL_op_sequence, just return it;
692 * *** Note that this isn't thread-safe */
695 S_sequence_num(pTHX_ const OP *o)
704 op = newSVuv(PTR2UV(o));
706 key = SvPV_const(op, len);
708 PL_op_sequence = newHV();
709 seq = hv_fetch(PL_op_sequence, key, len, 0);
712 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
716 const struct flag_to_name op_flags_names[] = {
718 {OPf_PARENS, ",PARENS"},
721 {OPf_STACKED, ",STACKED"},
722 {OPf_SPECIAL, ",SPECIAL"}
725 const struct flag_to_name op_trans_names[] = {
726 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
727 {OPpTRANS_TO_UTF, ",TO_UTF"},
728 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
729 {OPpTRANS_SQUASH, ",SQUASH"},
730 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
731 {OPpTRANS_GROWS, ",GROWS"},
732 {OPpTRANS_DELETE, ",DELETE"}
735 const struct flag_to_name op_entersub_names[] = {
736 {OPpENTERSUB_DB, ",DB"},
737 {OPpENTERSUB_HASTARG, ",HASTARG"},
738 {OPpENTERSUB_AMPER, ",AMPER"},
739 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
740 {OPpENTERSUB_INARGS, ",INARGS"}
743 const struct flag_to_name op_const_names[] = {
744 {OPpCONST_NOVER, ",NOVER"},
745 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
746 {OPpCONST_STRICT, ",STRICT"},
747 {OPpCONST_ENTERED, ",ENTERED"},
748 {OPpCONST_FOLDED, ",FOLDED"},
749 {OPpCONST_BARE, ",BARE"}
752 const struct flag_to_name op_sort_names[] = {
753 {OPpSORT_NUMERIC, ",NUMERIC"},
754 {OPpSORT_INTEGER, ",INTEGER"},
755 {OPpSORT_REVERSE, ",REVERSE"},
756 {OPpSORT_INPLACE, ",INPLACE"},
757 {OPpSORT_DESCEND, ",DESCEND"},
758 {OPpSORT_QSORT, ",QSORT"},
759 {OPpSORT_STABLE, ",STABLE"}
762 const struct flag_to_name op_open_names[] = {
763 {OPpOPEN_IN_RAW, ",IN_RAW"},
764 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
765 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
766 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
769 const struct flag_to_name op_exit_names[] = {
770 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
771 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
774 const struct flag_to_name op_sassign_names[] = {
775 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
776 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
779 #define OP_PRIVATE_ONCE(op, flag, name) \
780 const struct flag_to_name CAT2(op, _names)[] = { \
784 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
785 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
786 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
787 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
788 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
789 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
790 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
791 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
792 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
793 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
795 struct op_private_by_op {
798 const struct flag_to_name *start;
801 const struct op_private_by_op op_private_names[] = {
802 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_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_NN(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 else if (o->op_type == OP_AASSIGN) { \
945 if (oppriv & OPpASSIGN_COMMON) \
946 sv_catpvs(tmpsv, ",COMMON"); \
947 if (oppriv & OPpMAYBE_LVSUB) \
948 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
950 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
951 sv_catpv(tmpsv, ",INTRO"); \
952 if (o->op_type == OP_PADRANGE) \
953 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
954 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
955 if (SvCUR(tmpsv)) { \
957 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
959 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
961 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
963 SvREFCNT_dec_NN(tmpsv); \
968 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
972 const OPCODE optype = o->op_type;
974 PERL_ARGS_ASSERT_DO_OP_DUMP;
976 Perl_dump_indent(aTHX_ level, file, "{\n");
978 seq = sequence_num(o);
980 PerlIO_printf(file, "%-4"UVuf, seq);
982 PerlIO_printf(file, "????");
984 "%*sTYPE = %s ===> ",
985 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
988 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
989 sequence_num(o->op_next));
991 PerlIO_printf(file, "NULL\n");
993 if (optype == OP_NULL) {
994 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
995 if (o->op_targ == OP_NEXTSTATE) {
997 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
999 if (CopSTASHPV(cCOPo))
1000 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1002 if (CopLABEL(cCOPo))
1003 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1008 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1011 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1014 DUMP_OP_FLAGS(o,0,level,file);
1015 DUMP_OP_PRIVATE(o,0,level,file);
1018 if (PL_madskills && o->op_madprop) {
1019 SV * const tmpsv = newSVpvs("");
1020 MADPROP* mp = o->op_madprop;
1021 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1024 const char tmp = mp->mad_key;
1025 sv_setpvs(tmpsv,"'");
1027 sv_catpvn(tmpsv, &tmp, 1);
1028 sv_catpv(tmpsv, "'=");
1029 switch (mp->mad_type) {
1031 sv_catpv(tmpsv, "NULL");
1032 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1035 sv_catpv(tmpsv, "<");
1036 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1037 sv_catpv(tmpsv, ">");
1038 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1041 if ((OP*)mp->mad_val) {
1042 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1043 do_op_dump(level, file, (OP*)mp->mad_val);
1047 sv_catpv(tmpsv, "(UNK)");
1048 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1054 Perl_dump_indent(aTHX_ level, file, "}\n");
1056 SvREFCNT_dec_NN(tmpsv);
1065 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1067 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1068 if (cSVOPo->op_sv) {
1069 SV * const tmpsv = newSV(0);
1073 /* FIXME - is this making unwarranted assumptions about the
1074 UTF-8 cleanliness of the dump file handle? */
1077 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1078 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1079 SvPV_nolen_const(tmpsv));
1083 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1089 case OP_METHOD_NAMED:
1090 #ifndef USE_ITHREADS
1091 /* with ITHREADS, consts are stored in the pad, and the right pad
1092 * may not be active here, so skip */
1093 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1099 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1100 (UV)CopLINE(cCOPo));
1101 if (CopSTASHPV(cCOPo))
1102 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1104 if (CopLABEL(cCOPo))
1105 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1109 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1110 if (cLOOPo->op_redoop)
1111 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1113 PerlIO_printf(file, "DONE\n");
1114 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1115 if (cLOOPo->op_nextop)
1116 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1118 PerlIO_printf(file, "DONE\n");
1119 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1120 if (cLOOPo->op_lastop)
1121 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1123 PerlIO_printf(file, "DONE\n");
1131 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1132 if (cLOGOPo->op_other)
1133 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1135 PerlIO_printf(file, "DONE\n");
1141 do_pmop_dump(level, file, cPMOPo);
1149 if (o->op_private & OPpREFCOUNTED)
1150 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1155 if (o->op_flags & OPf_KIDS) {
1157 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1158 do_op_dump(level, file, kid);
1160 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1164 Perl_op_dump(pTHX_ const OP *o)
1166 PERL_ARGS_ASSERT_OP_DUMP;
1167 do_op_dump(0, Perl_debug_log, o);
1171 Perl_gv_dump(pTHX_ GV *gv)
1175 PERL_ARGS_ASSERT_GV_DUMP;
1178 PerlIO_printf(Perl_debug_log, "{}\n");
1181 sv = sv_newmortal();
1182 PerlIO_printf(Perl_debug_log, "{\n");
1183 gv_fullname3(sv, gv, NULL);
1184 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1185 if (gv != GvEGV(gv)) {
1186 gv_efullname3(sv, GvEGV(gv), NULL);
1187 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1189 PerlIO_putc(Perl_debug_log, '\n');
1190 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1194 /* map magic types to the symbolic names
1195 * (with the PERL_MAGIC_ prefixed stripped)
1198 static const struct { const char type; const char *name; } magic_names[] = {
1199 #include "mg_names.c"
1200 /* this null string terminates the list */
1205 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1207 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1209 for (; mg; mg = mg->mg_moremagic) {
1210 Perl_dump_indent(aTHX_ level, file,
1211 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1212 if (mg->mg_virtual) {
1213 const MGVTBL * const v = mg->mg_virtual;
1214 if (v >= PL_magic_vtables
1215 && v < PL_magic_vtables + magic_vtable_max) {
1216 const U32 i = v - PL_magic_vtables;
1217 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1220 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1223 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1226 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1230 const char *name = NULL;
1231 for (n = 0; magic_names[n].name; n++) {
1232 if (mg->mg_type == magic_names[n].type) {
1233 name = magic_names[n].name;
1238 Perl_dump_indent(aTHX_ level, file,
1239 " MG_TYPE = PERL_MAGIC_%s\n", name);
1241 Perl_dump_indent(aTHX_ level, file,
1242 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1246 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1247 if (mg->mg_type == PERL_MAGIC_envelem &&
1248 mg->mg_flags & MGf_TAINTEDDIR)
1249 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1250 if (mg->mg_type == PERL_MAGIC_regex_global &&
1251 mg->mg_flags & MGf_MINMATCH)
1252 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1253 if (mg->mg_flags & MGf_REFCOUNTED)
1254 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1255 if (mg->mg_flags & MGf_GSKIP)
1256 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1257 if (mg->mg_flags & MGf_COPY)
1258 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1259 if (mg->mg_flags & MGf_DUP)
1260 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1261 if (mg->mg_flags & MGf_LOCAL)
1262 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1265 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1266 PTR2UV(mg->mg_obj));
1267 if (mg->mg_type == PERL_MAGIC_qr) {
1268 REGEXP* const re = (REGEXP *)mg->mg_obj;
1269 SV * const dsv = sv_newmortal();
1270 const char * const s
1271 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1273 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1274 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1276 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1277 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1280 if (mg->mg_flags & MGf_REFCOUNTED)
1281 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1284 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1286 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1287 if (mg->mg_len >= 0) {
1288 if (mg->mg_type != PERL_MAGIC_utf8) {
1289 SV * const sv = newSVpvs("");
1290 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1291 SvREFCNT_dec_NN(sv);
1294 else if (mg->mg_len == HEf_SVKEY) {
1295 PerlIO_puts(file, " => HEf_SVKEY\n");
1296 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1297 maxnest, dumpops, pvlim); /* MG is already +1 */
1300 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1305 " does not know how to handle this MG_LEN"
1307 PerlIO_putc(file, '\n');
1309 if (mg->mg_type == PERL_MAGIC_utf8) {
1310 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1313 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1314 Perl_dump_indent(aTHX_ level, file,
1315 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1318 (UV)cache[i * 2 + 1]);
1325 Perl_magic_dump(pTHX_ const MAGIC *mg)
1327 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1331 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1335 PERL_ARGS_ASSERT_DO_HV_DUMP;
1337 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1338 if (sv && (hvname = HvNAME_get(sv)))
1340 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1341 name which quite legally could contain insane things like tabs, newlines, nulls or
1342 other scary crap - this should produce sane results - except maybe for unicode package
1343 names - but we will wait for someone to file a bug on that - demerphq */
1344 SV * const tmpsv = newSVpvs("");
1345 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1348 PerlIO_putc(file, '\n');
1352 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1354 PERL_ARGS_ASSERT_DO_GV_DUMP;
1356 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1357 if (sv && GvNAME(sv))
1358 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1360 PerlIO_putc(file, '\n');
1364 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1366 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1368 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1369 if (sv && GvNAME(sv)) {
1371 PerlIO_printf(file, "\t\"");
1372 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1373 PerlIO_printf(file, "%s\" :: \"", hvname);
1374 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1377 PerlIO_putc(file, '\n');
1380 const struct flag_to_name first_sv_flags_names[] = {
1381 {SVs_TEMP, "TEMP,"},
1382 {SVs_OBJECT, "OBJECT,"},
1391 const struct flag_to_name second_sv_flags_names[] = {
1393 {SVf_FAKE, "FAKE,"},
1394 {SVf_READONLY, "READONLY,"},
1395 {SVf_IsCOW, "IsCOW,"},
1396 {SVf_BREAK, "BREAK,"},
1397 {SVf_AMAGIC, "OVERLOAD,"},
1403 const struct flag_to_name cv_flags_names[] = {
1404 {CVf_ANON, "ANON,"},
1405 {CVf_UNIQUE, "UNIQUE,"},
1406 {CVf_CLONE, "CLONE,"},
1407 {CVf_CLONED, "CLONED,"},
1408 {CVf_CONST, "CONST,"},
1409 {CVf_NODEBUG, "NODEBUG,"},
1410 {CVf_LVALUE, "LVALUE,"},
1411 {CVf_METHOD, "METHOD,"},
1412 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1413 {CVf_CVGV_RC, "CVGV_RC,"},
1414 {CVf_DYNFILE, "DYNFILE,"},
1415 {CVf_AUTOLOAD, "AUTOLOAD,"},
1416 {CVf_HASEVAL, "HASEVAL"},
1417 {CVf_SLABBED, "SLABBED,"},
1418 {CVf_ISXSUB, "ISXSUB,"}
1421 const struct flag_to_name hv_flags_names[] = {
1422 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1423 {SVphv_LAZYDEL, "LAZYDEL,"},
1424 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1425 {SVphv_CLONEABLE, "CLONEABLE,"}
1428 const struct flag_to_name gp_flags_names[] = {
1429 {GVf_INTRO, "INTRO,"},
1430 {GVf_MULTI, "MULTI,"},
1431 {GVf_ASSUMECV, "ASSUMECV,"},
1432 {GVf_IN_PAD, "IN_PAD,"}
1435 const struct flag_to_name gp_flags_imported_names[] = {
1436 {GVf_IMPORTED_SV, " SV"},
1437 {GVf_IMPORTED_AV, " AV"},
1438 {GVf_IMPORTED_HV, " HV"},
1439 {GVf_IMPORTED_CV, " CV"},
1442 const struct flag_to_name regexp_flags_names[] = {
1443 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1444 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1445 {RXf_PMf_FOLD, "PMf_FOLD,"},
1446 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1447 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1448 {RXf_ANCH_BOL, "ANCH_BOL,"},
1449 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1450 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1451 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1452 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1453 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1454 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1455 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1456 {RXf_CANY_SEEN, "CANY_SEEN,"},
1457 {RXf_NOSCAN, "NOSCAN,"},
1458 {RXf_CHECK_ALL, "CHECK_ALL,"},
1459 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1460 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1461 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1462 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1463 {RXf_SPLIT, "SPLIT,"},
1464 {RXf_COPY_DONE, "COPY_DONE,"},
1465 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1466 {RXf_TAINTED, "TAINTED,"},
1467 {RXf_START_ONLY, "START_ONLY,"},
1468 {RXf_SKIPWHITE, "SKIPWHITE,"},
1469 {RXf_WHITE, "WHITE,"},
1470 {RXf_NULL, "NULL,"},
1474 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1482 PERL_ARGS_ASSERT_DO_SV_DUMP;
1485 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1489 flags = SvFLAGS(sv);
1492 /* process general SV flags */
1494 d = Perl_newSVpvf(aTHX_
1495 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1496 PTR2UV(SvANY(sv)), PTR2UV(sv),
1497 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1498 (int)(PL_dumpindent*level), "");
1500 if (!((flags & SVpad_NAME) == SVpad_NAME
1501 && (type == SVt_PVMG || type == SVt_PVNV))) {
1502 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1503 sv_catpv(d, "PADSTALE,");
1505 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1506 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1507 sv_catpv(d, "PADTMP,");
1508 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1510 append_flags(d, flags, first_sv_flags_names);
1511 if (flags & SVf_ROK) {
1512 sv_catpv(d, "ROK,");
1513 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1515 append_flags(d, flags, second_sv_flags_names);
1516 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1517 if (SvPCS_IMPORTED(sv))
1518 sv_catpv(d, "PCS_IMPORTED,");
1520 sv_catpv(d, "SCREAM,");
1523 /* process type-specific SV flags */
1528 append_flags(d, CvFLAGS(sv), cv_flags_names);
1531 append_flags(d, flags, hv_flags_names);
1535 if (isGV_with_GP(sv)) {
1536 append_flags(d, GvFLAGS(sv), gp_flags_names);
1538 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1539 sv_catpv(d, "IMPORT");
1540 if (GvIMPORTED(sv) == GVf_IMPORTED)
1541 sv_catpv(d, "ALL,");
1544 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1551 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1552 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1555 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1556 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1557 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1558 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1561 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1566 /* SVphv_SHAREKEYS is also 0x20000000 */
1567 if ((type != SVt_PVHV) && SvUTF8(sv))
1568 sv_catpv(d, "UTF8");
1570 if (*(SvEND(d) - 1) == ',') {
1571 SvCUR_set(d, SvCUR(d) - 1);
1572 SvPVX(d)[SvCUR(d)] = '\0';
1577 /* dump initial SV details */
1579 #ifdef DEBUG_LEAKING_SCALARS
1580 Perl_dump_indent(aTHX_ level, file,
1581 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1582 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1584 sv->sv_debug_inpad ? "for" : "by",
1585 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1586 PTR2UV(sv->sv_debug_parent),
1590 Perl_dump_indent(aTHX_ level, file, "SV = ");
1594 if (type < SVt_LAST) {
1595 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1597 if (type == SVt_NULL) {
1602 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1607 /* Dump general SV fields */
1609 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1610 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1611 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1612 || (type == SVt_IV && !SvROK(sv))) {
1614 #ifdef PERL_OLD_COPY_ON_WRITE
1618 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1620 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1621 #ifdef PERL_OLD_COPY_ON_WRITE
1622 if (SvIsCOW_shared_hash(sv))
1623 PerlIO_printf(file, " (HASH)");
1624 else if (SvIsCOW_normal(sv))
1625 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1627 PerlIO_putc(file, '\n');
1630 if ((type == SVt_PVNV || type == SVt_PVMG)
1631 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1632 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1633 (UV) COP_SEQ_RANGE_LOW(sv));
1634 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1635 (UV) COP_SEQ_RANGE_HIGH(sv));
1636 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1637 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1638 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1639 || type == SVt_NV) {
1640 STORE_NUMERIC_LOCAL_SET_STANDARD();
1641 /* %Vg doesn't work? --jhi */
1642 #ifdef USE_LONG_DOUBLE
1643 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1645 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1647 RESTORE_NUMERIC_LOCAL();
1651 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1653 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1656 if (type < SVt_PV) {
1661 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1662 const bool re = isREGEXP(sv);
1663 const char * const ptr =
1664 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1668 SvOOK_offset(sv, delta);
1669 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1674 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1676 PerlIO_printf(file, "( %s . ) ",
1677 pv_display(d, ptr - delta, delta, 0,
1680 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1683 if (SvUTF8(sv)) /* the 6? \x{....} */
1684 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1685 PerlIO_printf(file, "\n");
1686 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1688 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1690 #ifdef PERL_NEW_COPY_ON_WRITE
1691 if (SvIsCOW(sv) && SvLEN(sv))
1692 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1697 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1700 if (type >= SVt_PVMG) {
1701 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1702 HV * const ost = SvOURSTASH(sv);
1704 do_hv_dump(level, file, " OURSTASH", ost);
1707 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1710 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1712 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1713 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1714 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1715 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1719 /* Dump type-specific SV fields */
1723 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1724 if (AvARRAY(sv) != AvALLOC(sv)) {
1725 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1726 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1729 PerlIO_putc(file, '\n');
1730 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1731 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1732 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1734 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1735 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1736 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1737 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1738 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1740 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1741 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1743 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1745 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1750 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1751 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1752 /* Show distribution of HEs in the ARRAY */
1754 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1757 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1758 NV theoret, sum = 0;
1760 PerlIO_printf(file, " (");
1761 Zero(freq, FREQ_MAX + 1, int);
1762 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1765 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1767 if (count > FREQ_MAX)
1773 for (i = 0; i <= max; i++) {
1775 PerlIO_printf(file, "%d%s:%d", i,
1776 (i == FREQ_MAX) ? "+" : "",
1779 PerlIO_printf(file, ", ");
1782 PerlIO_putc(file, ')');
1783 /* The "quality" of a hash is defined as the total number of
1784 comparisons needed to access every element once, relative
1785 to the expected number needed for a random hash.
1787 The total number of comparisons is equal to the sum of
1788 the squares of the number of entries in each bucket.
1789 For a random hash of n keys into k buckets, the expected
1794 for (i = max; i > 0; i--) { /* Precision: count down. */
1795 sum += freq[i] * i * i;
1797 while ((keys = keys >> 1))
1799 theoret = HvUSEDKEYS(sv);
1800 theoret += theoret * (theoret-1)/pow2;
1801 PerlIO_putc(file, '\n');
1802 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1804 PerlIO_putc(file, '\n');
1805 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1806 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1807 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1809 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1810 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1811 #ifdef PERL_HASH_RANDOMIZE_KEYS
1812 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1813 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1814 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1817 PerlIO_putc(file, '\n');
1820 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1821 if (mg && mg->mg_obj) {
1822 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1826 const char * const hvname = HvNAME_get(sv);
1828 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1832 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1833 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1834 if (HvAUX(sv)->xhv_name_count)
1835 Perl_dump_indent(aTHX_
1836 level, file, " NAMECOUNT = %"IVdf"\n",
1837 (IV)HvAUX(sv)->xhv_name_count
1839 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1840 const I32 count = HvAUX(sv)->xhv_name_count;
1842 SV * const names = newSVpvs_flags("", SVs_TEMP);
1843 /* The starting point is the first element if count is
1844 positive and the second element if count is negative. */
1845 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1846 + (count < 0 ? 1 : 0);
1847 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1848 + (count < 0 ? -count : count);
1849 while (hekp < endp) {
1851 sv_catpvs(names, ", \"");
1852 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1853 sv_catpvs(names, "\"");
1855 /* This should never happen. */
1856 sv_catpvs(names, ", (null)");
1860 Perl_dump_indent(aTHX_
1861 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1865 Perl_dump_indent(aTHX_
1866 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1870 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1872 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1876 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1877 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1878 (int)meta->mro_which->length,
1879 meta->mro_which->name,
1880 PTR2UV(meta->mro_which));
1881 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1882 (UV)meta->cache_gen);
1883 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1885 if (meta->mro_linear_all) {
1886 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1887 PTR2UV(meta->mro_linear_all));
1888 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1891 if (meta->mro_linear_current) {
1892 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1893 PTR2UV(meta->mro_linear_current));
1894 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1897 if (meta->mro_nextmethod) {
1898 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1899 PTR2UV(meta->mro_nextmethod));
1900 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1904 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1906 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1911 if (nest < maxnest) {
1912 HV * const hv = MUTABLE_HV(sv);
1917 int count = maxnest - nest;
1918 for (i=0; i <= HvMAX(hv); i++) {
1919 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1926 if (count-- <= 0) goto DONEHV;
1929 keysv = hv_iterkeysv(he);
1930 keypv = SvPV_const(keysv, len);
1933 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1935 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1936 if (HvEITER_get(hv) == he)
1937 PerlIO_printf(file, "[CURRENT] ");
1938 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1939 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1948 if (CvAUTOLOAD(sv)) {
1950 const char *const name = SvPV_const(sv, len);
1951 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1955 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1956 (int) CvPROTOLEN(sv), CvPROTO(sv));
1960 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1961 if (!CvISXSUB(sv)) {
1963 Perl_dump_indent(aTHX_ level, file,
1964 " START = 0x%"UVxf" ===> %"IVdf"\n",
1965 PTR2UV(CvSTART(sv)),
1966 (IV)sequence_num(CvSTART(sv)));
1968 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1969 PTR2UV(CvROOT(sv)));
1970 if (CvROOT(sv) && dumpops) {
1971 do_op_dump(level+1, file, CvROOT(sv));
1974 SV * const constant = cv_const_sv((const CV *)sv);
1976 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1979 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1981 PTR2UV(CvXSUBANY(sv).any_ptr));
1982 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1985 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1986 (IV)CvXSUBANY(sv).any_i32);
1990 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1991 HEK_KEY(CvNAME_HEK((CV *)sv)));
1992 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1993 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1994 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1995 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1996 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1997 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1998 if (nest < maxnest) {
1999 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2002 const CV * const outside = CvOUTSIDE(sv);
2003 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2006 : CvANON(outside) ? "ANON"
2007 : (outside == PL_main_cv) ? "MAIN"
2008 : CvUNIQUE(outside) ? "UNIQUE"
2009 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2011 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2012 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2017 if (type == SVt_PVLV) {
2018 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2019 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2020 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2021 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2022 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2023 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2024 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2027 if (isREGEXP(sv)) goto dumpregexp;
2028 if (!isGV_with_GP(sv))
2030 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2031 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2032 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2033 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2038 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2044 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2045 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2046 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2047 do_gv_dump (level, file, " EGV", GvEGV(sv));
2050 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2051 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2052 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2054 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2055 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2056 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2058 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2059 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2060 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2062 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2063 PTR2UV(IoTOP_GV(sv)));
2064 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2065 maxnest, dumpops, pvlim);
2067 /* Source filters hide things that are not GVs in these three, so let's
2068 be careful out there. */
2070 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2071 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2072 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2074 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2075 PTR2UV(IoFMT_GV(sv)));
2076 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2077 maxnest, dumpops, pvlim);
2079 if (IoBOTTOM_NAME(sv))
2080 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2081 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2082 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2084 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2085 PTR2UV(IoBOTTOM_GV(sv)));
2086 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2087 maxnest, dumpops, pvlim);
2089 if (isPRINT(IoTYPE(sv)))
2090 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2093 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2098 struct regexp * const r = ReANY((REGEXP*)sv);
2099 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2101 append_flags(d, flags, regexp_flags_names); \
2102 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2103 SvCUR_set(d, SvCUR(d) - 1); \
2104 SvPVX(d)[SvCUR(d)] = '\0'; \
2107 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2108 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2109 (UV)(r->compflags), SvPVX_const(d));
2111 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2112 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2113 (UV)(r->extflags), SvPVX_const(d));
2114 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2116 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2118 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2120 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2121 (UV)(r->lastparen));
2122 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2123 (UV)(r->lastcloseparen));
2124 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2126 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2127 (IV)(r->minlenret));
2128 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2130 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2131 (UV)(r->pre_prefix));
2132 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2134 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2135 (IV)(r->suboffset));
2136 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2137 (IV)(r->subcoffset));
2139 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2141 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2143 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2144 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2146 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2147 PTR2UV(r->mother_re));
2148 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2149 PTR2UV(r->paren_names));
2150 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2151 PTR2UV(r->substrs));
2152 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2153 PTR2UV(r->pprivate));
2154 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2156 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2157 PTR2UV(r->qr_anoncv));
2159 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2160 PTR2UV(r->saved_copy));
2169 Perl_sv_dump(pTHX_ SV *sv)
2173 PERL_ARGS_ASSERT_SV_DUMP;
2176 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2178 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2182 Perl_runops_debug(pTHX)
2186 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2190 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2193 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2194 PerlIO_printf(Perl_debug_log,
2195 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2196 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2197 PTR2UV(*PL_watchaddr));
2198 if (DEBUG_s_TEST_) {
2199 if (DEBUG_v_TEST_) {
2200 PerlIO_printf(Perl_debug_log, "\n");
2208 if (DEBUG_t_TEST_) debop(PL_op);
2209 if (DEBUG_P_TEST_) debprof(PL_op);
2212 OP_ENTRY_PROBE(OP_NAME(PL_op));
2213 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2214 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2222 Perl_debop(pTHX_ const OP *o)
2226 PERL_ARGS_ASSERT_DEBOP;
2228 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2231 Perl_deb(aTHX_ "%s", OP_NAME(o));
2232 switch (o->op_type) {
2235 /* With ITHREADS, consts are stored in the pad, and the right pad
2236 * may not be active here, so check.
2237 * Looks like only during compiling the pads are illegal.
2240 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2242 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2247 SV * const sv = newSV(0);
2249 /* FIXME - is this making unwarranted assumptions about the
2250 UTF-8 cleanliness of the dump file handle? */
2253 gv_fullname3(sv, cGVOPo_gv, NULL);
2254 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2255 SvREFCNT_dec_NN(sv);
2258 PerlIO_printf(Perl_debug_log, "(NULL)");
2270 count = o->op_private & OPpPADRANGE_COUNTMASK;
2272 /* print the lexical's name */
2274 CV * const cv = deb_curcv(cxstack_ix);
2276 PAD * comppad = NULL;
2280 PADLIST * const padlist = CvPADLIST(cv);
2281 comppad = *PadlistARRAY(padlist);
2283 PerlIO_printf(Perl_debug_log, "(");
2284 for (i = 0; i < count; i++) {
2286 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2287 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2289 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2292 PerlIO_printf(Perl_debug_log, ",");
2294 PerlIO_printf(Perl_debug_log, ")");
2302 PerlIO_printf(Perl_debug_log, "\n");
2307 S_deb_curcv(pTHX_ const I32 ix)
2310 const PERL_CONTEXT * const cx = &cxstack[ix];
2311 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2312 return cx->blk_sub.cv;
2313 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2314 return cx->blk_eval.cv;
2315 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2320 return deb_curcv(ix - 1);
2324 Perl_watch(pTHX_ char **addr)
2328 PERL_ARGS_ASSERT_WATCH;
2330 PL_watchaddr = addr;
2332 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2333 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2337 S_debprof(pTHX_ const OP *o)
2341 PERL_ARGS_ASSERT_DEBPROF;
2343 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2345 if (!PL_profiledata)
2346 Newxz(PL_profiledata, MAXO, U32);
2347 ++PL_profiledata[o->op_type];
2351 Perl_debprofdump(pTHX)
2355 if (!PL_profiledata)
2357 for (i = 0; i < MAXO; i++) {
2358 if (PL_profiledata[i])
2359 PerlIO_printf(Perl_debug_log,
2360 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2367 * XML variants of most of the above routines
2371 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2375 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2377 PerlIO_printf(file, "\n ");
2378 va_start(args, pat);
2379 xmldump_vindent(level, file, pat, &args);
2385 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2388 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2389 va_start(args, pat);
2390 xmldump_vindent(level, file, pat, &args);
2395 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2397 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2399 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2400 PerlIO_vprintf(file, pat, *args);
2404 Perl_xmldump_all(pTHX)
2406 xmldump_all_perl(FALSE);
2410 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2412 PerlIO_setlinebuf(PL_xmlfp);
2414 op_xmldump(PL_main_root);
2415 /* someday we might call this, when it outputs XML: */
2416 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2417 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2418 PerlIO_close(PL_xmlfp);
2423 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2425 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2426 xmldump_packsubs_perl(stash, FALSE);
2430 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2435 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2437 if (!HvARRAY(stash))
2439 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2440 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2441 GV *gv = MUTABLE_GV(HeVAL(entry));
2443 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2446 xmldump_sub_perl(gv, justperl);
2449 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2450 && (hv = GvHV(gv)) && hv != PL_defstash)
2451 xmldump_packsubs_perl(hv, justperl); /* nested package */
2457 Perl_xmldump_sub(pTHX_ const GV *gv)
2459 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2460 xmldump_sub_perl(gv, FALSE);
2464 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2468 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2470 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2473 sv = sv_newmortal();
2474 gv_fullname3(sv, gv, NULL);
2475 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2476 if (CvXSUB(GvCV(gv)))
2477 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2478 PTR2UV(CvXSUB(GvCV(gv))),
2479 (int)CvXSUBANY(GvCV(gv)).any_i32);
2480 else if (CvROOT(GvCV(gv)))
2481 op_xmldump(CvROOT(GvCV(gv)));
2483 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2487 Perl_xmldump_form(pTHX_ const GV *gv)
2489 SV * const sv = sv_newmortal();
2491 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2493 gv_fullname3(sv, gv, NULL);
2494 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2495 if (CvROOT(GvFORM(gv)))
2496 op_xmldump(CvROOT(GvFORM(gv)));
2498 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2502 Perl_xmldump_eval(pTHX)
2504 op_xmldump(PL_eval_root);
2508 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2510 PERL_ARGS_ASSERT_SV_CATXMLSV;
2511 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2515 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2517 PERL_ARGS_ASSERT_SV_CATXMLPV;
2518 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2522 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2525 const char * const e = pv + len;
2526 const char * const start = pv;
2530 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2533 dsvcur = SvCUR(dsv); /* in case we have to restart */
2538 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2540 SvCUR(dsv) = dsvcur;
2605 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2608 sv_catpvs(dsv, "<");
2611 sv_catpvs(dsv, ">");
2614 sv_catpvs(dsv, "&");
2617 sv_catpvs(dsv, """);
2621 if (c < 32 || c > 127) {
2622 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2625 const char string = (char) c;
2626 sv_catpvn(dsv, &string, 1);
2630 if ((c >= 0xD800 && c <= 0xDB7F) ||
2631 (c >= 0xDC00 && c <= 0xDFFF) ||
2632 (c >= 0xFFF0 && c <= 0xFFFF) ||
2634 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2636 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2649 Perl_sv_xmlpeek(pTHX_ SV *sv)
2651 SV * const t = sv_newmortal();
2655 PERL_ARGS_ASSERT_SV_XMLPEEK;
2661 sv_catpv(t, "VOID=\"\"");
2664 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2665 sv_catpv(t, "WILD=\"\"");
2668 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2669 if (sv == &PL_sv_undef) {
2670 sv_catpv(t, "SV_UNDEF=\"1\"");
2671 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2672 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2676 else if (sv == &PL_sv_no) {
2677 sv_catpv(t, "SV_NO=\"1\"");
2678 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2679 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2680 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2681 SVp_POK|SVp_NOK)) &&
2686 else if (sv == &PL_sv_yes) {
2687 sv_catpv(t, "SV_YES=\"1\"");
2688 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2689 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2690 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2691 SVp_POK|SVp_NOK)) &&
2693 SvPVX(sv) && *SvPVX(sv) == '1' &&
2698 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2699 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2700 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2704 sv_catpv(t, " XXX=\"\" ");
2706 else if (SvREFCNT(sv) == 0) {
2707 sv_catpv(t, " refcnt=\"0\"");
2710 else if (DEBUG_R_TEST_) {
2713 /* is this SV on the tmps stack? */
2714 for (ix=PL_tmps_ix; ix>=0; ix--) {
2715 if (PL_tmps_stack[ix] == sv) {
2720 if (SvREFCNT(sv) > 1)
2721 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2724 sv_catpv(t, " DRT=\"<T>\"");
2728 sv_catpv(t, " ROK=\"\"");
2730 switch (SvTYPE(sv)) {
2732 sv_catpv(t, " FREED=\"1\"");
2736 sv_catpv(t, " UNDEF=\"1\"");
2739 sv_catpv(t, " IV=\"");
2742 sv_catpv(t, " NV=\"");
2745 sv_catpv(t, " PV=\"");
2748 sv_catpv(t, " PVIV=\"");
2751 sv_catpv(t, " PVNV=\"");
2754 sv_catpv(t, " PVMG=\"");
2757 sv_catpv(t, " PVLV=\"");
2760 sv_catpv(t, " AV=\"");
2763 sv_catpv(t, " HV=\"");
2767 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2769 sv_catpv(t, " CV=\"()\"");
2772 sv_catpv(t, " GV=\"");
2775 sv_catpv(t, " DUMMY=\"");
2778 sv_catpv(t, " REGEXP=\"");
2781 sv_catpv(t, " FM=\"");
2784 sv_catpv(t, " IO=\"");
2793 else if (SvNOKp(sv)) {
2794 STORE_NUMERIC_LOCAL_SET_STANDARD();
2795 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2796 RESTORE_NUMERIC_LOCAL();
2798 else if (SvIOKp(sv)) {
2800 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2802 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2811 return SvPV(t, n_a);
2815 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2817 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2820 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2823 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2826 REGEXP *const r = PM_GETRE(pm);
2827 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2828 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2829 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2831 SvREFCNT_dec_NN(tmpsv);
2832 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2833 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2836 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2837 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2838 SV * const tmpsv = pm_description(pm);
2839 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2840 SvREFCNT_dec_NN(tmpsv);
2844 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2845 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2846 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2847 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2848 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2849 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2852 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2856 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2858 do_pmop_xmldump(0, PL_xmlfp, pm);
2862 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2866 const OPCODE optype = o->op_type;
2868 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2872 seq = sequence_num(o);
2873 Perl_xmldump_indent(aTHX_ level, file,
2874 "<op_%s seq=\"%"UVuf" -> ",
2879 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2880 sequence_num(o->op_next));
2882 PerlIO_printf(file, "DONE\"");
2885 if (optype == OP_NULL)
2887 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2888 if (o->op_targ == OP_NEXTSTATE)
2891 PerlIO_printf(file, " line=\"%"UVuf"\"",
2892 (UV)CopLINE(cCOPo));
2893 if (CopSTASHPV(cCOPo))
2894 PerlIO_printf(file, " package=\"%s\"",
2896 if (CopLABEL(cCOPo))
2897 PerlIO_printf(file, " label=\"%s\"",
2902 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2905 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2908 DUMP_OP_FLAGS(o,1,0,file);
2909 DUMP_OP_PRIVATE(o,1,0,file);
2913 if (o->op_flags & OPf_SPECIAL) {
2919 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2921 if (cSVOPo->op_sv) {
2922 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2923 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2929 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2930 s = SvPV(tmpsv1,len);
2931 sv_catxmlpvn(tmpsv2, s, len, 1);
2932 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2936 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2941 case OP_METHOD_NAMED:
2942 #ifndef USE_ITHREADS
2943 /* with ITHREADS, consts are stored in the pad, and the right pad
2944 * may not be active here, so skip */
2945 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2951 PerlIO_printf(file, ">\n");
2953 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2958 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2959 (UV)CopLINE(cCOPo));
2960 if (CopSTASHPV(cCOPo))
2961 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2963 if (CopLABEL(cCOPo))
2964 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2968 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2969 if (cLOOPo->op_redoop)
2970 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2972 PerlIO_printf(file, "DONE\"");
2973 S_xmldump_attr(aTHX_ level, file, "next=\"");
2974 if (cLOOPo->op_nextop)
2975 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2977 PerlIO_printf(file, "DONE\"");
2978 S_xmldump_attr(aTHX_ level, file, "last=\"");
2979 if (cLOOPo->op_lastop)
2980 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2982 PerlIO_printf(file, "DONE\"");
2990 S_xmldump_attr(aTHX_ level, file, "other=\"");
2991 if (cLOGOPo->op_other)
2992 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2994 PerlIO_printf(file, "DONE\"");
3002 if (o->op_private & OPpREFCOUNTED)
3003 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3009 if (PL_madskills && o->op_madprop) {
3010 char prevkey = '\0';
3011 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3012 const MADPROP* mp = o->op_madprop;
3016 PerlIO_printf(file, ">\n");
3018 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3021 char tmp = mp->mad_key;
3022 sv_setpvs(tmpsv,"\"");
3024 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3025 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3026 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3029 sv_catpv(tmpsv, "\"");
3030 switch (mp->mad_type) {
3032 sv_catpv(tmpsv, "NULL");
3033 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3036 sv_catpv(tmpsv, " val=\"");
3037 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3038 sv_catpv(tmpsv, "\"");
3039 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3042 sv_catpv(tmpsv, " val=\"");
3043 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3044 sv_catpv(tmpsv, "\"");
3045 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3048 if ((OP*)mp->mad_val) {
3049 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3050 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3051 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3055 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3061 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3063 SvREFCNT_dec_NN(tmpsv);
3073 PerlIO_printf(file, ">\n");
3075 do_pmop_xmldump(level, file, cPMOPo);
3081 if (o->op_flags & OPf_KIDS) {
3085 PerlIO_printf(file, ">\n");
3087 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3088 do_op_xmldump(level, file, kid);
3092 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3094 PerlIO_printf(file, " />\n");
3098 Perl_op_xmldump(pTHX_ const OP *o)
3100 PERL_ARGS_ASSERT_OP_XMLDUMP;
3102 do_op_xmldump(0, PL_xmlfp, o);
3108 * c-indentation-style: bsd
3110 * indent-tabs-mode: nil
3113 * ex: set ts=8 sts=4 sw=4 et: