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));
1808 HE **ents = HvARRAY(sv);
1811 HE *const *const last = ents + HvMAX(sv);
1812 count = last + 1 - ents;
1817 } while (++ents <= last);
1821 struct xpvhv_aux *const aux = HvAUX(sv);
1822 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1823 " (cached = %"UVuf")\n",
1824 (UV)count, (UV)aux->xhv_fill_lazy);
1826 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1830 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1832 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1833 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1834 #ifdef PERL_HASH_RANDOMIZE_KEYS
1835 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1836 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1837 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1840 PerlIO_putc(file, '\n');
1843 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1844 if (mg && mg->mg_obj) {
1845 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1849 const char * const hvname = HvNAME_get(sv);
1851 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1855 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1856 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1857 if (HvAUX(sv)->xhv_name_count)
1858 Perl_dump_indent(aTHX_
1859 level, file, " NAMECOUNT = %"IVdf"\n",
1860 (IV)HvAUX(sv)->xhv_name_count
1862 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1863 const I32 count = HvAUX(sv)->xhv_name_count;
1865 SV * const names = newSVpvs_flags("", SVs_TEMP);
1866 /* The starting point is the first element if count is
1867 positive and the second element if count is negative. */
1868 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1869 + (count < 0 ? 1 : 0);
1870 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1871 + (count < 0 ? -count : count);
1872 while (hekp < endp) {
1874 sv_catpvs(names, ", \"");
1875 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1876 sv_catpvs(names, "\"");
1878 /* This should never happen. */
1879 sv_catpvs(names, ", (null)");
1883 Perl_dump_indent(aTHX_
1884 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1888 Perl_dump_indent(aTHX_
1889 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1893 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1895 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1899 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1900 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1901 (int)meta->mro_which->length,
1902 meta->mro_which->name,
1903 PTR2UV(meta->mro_which));
1904 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1905 (UV)meta->cache_gen);
1906 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1908 if (meta->mro_linear_all) {
1909 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1910 PTR2UV(meta->mro_linear_all));
1911 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1914 if (meta->mro_linear_current) {
1915 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1916 PTR2UV(meta->mro_linear_current));
1917 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1920 if (meta->mro_nextmethod) {
1921 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1922 PTR2UV(meta->mro_nextmethod));
1923 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1927 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1929 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1934 if (nest < maxnest) {
1935 HV * const hv = MUTABLE_HV(sv);
1940 int count = maxnest - nest;
1941 for (i=0; i <= HvMAX(hv); i++) {
1942 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1949 if (count-- <= 0) goto DONEHV;
1952 keysv = hv_iterkeysv(he);
1953 keypv = SvPV_const(keysv, len);
1956 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1958 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1959 if (HvEITER_get(hv) == he)
1960 PerlIO_printf(file, "[CURRENT] ");
1961 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1962 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1971 if (CvAUTOLOAD(sv)) {
1973 const char *const name = SvPV_const(sv, len);
1974 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1978 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1979 (int) CvPROTOLEN(sv), CvPROTO(sv));
1983 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1984 if (!CvISXSUB(sv)) {
1986 Perl_dump_indent(aTHX_ level, file,
1987 " START = 0x%"UVxf" ===> %"IVdf"\n",
1988 PTR2UV(CvSTART(sv)),
1989 (IV)sequence_num(CvSTART(sv)));
1991 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1992 PTR2UV(CvROOT(sv)));
1993 if (CvROOT(sv) && dumpops) {
1994 do_op_dump(level+1, file, CvROOT(sv));
1997 SV * const constant = cv_const_sv((const CV *)sv);
1999 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2002 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2004 PTR2UV(CvXSUBANY(sv).any_ptr));
2005 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2008 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2009 (IV)CvXSUBANY(sv).any_i32);
2013 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2014 HEK_KEY(CvNAME_HEK((CV *)sv)));
2015 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2016 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2017 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2018 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2019 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2020 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2021 if (nest < maxnest) {
2022 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2025 const CV * const outside = CvOUTSIDE(sv);
2026 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2029 : CvANON(outside) ? "ANON"
2030 : (outside == PL_main_cv) ? "MAIN"
2031 : CvUNIQUE(outside) ? "UNIQUE"
2032 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2034 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2035 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2040 if (type == SVt_PVLV) {
2041 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2042 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2043 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2044 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2045 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2046 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2047 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2050 if (isREGEXP(sv)) goto dumpregexp;
2051 if (!isGV_with_GP(sv))
2053 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2054 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2055 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2056 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2059 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2060 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2061 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2062 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2063 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2064 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2065 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2066 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2067 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2068 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2069 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2070 do_gv_dump (level, file, " EGV", GvEGV(sv));
2073 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2074 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2075 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2076 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2077 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2078 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2079 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2081 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2082 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2083 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2085 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2086 PTR2UV(IoTOP_GV(sv)));
2087 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2088 maxnest, dumpops, pvlim);
2090 /* Source filters hide things that are not GVs in these three, so let's
2091 be careful out there. */
2093 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2094 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2095 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2097 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2098 PTR2UV(IoFMT_GV(sv)));
2099 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2100 maxnest, dumpops, pvlim);
2102 if (IoBOTTOM_NAME(sv))
2103 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2104 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2105 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2107 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2108 PTR2UV(IoBOTTOM_GV(sv)));
2109 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2110 maxnest, dumpops, pvlim);
2112 if (isPRINT(IoTYPE(sv)))
2113 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2115 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2116 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2121 struct regexp * const r = ReANY((REGEXP*)sv);
2122 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2124 append_flags(d, flags, regexp_flags_names); \
2125 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2126 SvCUR_set(d, SvCUR(d) - 1); \
2127 SvPVX(d)[SvCUR(d)] = '\0'; \
2130 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2131 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2132 (UV)(r->compflags), SvPVX_const(d));
2134 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2135 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2136 (UV)(r->extflags), SvPVX_const(d));
2137 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2139 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2141 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2143 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2144 (UV)(r->lastparen));
2145 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2146 (UV)(r->lastcloseparen));
2147 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2149 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2150 (IV)(r->minlenret));
2151 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2153 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2154 (UV)(r->pre_prefix));
2155 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2157 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2158 (IV)(r->suboffset));
2159 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2160 (IV)(r->subcoffset));
2162 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2164 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2166 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2167 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2169 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2170 PTR2UV(r->mother_re));
2171 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2172 PTR2UV(r->paren_names));
2173 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2174 PTR2UV(r->substrs));
2175 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2176 PTR2UV(r->pprivate));
2177 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2179 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2180 PTR2UV(r->qr_anoncv));
2182 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2183 PTR2UV(r->saved_copy));
2192 Perl_sv_dump(pTHX_ SV *sv)
2196 PERL_ARGS_ASSERT_SV_DUMP;
2199 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2201 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2205 Perl_runops_debug(pTHX)
2209 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2213 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2216 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2217 PerlIO_printf(Perl_debug_log,
2218 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2219 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2220 PTR2UV(*PL_watchaddr));
2221 if (DEBUG_s_TEST_) {
2222 if (DEBUG_v_TEST_) {
2223 PerlIO_printf(Perl_debug_log, "\n");
2231 if (DEBUG_t_TEST_) debop(PL_op);
2232 if (DEBUG_P_TEST_) debprof(PL_op);
2235 OP_ENTRY_PROBE(OP_NAME(PL_op));
2236 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2237 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2245 Perl_debop(pTHX_ const OP *o)
2249 PERL_ARGS_ASSERT_DEBOP;
2251 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2254 Perl_deb(aTHX_ "%s", OP_NAME(o));
2255 switch (o->op_type) {
2258 /* With ITHREADS, consts are stored in the pad, and the right pad
2259 * may not be active here, so check.
2260 * Looks like only during compiling the pads are illegal.
2263 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2265 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2270 SV * const sv = newSV(0);
2272 /* FIXME - is this making unwarranted assumptions about the
2273 UTF-8 cleanliness of the dump file handle? */
2276 gv_fullname3(sv, cGVOPo_gv, NULL);
2277 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2278 SvREFCNT_dec_NN(sv);
2281 PerlIO_printf(Perl_debug_log, "(NULL)");
2293 count = o->op_private & OPpPADRANGE_COUNTMASK;
2295 /* print the lexical's name */
2297 CV * const cv = deb_curcv(cxstack_ix);
2299 PAD * comppad = NULL;
2303 PADLIST * const padlist = CvPADLIST(cv);
2304 comppad = *PadlistARRAY(padlist);
2306 PerlIO_printf(Perl_debug_log, "(");
2307 for (i = 0; i < count; i++) {
2309 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2310 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2312 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2315 PerlIO_printf(Perl_debug_log, ",");
2317 PerlIO_printf(Perl_debug_log, ")");
2325 PerlIO_printf(Perl_debug_log, "\n");
2330 S_deb_curcv(pTHX_ const I32 ix)
2333 const PERL_CONTEXT * const cx = &cxstack[ix];
2334 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2335 return cx->blk_sub.cv;
2336 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2337 return cx->blk_eval.cv;
2338 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2343 return deb_curcv(ix - 1);
2347 Perl_watch(pTHX_ char **addr)
2351 PERL_ARGS_ASSERT_WATCH;
2353 PL_watchaddr = addr;
2355 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2356 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2360 S_debprof(pTHX_ const OP *o)
2364 PERL_ARGS_ASSERT_DEBPROF;
2366 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2368 if (!PL_profiledata)
2369 Newxz(PL_profiledata, MAXO, U32);
2370 ++PL_profiledata[o->op_type];
2374 Perl_debprofdump(pTHX)
2378 if (!PL_profiledata)
2380 for (i = 0; i < MAXO; i++) {
2381 if (PL_profiledata[i])
2382 PerlIO_printf(Perl_debug_log,
2383 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2390 * XML variants of most of the above routines
2394 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2398 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2400 PerlIO_printf(file, "\n ");
2401 va_start(args, pat);
2402 xmldump_vindent(level, file, pat, &args);
2408 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2411 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2412 va_start(args, pat);
2413 xmldump_vindent(level, file, pat, &args);
2418 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2420 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2422 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2423 PerlIO_vprintf(file, pat, *args);
2427 Perl_xmldump_all(pTHX)
2429 xmldump_all_perl(FALSE);
2433 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2435 PerlIO_setlinebuf(PL_xmlfp);
2437 op_xmldump(PL_main_root);
2438 /* someday we might call this, when it outputs XML: */
2439 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2440 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2441 PerlIO_close(PL_xmlfp);
2446 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2448 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2449 xmldump_packsubs_perl(stash, FALSE);
2453 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2458 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2460 if (!HvARRAY(stash))
2462 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2463 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2464 GV *gv = MUTABLE_GV(HeVAL(entry));
2466 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2469 xmldump_sub_perl(gv, justperl);
2472 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2473 && (hv = GvHV(gv)) && hv != PL_defstash)
2474 xmldump_packsubs_perl(hv, justperl); /* nested package */
2480 Perl_xmldump_sub(pTHX_ const GV *gv)
2482 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2483 xmldump_sub_perl(gv, FALSE);
2487 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2491 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2493 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2496 sv = sv_newmortal();
2497 gv_fullname3(sv, gv, NULL);
2498 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2499 if (CvXSUB(GvCV(gv)))
2500 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2501 PTR2UV(CvXSUB(GvCV(gv))),
2502 (int)CvXSUBANY(GvCV(gv)).any_i32);
2503 else if (CvROOT(GvCV(gv)))
2504 op_xmldump(CvROOT(GvCV(gv)));
2506 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2510 Perl_xmldump_form(pTHX_ const GV *gv)
2512 SV * const sv = sv_newmortal();
2514 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2516 gv_fullname3(sv, gv, NULL);
2517 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2518 if (CvROOT(GvFORM(gv)))
2519 op_xmldump(CvROOT(GvFORM(gv)));
2521 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2525 Perl_xmldump_eval(pTHX)
2527 op_xmldump(PL_eval_root);
2531 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2533 PERL_ARGS_ASSERT_SV_CATXMLSV;
2534 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2538 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2540 PERL_ARGS_ASSERT_SV_CATXMLPV;
2541 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2545 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2548 const char * const e = pv + len;
2549 const char * const start = pv;
2553 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2556 dsvcur = SvCUR(dsv); /* in case we have to restart */
2561 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2563 SvCUR(dsv) = dsvcur;
2628 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2631 sv_catpvs(dsv, "<");
2634 sv_catpvs(dsv, ">");
2637 sv_catpvs(dsv, "&");
2640 sv_catpvs(dsv, """);
2644 if (c < 32 || c > 127) {
2645 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2648 const char string = (char) c;
2649 sv_catpvn(dsv, &string, 1);
2653 if ((c >= 0xD800 && c <= 0xDB7F) ||
2654 (c >= 0xDC00 && c <= 0xDFFF) ||
2655 (c >= 0xFFF0 && c <= 0xFFFF) ||
2657 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2659 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2672 Perl_sv_xmlpeek(pTHX_ SV *sv)
2674 SV * const t = sv_newmortal();
2678 PERL_ARGS_ASSERT_SV_XMLPEEK;
2684 sv_catpv(t, "VOID=\"\"");
2687 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2688 sv_catpv(t, "WILD=\"\"");
2691 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2692 if (sv == &PL_sv_undef) {
2693 sv_catpv(t, "SV_UNDEF=\"1\"");
2694 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2695 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2699 else if (sv == &PL_sv_no) {
2700 sv_catpv(t, "SV_NO=\"1\"");
2701 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2702 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2703 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2704 SVp_POK|SVp_NOK)) &&
2709 else if (sv == &PL_sv_yes) {
2710 sv_catpv(t, "SV_YES=\"1\"");
2711 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2712 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2713 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2714 SVp_POK|SVp_NOK)) &&
2716 SvPVX(sv) && *SvPVX(sv) == '1' &&
2721 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2722 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2723 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2727 sv_catpv(t, " XXX=\"\" ");
2729 else if (SvREFCNT(sv) == 0) {
2730 sv_catpv(t, " refcnt=\"0\"");
2733 else if (DEBUG_R_TEST_) {
2736 /* is this SV on the tmps stack? */
2737 for (ix=PL_tmps_ix; ix>=0; ix--) {
2738 if (PL_tmps_stack[ix] == sv) {
2743 if (SvREFCNT(sv) > 1)
2744 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2747 sv_catpv(t, " DRT=\"<T>\"");
2751 sv_catpv(t, " ROK=\"\"");
2753 switch (SvTYPE(sv)) {
2755 sv_catpv(t, " FREED=\"1\"");
2759 sv_catpv(t, " UNDEF=\"1\"");
2762 sv_catpv(t, " IV=\"");
2765 sv_catpv(t, " NV=\"");
2768 sv_catpv(t, " PV=\"");
2771 sv_catpv(t, " PVIV=\"");
2774 sv_catpv(t, " PVNV=\"");
2777 sv_catpv(t, " PVMG=\"");
2780 sv_catpv(t, " PVLV=\"");
2783 sv_catpv(t, " AV=\"");
2786 sv_catpv(t, " HV=\"");
2790 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2792 sv_catpv(t, " CV=\"()\"");
2795 sv_catpv(t, " GV=\"");
2798 sv_catpv(t, " DUMMY=\"");
2801 sv_catpv(t, " REGEXP=\"");
2804 sv_catpv(t, " FM=\"");
2807 sv_catpv(t, " IO=\"");
2816 else if (SvNOKp(sv)) {
2817 STORE_NUMERIC_LOCAL_SET_STANDARD();
2818 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2819 RESTORE_NUMERIC_LOCAL();
2821 else if (SvIOKp(sv)) {
2823 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2825 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2834 return SvPV(t, n_a);
2838 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2840 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2843 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2846 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2849 REGEXP *const r = PM_GETRE(pm);
2850 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2851 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2852 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2854 SvREFCNT_dec_NN(tmpsv);
2855 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2856 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2859 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2860 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2861 SV * const tmpsv = pm_description(pm);
2862 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2863 SvREFCNT_dec_NN(tmpsv);
2867 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2868 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2869 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2870 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2871 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2872 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2875 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2879 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2881 do_pmop_xmldump(0, PL_xmlfp, pm);
2885 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2889 const OPCODE optype = o->op_type;
2891 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2895 seq = sequence_num(o);
2896 Perl_xmldump_indent(aTHX_ level, file,
2897 "<op_%s seq=\"%"UVuf" -> ",
2902 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2903 sequence_num(o->op_next));
2905 PerlIO_printf(file, "DONE\"");
2908 if (optype == OP_NULL)
2910 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2911 if (o->op_targ == OP_NEXTSTATE)
2914 PerlIO_printf(file, " line=\"%"UVuf"\"",
2915 (UV)CopLINE(cCOPo));
2916 if (CopSTASHPV(cCOPo))
2917 PerlIO_printf(file, " package=\"%s\"",
2919 if (CopLABEL(cCOPo))
2920 PerlIO_printf(file, " label=\"%s\"",
2925 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2928 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2931 DUMP_OP_FLAGS(o,1,0,file);
2932 DUMP_OP_PRIVATE(o,1,0,file);
2936 if (o->op_flags & OPf_SPECIAL) {
2942 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2944 if (cSVOPo->op_sv) {
2945 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2946 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2952 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2953 s = SvPV(tmpsv1,len);
2954 sv_catxmlpvn(tmpsv2, s, len, 1);
2955 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2959 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2964 case OP_METHOD_NAMED:
2965 #ifndef USE_ITHREADS
2966 /* with ITHREADS, consts are stored in the pad, and the right pad
2967 * may not be active here, so skip */
2968 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2974 PerlIO_printf(file, ">\n");
2976 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2981 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2982 (UV)CopLINE(cCOPo));
2983 if (CopSTASHPV(cCOPo))
2984 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2986 if (CopLABEL(cCOPo))
2987 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2991 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2992 if (cLOOPo->op_redoop)
2993 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2995 PerlIO_printf(file, "DONE\"");
2996 S_xmldump_attr(aTHX_ level, file, "next=\"");
2997 if (cLOOPo->op_nextop)
2998 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3000 PerlIO_printf(file, "DONE\"");
3001 S_xmldump_attr(aTHX_ level, file, "last=\"");
3002 if (cLOOPo->op_lastop)
3003 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3005 PerlIO_printf(file, "DONE\"");
3013 S_xmldump_attr(aTHX_ level, file, "other=\"");
3014 if (cLOGOPo->op_other)
3015 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3017 PerlIO_printf(file, "DONE\"");
3025 if (o->op_private & OPpREFCOUNTED)
3026 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3032 if (PL_madskills && o->op_madprop) {
3033 char prevkey = '\0';
3034 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3035 const MADPROP* mp = o->op_madprop;
3039 PerlIO_printf(file, ">\n");
3041 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3044 char tmp = mp->mad_key;
3045 sv_setpvs(tmpsv,"\"");
3047 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3048 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3049 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3052 sv_catpv(tmpsv, "\"");
3053 switch (mp->mad_type) {
3055 sv_catpv(tmpsv, "NULL");
3056 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3059 sv_catpv(tmpsv, " val=\"");
3060 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3061 sv_catpv(tmpsv, "\"");
3062 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3065 sv_catpv(tmpsv, " val=\"");
3066 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3067 sv_catpv(tmpsv, "\"");
3068 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3071 if ((OP*)mp->mad_val) {
3072 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3073 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3074 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3078 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3084 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3086 SvREFCNT_dec_NN(tmpsv);
3096 PerlIO_printf(file, ">\n");
3098 do_pmop_xmldump(level, file, cPMOPo);
3104 if (o->op_flags & OPf_KIDS) {
3108 PerlIO_printf(file, ">\n");
3110 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3111 do_op_xmldump(level, file, kid);
3115 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3117 PerlIO_printf(file, " />\n");
3121 Perl_op_xmldump(pTHX_ const OP *o)
3123 PERL_ARGS_ASSERT_OP_XMLDUMP;
3125 do_op_xmldump(0, PL_xmlfp, o);
3131 * c-indentation-style: bsd
3133 * indent-tabs-mode: nil
3136 * ex: set ts=8 sts=4 sw=4 et: