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");
677 append_flags(desc, pmflags, pmflags_flags_names);
682 Perl_pmop_dump(pTHX_ PMOP *pm)
684 do_pmop_dump(0, Perl_debug_log, pm);
687 /* Return a unique integer to represent the address of op o.
688 * If it already exists in PL_op_sequence, just return it;
690 * *** Note that this isn't thread-safe */
693 S_sequence_num(pTHX_ const OP *o)
702 op = newSVuv(PTR2UV(o));
704 key = SvPV_const(op, len);
706 PL_op_sequence = newHV();
707 seq = hv_fetch(PL_op_sequence, key, len, 0);
710 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
714 const struct flag_to_name op_flags_names[] = {
716 {OPf_PARENS, ",PARENS"},
719 {OPf_STACKED, ",STACKED"},
720 {OPf_SPECIAL, ",SPECIAL"}
723 const struct flag_to_name op_trans_names[] = {
724 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
725 {OPpTRANS_TO_UTF, ",TO_UTF"},
726 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
727 {OPpTRANS_SQUASH, ",SQUASH"},
728 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
729 {OPpTRANS_GROWS, ",GROWS"},
730 {OPpTRANS_DELETE, ",DELETE"}
733 const struct flag_to_name op_entersub_names[] = {
734 {OPpENTERSUB_DB, ",DB"},
735 {OPpENTERSUB_HASTARG, ",HASTARG"},
736 {OPpENTERSUB_AMPER, ",AMPER"},
737 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
738 {OPpENTERSUB_INARGS, ",INARGS"}
741 const struct flag_to_name op_const_names[] = {
742 {OPpCONST_NOVER, ",NOVER"},
743 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
744 {OPpCONST_STRICT, ",STRICT"},
745 {OPpCONST_ENTERED, ",ENTERED"},
746 {OPpCONST_FOLDED, ",FOLDED"},
747 {OPpCONST_BARE, ",BARE"}
750 const struct flag_to_name op_sort_names[] = {
751 {OPpSORT_NUMERIC, ",NUMERIC"},
752 {OPpSORT_INTEGER, ",INTEGER"},
753 {OPpSORT_REVERSE, ",REVERSE"},
754 {OPpSORT_INPLACE, ",INPLACE"},
755 {OPpSORT_DESCEND, ",DESCEND"},
756 {OPpSORT_QSORT, ",QSORT"},
757 {OPpSORT_STABLE, ",STABLE"}
760 const struct flag_to_name op_open_names[] = {
761 {OPpOPEN_IN_RAW, ",IN_RAW"},
762 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
763 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
764 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
767 const struct flag_to_name op_exit_names[] = {
768 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
769 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
772 const struct flag_to_name op_sassign_names[] = {
773 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
774 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
777 #define OP_PRIVATE_ONCE(op, flag, name) \
778 const struct flag_to_name CAT2(op, _names)[] = { \
782 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
783 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
784 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
785 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
786 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
787 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
788 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
789 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
790 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
791 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
793 struct op_private_by_op {
796 const struct flag_to_name *start;
799 const struct op_private_by_op op_private_names[] = {
800 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
805 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
806 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
807 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
808 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
809 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
810 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
811 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
812 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
813 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
814 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
815 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
816 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
817 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
818 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
819 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
823 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
824 const struct op_private_by_op *start = op_private_names;
825 const struct op_private_by_op *const end
826 = op_private_names + C_ARRAY_LENGTH(op_private_names);
828 /* This is a linear search, but no worse than the code that it replaced.
829 It's debugging code - size is more important than speed. */
831 if (optype == start->op_type) {
832 S_append_flags(aTHX_ tmpsv, op_private, start->start,
833 start->start + start->len);
836 } while (++start < end);
840 #define DUMP_OP_FLAGS(o,xml,level,file) \
841 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
842 SV * const tmpsv = newSVpvs(""); \
843 switch (o->op_flags & OPf_WANT) { \
844 case OPf_WANT_VOID: \
845 sv_catpv(tmpsv, ",VOID"); \
847 case OPf_WANT_SCALAR: \
848 sv_catpv(tmpsv, ",SCALAR"); \
850 case OPf_WANT_LIST: \
851 sv_catpv(tmpsv, ",LIST"); \
854 sv_catpv(tmpsv, ",UNKNOWN"); \
857 append_flags(tmpsv, o->op_flags, op_flags_names); \
858 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
859 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
860 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
862 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
863 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
865 PerlIO_printf(file, " flags=\"%s\"", \
866 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
867 SvREFCNT_dec_NN(tmpsv); \
870 #if !defined(PERL_MAD)
871 # define xmldump_attr1(level, file, pat, arg)
873 # define xmldump_attr1(level, file, pat, arg) \
874 S_xmldump_attr(aTHX_ level, file, pat, arg)
877 #define DUMP_OP_PRIVATE(o,xml,level,file) \
878 if (o->op_private) { \
879 U32 optype = o->op_type; \
880 U32 oppriv = o->op_private; \
881 SV * const tmpsv = newSVpvs(""); \
882 if (PL_opargs[optype] & OA_TARGLEX) { \
883 if (oppriv & OPpTARGET_MY) \
884 sv_catpv(tmpsv, ",TARGET_MY"); \
886 else if (optype == OP_ENTERSUB || \
887 optype == OP_RV2SV || \
888 optype == OP_GVSV || \
889 optype == OP_RV2AV || \
890 optype == OP_RV2HV || \
891 optype == OP_RV2GV || \
892 optype == OP_AELEM || \
893 optype == OP_HELEM ) \
895 if (optype == OP_ENTERSUB) { \
896 append_flags(tmpsv, oppriv, op_entersub_names); \
899 switch (oppriv & OPpDEREF) { \
901 sv_catpv(tmpsv, ",SV"); \
904 sv_catpv(tmpsv, ",AV"); \
907 sv_catpv(tmpsv, ",HV"); \
910 if (oppriv & OPpMAYBE_LVSUB) \
911 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
913 if (optype == OP_AELEM || optype == OP_HELEM) { \
914 if (oppriv & OPpLVAL_DEFER) \
915 sv_catpv(tmpsv, ",LVAL_DEFER"); \
917 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
918 if (oppriv & OPpMAYBE_TRUEBOOL) \
919 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
920 if (oppriv & OPpTRUEBOOL) \
921 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
924 if (oppriv & HINT_STRICT_REFS) \
925 sv_catpv(tmpsv, ",STRICT_REFS"); \
926 if (oppriv & OPpOUR_INTRO) \
927 sv_catpv(tmpsv, ",OUR_INTRO"); \
930 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
932 else if (OP_IS_FILETEST(o->op_type)) { \
933 if (oppriv & OPpFT_ACCESS) \
934 sv_catpv(tmpsv, ",FT_ACCESS"); \
935 if (oppriv & OPpFT_STACKED) \
936 sv_catpv(tmpsv, ",FT_STACKED"); \
937 if (oppriv & OPpFT_STACKING) \
938 sv_catpv(tmpsv, ",FT_STACKING"); \
939 if (oppriv & OPpFT_AFTER_t) \
940 sv_catpv(tmpsv, ",AFTER_t"); \
942 else if (o->op_type == OP_AASSIGN) { \
943 if (oppriv & OPpASSIGN_COMMON) \
944 sv_catpvs(tmpsv, ",COMMON"); \
945 if (oppriv & OPpMAYBE_LVSUB) \
946 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
948 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
949 sv_catpv(tmpsv, ",INTRO"); \
950 if (o->op_type == OP_PADRANGE) \
951 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
952 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
953 if (SvCUR(tmpsv)) { \
955 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
957 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
959 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
961 SvREFCNT_dec_NN(tmpsv); \
966 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
970 const OPCODE optype = o->op_type;
972 PERL_ARGS_ASSERT_DO_OP_DUMP;
974 Perl_dump_indent(aTHX_ level, file, "{\n");
976 seq = sequence_num(o);
978 PerlIO_printf(file, "%-4"UVuf, seq);
980 PerlIO_printf(file, "????");
982 "%*sTYPE = %s ===> ",
983 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
986 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
987 sequence_num(o->op_next));
989 PerlIO_printf(file, "NULL\n");
991 if (optype == OP_NULL) {
992 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
993 if (o->op_targ == OP_NEXTSTATE) {
995 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
997 if (CopSTASHPV(cCOPo))
998 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1000 if (CopLABEL(cCOPo))
1001 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1006 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1009 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1012 DUMP_OP_FLAGS(o,0,level,file);
1013 DUMP_OP_PRIVATE(o,0,level,file);
1016 if (PL_madskills && o->op_madprop) {
1017 SV * const tmpsv = newSVpvs("");
1018 MADPROP* mp = o->op_madprop;
1019 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1022 const char tmp = mp->mad_key;
1023 sv_setpvs(tmpsv,"'");
1025 sv_catpvn(tmpsv, &tmp, 1);
1026 sv_catpv(tmpsv, "'=");
1027 switch (mp->mad_type) {
1029 sv_catpv(tmpsv, "NULL");
1030 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1033 sv_catpv(tmpsv, "<");
1034 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1035 sv_catpv(tmpsv, ">");
1036 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1039 if ((OP*)mp->mad_val) {
1040 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1041 do_op_dump(level, file, (OP*)mp->mad_val);
1045 sv_catpv(tmpsv, "(UNK)");
1046 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1052 Perl_dump_indent(aTHX_ level, file, "}\n");
1054 SvREFCNT_dec_NN(tmpsv);
1063 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1065 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1066 if (cSVOPo->op_sv) {
1067 SV * const tmpsv = newSV(0);
1071 /* FIXME - is this making unwarranted assumptions about the
1072 UTF-8 cleanliness of the dump file handle? */
1075 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1076 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1077 SvPV_nolen_const(tmpsv));
1081 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1087 case OP_METHOD_NAMED:
1088 #ifndef USE_ITHREADS
1089 /* with ITHREADS, consts are stored in the pad, and the right pad
1090 * may not be active here, so skip */
1091 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1097 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1098 (UV)CopLINE(cCOPo));
1099 if (CopSTASHPV(cCOPo))
1100 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1102 if (CopLABEL(cCOPo))
1103 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1107 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1108 if (cLOOPo->op_redoop)
1109 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1111 PerlIO_printf(file, "DONE\n");
1112 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1113 if (cLOOPo->op_nextop)
1114 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1116 PerlIO_printf(file, "DONE\n");
1117 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1118 if (cLOOPo->op_lastop)
1119 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1121 PerlIO_printf(file, "DONE\n");
1129 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1130 if (cLOGOPo->op_other)
1131 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1133 PerlIO_printf(file, "DONE\n");
1139 do_pmop_dump(level, file, cPMOPo);
1147 if (o->op_private & OPpREFCOUNTED)
1148 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1153 if (o->op_flags & OPf_KIDS) {
1155 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1156 do_op_dump(level, file, kid);
1158 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1162 Perl_op_dump(pTHX_ const OP *o)
1164 PERL_ARGS_ASSERT_OP_DUMP;
1165 do_op_dump(0, Perl_debug_log, o);
1169 Perl_gv_dump(pTHX_ GV *gv)
1173 PERL_ARGS_ASSERT_GV_DUMP;
1176 PerlIO_printf(Perl_debug_log, "{}\n");
1179 sv = sv_newmortal();
1180 PerlIO_printf(Perl_debug_log, "{\n");
1181 gv_fullname3(sv, gv, NULL);
1182 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1183 if (gv != GvEGV(gv)) {
1184 gv_efullname3(sv, GvEGV(gv), NULL);
1185 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1187 PerlIO_putc(Perl_debug_log, '\n');
1188 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1192 /* map magic types to the symbolic names
1193 * (with the PERL_MAGIC_ prefixed stripped)
1196 static const struct { const char type; const char *name; } magic_names[] = {
1197 #include "mg_names.c"
1198 /* this null string terminates the list */
1203 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1205 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1207 for (; mg; mg = mg->mg_moremagic) {
1208 Perl_dump_indent(aTHX_ level, file,
1209 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1210 if (mg->mg_virtual) {
1211 const MGVTBL * const v = mg->mg_virtual;
1212 if (v >= PL_magic_vtables
1213 && v < PL_magic_vtables + magic_vtable_max) {
1214 const U32 i = v - PL_magic_vtables;
1215 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1218 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1221 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1224 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1228 const char *name = NULL;
1229 for (n = 0; magic_names[n].name; n++) {
1230 if (mg->mg_type == magic_names[n].type) {
1231 name = magic_names[n].name;
1236 Perl_dump_indent(aTHX_ level, file,
1237 " MG_TYPE = PERL_MAGIC_%s\n", name);
1239 Perl_dump_indent(aTHX_ level, file,
1240 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1244 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1245 if (mg->mg_type == PERL_MAGIC_envelem &&
1246 mg->mg_flags & MGf_TAINTEDDIR)
1247 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1248 if (mg->mg_type == PERL_MAGIC_regex_global &&
1249 mg->mg_flags & MGf_MINMATCH)
1250 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1251 if (mg->mg_flags & MGf_REFCOUNTED)
1252 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1253 if (mg->mg_flags & MGf_GSKIP)
1254 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1255 if (mg->mg_flags & MGf_COPY)
1256 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1257 if (mg->mg_flags & MGf_DUP)
1258 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1259 if (mg->mg_flags & MGf_LOCAL)
1260 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1263 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1264 PTR2UV(mg->mg_obj));
1265 if (mg->mg_type == PERL_MAGIC_qr) {
1266 REGEXP* const re = (REGEXP *)mg->mg_obj;
1267 SV * const dsv = sv_newmortal();
1268 const char * const s
1269 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1271 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1272 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1274 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1275 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1278 if (mg->mg_flags & MGf_REFCOUNTED)
1279 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1282 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1284 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1285 if (mg->mg_len >= 0) {
1286 if (mg->mg_type != PERL_MAGIC_utf8) {
1287 SV * const sv = newSVpvs("");
1288 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1289 SvREFCNT_dec_NN(sv);
1292 else if (mg->mg_len == HEf_SVKEY) {
1293 PerlIO_puts(file, " => HEf_SVKEY\n");
1294 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1295 maxnest, dumpops, pvlim); /* MG is already +1 */
1298 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1303 " does not know how to handle this MG_LEN"
1305 PerlIO_putc(file, '\n');
1307 if (mg->mg_type == PERL_MAGIC_utf8) {
1308 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1311 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1312 Perl_dump_indent(aTHX_ level, file,
1313 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1316 (UV)cache[i * 2 + 1]);
1323 Perl_magic_dump(pTHX_ const MAGIC *mg)
1325 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1329 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1333 PERL_ARGS_ASSERT_DO_HV_DUMP;
1335 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1336 if (sv && (hvname = HvNAME_get(sv)))
1338 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1339 name which quite legally could contain insane things like tabs, newlines, nulls or
1340 other scary crap - this should produce sane results - except maybe for unicode package
1341 names - but we will wait for someone to file a bug on that - demerphq */
1342 SV * const tmpsv = newSVpvs("");
1343 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1346 PerlIO_putc(file, '\n');
1350 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1352 PERL_ARGS_ASSERT_DO_GV_DUMP;
1354 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1355 if (sv && GvNAME(sv))
1356 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1358 PerlIO_putc(file, '\n');
1362 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1364 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1366 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1367 if (sv && GvNAME(sv)) {
1369 PerlIO_printf(file, "\t\"");
1370 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1371 PerlIO_printf(file, "%s\" :: \"", hvname);
1372 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1375 PerlIO_putc(file, '\n');
1378 const struct flag_to_name first_sv_flags_names[] = {
1379 {SVs_TEMP, "TEMP,"},
1380 {SVs_OBJECT, "OBJECT,"},
1389 const struct flag_to_name second_sv_flags_names[] = {
1391 {SVf_FAKE, "FAKE,"},
1392 {SVf_READONLY, "READONLY,"},
1393 {SVf_IsCOW, "IsCOW,"},
1394 {SVf_BREAK, "BREAK,"},
1395 {SVf_AMAGIC, "OVERLOAD,"},
1401 const struct flag_to_name cv_flags_names[] = {
1402 {CVf_ANON, "ANON,"},
1403 {CVf_UNIQUE, "UNIQUE,"},
1404 {CVf_CLONE, "CLONE,"},
1405 {CVf_CLONED, "CLONED,"},
1406 {CVf_CONST, "CONST,"},
1407 {CVf_NODEBUG, "NODEBUG,"},
1408 {CVf_LVALUE, "LVALUE,"},
1409 {CVf_METHOD, "METHOD,"},
1410 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1411 {CVf_CVGV_RC, "CVGV_RC,"},
1412 {CVf_DYNFILE, "DYNFILE,"},
1413 {CVf_AUTOLOAD, "AUTOLOAD,"},
1414 {CVf_HASEVAL, "HASEVAL"},
1415 {CVf_SLABBED, "SLABBED,"},
1416 {CVf_ISXSUB, "ISXSUB,"}
1419 const struct flag_to_name hv_flags_names[] = {
1420 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1421 {SVphv_LAZYDEL, "LAZYDEL,"},
1422 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1423 {SVphv_CLONEABLE, "CLONEABLE,"}
1426 const struct flag_to_name gp_flags_names[] = {
1427 {GVf_INTRO, "INTRO,"},
1428 {GVf_MULTI, "MULTI,"},
1429 {GVf_ASSUMECV, "ASSUMECV,"},
1430 {GVf_IN_PAD, "IN_PAD,"}
1433 const struct flag_to_name gp_flags_imported_names[] = {
1434 {GVf_IMPORTED_SV, " SV"},
1435 {GVf_IMPORTED_AV, " AV"},
1436 {GVf_IMPORTED_HV, " HV"},
1437 {GVf_IMPORTED_CV, " CV"},
1440 const struct flag_to_name regexp_flags_names[] = {
1441 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1442 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1443 {RXf_PMf_FOLD, "PMf_FOLD,"},
1444 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1445 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1446 {RXf_ANCH_BOL, "ANCH_BOL,"},
1447 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1448 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1449 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1450 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1451 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1452 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1453 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1454 {RXf_CANY_SEEN, "CANY_SEEN,"},
1455 {RXf_NOSCAN, "NOSCAN,"},
1456 {RXf_CHECK_ALL, "CHECK_ALL,"},
1457 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1458 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1459 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1460 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1461 {RXf_COPY_DONE, "COPY_DONE,"},
1462 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1463 {RXf_TAINTED, "TAINTED,"},
1464 {RXf_START_ONLY, "START_ONLY,"},
1465 {RXf_WHITE, "WHITE,"},
1466 {RXf_NULL, "NULL,"},
1470 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1478 PERL_ARGS_ASSERT_DO_SV_DUMP;
1481 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1485 flags = SvFLAGS(sv);
1488 /* process general SV flags */
1490 d = Perl_newSVpvf(aTHX_
1491 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1492 PTR2UV(SvANY(sv)), PTR2UV(sv),
1493 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1494 (int)(PL_dumpindent*level), "");
1496 if (!((flags & SVpad_NAME) == SVpad_NAME
1497 && (type == SVt_PVMG || type == SVt_PVNV))) {
1498 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1499 sv_catpv(d, "PADSTALE,");
1501 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1502 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1503 sv_catpv(d, "PADTMP,");
1504 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1506 append_flags(d, flags, first_sv_flags_names);
1507 if (flags & SVf_ROK) {
1508 sv_catpv(d, "ROK,");
1509 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1511 append_flags(d, flags, second_sv_flags_names);
1512 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1513 if (SvPCS_IMPORTED(sv))
1514 sv_catpv(d, "PCS_IMPORTED,");
1516 sv_catpv(d, "SCREAM,");
1519 /* process type-specific SV flags */
1524 append_flags(d, CvFLAGS(sv), cv_flags_names);
1527 append_flags(d, flags, hv_flags_names);
1531 if (isGV_with_GP(sv)) {
1532 append_flags(d, GvFLAGS(sv), gp_flags_names);
1534 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1535 sv_catpv(d, "IMPORT");
1536 if (GvIMPORTED(sv) == GVf_IMPORTED)
1537 sv_catpv(d, "ALL,");
1540 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1547 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1548 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1551 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1552 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1553 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1554 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1557 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1562 /* SVphv_SHAREKEYS is also 0x20000000 */
1563 if ((type != SVt_PVHV) && SvUTF8(sv))
1564 sv_catpv(d, "UTF8");
1566 if (*(SvEND(d) - 1) == ',') {
1567 SvCUR_set(d, SvCUR(d) - 1);
1568 SvPVX(d)[SvCUR(d)] = '\0';
1573 /* dump initial SV details */
1575 #ifdef DEBUG_LEAKING_SCALARS
1576 Perl_dump_indent(aTHX_ level, file,
1577 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1578 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1580 sv->sv_debug_inpad ? "for" : "by",
1581 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1582 PTR2UV(sv->sv_debug_parent),
1586 Perl_dump_indent(aTHX_ level, file, "SV = ");
1590 if (type < SVt_LAST) {
1591 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1593 if (type == SVt_NULL) {
1598 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1603 /* Dump general SV fields */
1605 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1606 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1607 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1608 || (type == SVt_IV && !SvROK(sv))) {
1610 #ifdef PERL_OLD_COPY_ON_WRITE
1614 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1616 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1617 #ifdef PERL_OLD_COPY_ON_WRITE
1618 if (SvIsCOW_shared_hash(sv))
1619 PerlIO_printf(file, " (HASH)");
1620 else if (SvIsCOW_normal(sv))
1621 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1623 PerlIO_putc(file, '\n');
1626 if ((type == SVt_PVNV || type == SVt_PVMG)
1627 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1628 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1629 (UV) COP_SEQ_RANGE_LOW(sv));
1630 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1631 (UV) COP_SEQ_RANGE_HIGH(sv));
1632 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1633 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1634 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1635 || type == SVt_NV) {
1636 STORE_NUMERIC_LOCAL_SET_STANDARD();
1637 /* %Vg doesn't work? --jhi */
1638 #ifdef USE_LONG_DOUBLE
1639 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1641 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1643 RESTORE_NUMERIC_LOCAL();
1647 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1649 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1652 if (type < SVt_PV) {
1657 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1658 const bool re = isREGEXP(sv);
1659 const char * const ptr =
1660 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1664 SvOOK_offset(sv, delta);
1665 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1670 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1672 PerlIO_printf(file, "( %s . ) ",
1673 pv_display(d, ptr - delta, delta, 0,
1676 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1679 if (SvUTF8(sv)) /* the 6? \x{....} */
1680 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1681 PerlIO_printf(file, "\n");
1682 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1684 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1686 #ifdef PERL_NEW_COPY_ON_WRITE
1687 if (SvIsCOW(sv) && SvLEN(sv))
1688 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1693 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1696 if (type >= SVt_PVMG) {
1697 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1698 HV * const ost = SvOURSTASH(sv);
1700 do_hv_dump(level, file, " OURSTASH", ost);
1703 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1706 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1708 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1709 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1710 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1711 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1715 /* Dump type-specific SV fields */
1719 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1720 if (AvARRAY(sv) != AvALLOC(sv)) {
1721 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1722 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1725 PerlIO_putc(file, '\n');
1726 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1727 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1728 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1730 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1731 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1732 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1733 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1734 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1736 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1737 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1739 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1741 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1746 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1747 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1748 /* Show distribution of HEs in the ARRAY */
1750 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1753 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1754 NV theoret, sum = 0;
1756 PerlIO_printf(file, " (");
1757 Zero(freq, FREQ_MAX + 1, int);
1758 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1761 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1763 if (count > FREQ_MAX)
1769 for (i = 0; i <= max; i++) {
1771 PerlIO_printf(file, "%d%s:%d", i,
1772 (i == FREQ_MAX) ? "+" : "",
1775 PerlIO_printf(file, ", ");
1778 PerlIO_putc(file, ')');
1779 /* The "quality" of a hash is defined as the total number of
1780 comparisons needed to access every element once, relative
1781 to the expected number needed for a random hash.
1783 The total number of comparisons is equal to the sum of
1784 the squares of the number of entries in each bucket.
1785 For a random hash of n keys into k buckets, the expected
1790 for (i = max; i > 0; i--) { /* Precision: count down. */
1791 sum += freq[i] * i * i;
1793 while ((keys = keys >> 1))
1795 theoret = HvUSEDKEYS(sv);
1796 theoret += theoret * (theoret-1)/pow2;
1797 PerlIO_putc(file, '\n');
1798 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1800 PerlIO_putc(file, '\n');
1801 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1802 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1803 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1804 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1805 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1807 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1808 if (mg && mg->mg_obj) {
1809 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1813 const char * const hvname = HvNAME_get(sv);
1815 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1819 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1820 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1821 if (HvAUX(sv)->xhv_name_count)
1822 Perl_dump_indent(aTHX_
1823 level, file, " NAMECOUNT = %"IVdf"\n",
1824 (IV)HvAUX(sv)->xhv_name_count
1826 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1827 const I32 count = HvAUX(sv)->xhv_name_count;
1829 SV * const names = newSVpvs_flags("", SVs_TEMP);
1830 /* The starting point is the first element if count is
1831 positive and the second element if count is negative. */
1832 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1833 + (count < 0 ? 1 : 0);
1834 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1835 + (count < 0 ? -count : count);
1836 while (hekp < endp) {
1838 sv_catpvs(names, ", \"");
1839 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1840 sv_catpvs(names, "\"");
1842 /* This should never happen. */
1843 sv_catpvs(names, ", (null)");
1847 Perl_dump_indent(aTHX_
1848 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1852 Perl_dump_indent(aTHX_
1853 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1857 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1859 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1863 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1864 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1865 (int)meta->mro_which->length,
1866 meta->mro_which->name,
1867 PTR2UV(meta->mro_which));
1868 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1869 (UV)meta->cache_gen);
1870 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1872 if (meta->mro_linear_all) {
1873 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1874 PTR2UV(meta->mro_linear_all));
1875 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1878 if (meta->mro_linear_current) {
1879 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1880 PTR2UV(meta->mro_linear_current));
1881 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1884 if (meta->mro_nextmethod) {
1885 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1886 PTR2UV(meta->mro_nextmethod));
1887 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1891 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1893 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1898 if (nest < maxnest) {
1899 HV * const hv = MUTABLE_HV(sv);
1904 int count = maxnest - nest;
1905 for (i=0; i <= HvMAX(hv); i++) {
1906 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1913 if (count-- <= 0) goto DONEHV;
1916 keysv = hv_iterkeysv(he);
1917 keypv = SvPV_const(keysv, len);
1920 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1922 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1923 if (HvEITER_get(hv) == he)
1924 PerlIO_printf(file, "[CURRENT] ");
1925 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1926 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1935 if (CvAUTOLOAD(sv)) {
1937 const char *const name = SvPV_const(sv, len);
1938 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1942 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1943 (int) CvPROTOLEN(sv), CvPROTO(sv));
1947 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1948 if (!CvISXSUB(sv)) {
1950 Perl_dump_indent(aTHX_ level, file,
1951 " START = 0x%"UVxf" ===> %"IVdf"\n",
1952 PTR2UV(CvSTART(sv)),
1953 (IV)sequence_num(CvSTART(sv)));
1955 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1956 PTR2UV(CvROOT(sv)));
1957 if (CvROOT(sv) && dumpops) {
1958 do_op_dump(level+1, file, CvROOT(sv));
1961 SV * const constant = cv_const_sv((const CV *)sv);
1963 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1966 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1968 PTR2UV(CvXSUBANY(sv).any_ptr));
1969 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1972 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1973 (IV)CvXSUBANY(sv).any_i32);
1977 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1978 HEK_KEY(CvNAME_HEK((CV *)sv)));
1979 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1980 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1981 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1982 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1983 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1984 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1985 if (nest < maxnest) {
1986 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1989 const CV * const outside = CvOUTSIDE(sv);
1990 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1993 : CvANON(outside) ? "ANON"
1994 : (outside == PL_main_cv) ? "MAIN"
1995 : CvUNIQUE(outside) ? "UNIQUE"
1996 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1998 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1999 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2004 if (type == SVt_PVLV) {
2005 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2006 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2007 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2008 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2009 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2010 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2011 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2014 if (isREGEXP(sv)) goto dumpregexp;
2015 if (!isGV_with_GP(sv))
2017 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2018 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2019 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2020 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2023 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2024 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2025 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2026 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2027 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2028 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2029 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2030 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2031 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2032 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2033 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2034 do_gv_dump (level, file, " EGV", GvEGV(sv));
2037 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2041 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2042 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2043 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2045 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2046 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2047 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2049 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2050 PTR2UV(IoTOP_GV(sv)));
2051 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2052 maxnest, dumpops, pvlim);
2054 /* Source filters hide things that are not GVs in these three, so let's
2055 be careful out there. */
2057 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2058 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2059 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2061 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2062 PTR2UV(IoFMT_GV(sv)));
2063 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2064 maxnest, dumpops, pvlim);
2066 if (IoBOTTOM_NAME(sv))
2067 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2068 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2069 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2071 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2072 PTR2UV(IoBOTTOM_GV(sv)));
2073 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2074 maxnest, dumpops, pvlim);
2076 if (isPRINT(IoTYPE(sv)))
2077 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2079 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2080 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2085 struct regexp * const r = ReANY((REGEXP*)sv);
2086 flags = RX_EXTFLAGS((REGEXP*)sv);
2088 append_flags(d, flags, regexp_flags_names);
2089 if (*(SvEND(d) - 1) == ',') {
2090 SvCUR_set(d, SvCUR(d) - 1);
2091 SvPVX(d)[SvCUR(d)] = '\0';
2093 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2094 (UV)flags, SvPVX_const(d));
2095 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2097 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2099 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2100 (UV)(r->lastparen));
2101 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2102 (UV)(r->lastcloseparen));
2103 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2105 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2106 (IV)(r->minlenret));
2107 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2109 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2110 (UV)(r->pre_prefix));
2111 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2113 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2114 (IV)(r->suboffset));
2115 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2116 (IV)(r->subcoffset));
2118 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2120 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2122 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2123 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2125 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2126 PTR2UV(r->mother_re));
2127 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2128 PTR2UV(r->paren_names));
2129 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2130 PTR2UV(r->substrs));
2131 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2132 PTR2UV(r->pprivate));
2133 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2135 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2136 PTR2UV(r->qr_anoncv));
2138 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2139 PTR2UV(r->saved_copy));
2148 Perl_sv_dump(pTHX_ SV *sv)
2152 PERL_ARGS_ASSERT_SV_DUMP;
2155 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2157 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2161 Perl_runops_debug(pTHX)
2165 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2169 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2172 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2173 PerlIO_printf(Perl_debug_log,
2174 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2175 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2176 PTR2UV(*PL_watchaddr));
2177 if (DEBUG_s_TEST_) {
2178 if (DEBUG_v_TEST_) {
2179 PerlIO_printf(Perl_debug_log, "\n");
2187 if (DEBUG_t_TEST_) debop(PL_op);
2188 if (DEBUG_P_TEST_) debprof(PL_op);
2191 OP_ENTRY_PROBE(OP_NAME(PL_op));
2192 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2193 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2200 Perl_debop(pTHX_ const OP *o)
2204 PERL_ARGS_ASSERT_DEBOP;
2206 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2209 Perl_deb(aTHX_ "%s", OP_NAME(o));
2210 switch (o->op_type) {
2213 /* With ITHREADS, consts are stored in the pad, and the right pad
2214 * may not be active here, so check.
2215 * Looks like only during compiling the pads are illegal.
2218 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2220 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2225 SV * const sv = newSV(0);
2227 /* FIXME - is this making unwarranted assumptions about the
2228 UTF-8 cleanliness of the dump file handle? */
2231 gv_fullname3(sv, cGVOPo_gv, NULL);
2232 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2233 SvREFCNT_dec_NN(sv);
2236 PerlIO_printf(Perl_debug_log, "(NULL)");
2248 count = o->op_private & OPpPADRANGE_COUNTMASK;
2250 /* print the lexical's name */
2252 CV * const cv = deb_curcv(cxstack_ix);
2254 PAD * comppad = NULL;
2258 PADLIST * const padlist = CvPADLIST(cv);
2259 comppad = *PadlistARRAY(padlist);
2261 PerlIO_printf(Perl_debug_log, "(");
2262 for (i = 0; i < count; i++) {
2264 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2265 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2267 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2270 PerlIO_printf(Perl_debug_log, ",");
2272 PerlIO_printf(Perl_debug_log, ")");
2280 PerlIO_printf(Perl_debug_log, "\n");
2285 S_deb_curcv(pTHX_ const I32 ix)
2288 const PERL_CONTEXT * const cx = &cxstack[ix];
2289 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2290 return cx->blk_sub.cv;
2291 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2292 return cx->blk_eval.cv;
2293 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2298 return deb_curcv(ix - 1);
2302 Perl_watch(pTHX_ char **addr)
2306 PERL_ARGS_ASSERT_WATCH;
2308 PL_watchaddr = addr;
2310 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2311 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2315 S_debprof(pTHX_ const OP *o)
2319 PERL_ARGS_ASSERT_DEBPROF;
2321 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2323 if (!PL_profiledata)
2324 Newxz(PL_profiledata, MAXO, U32);
2325 ++PL_profiledata[o->op_type];
2329 Perl_debprofdump(pTHX)
2333 if (!PL_profiledata)
2335 for (i = 0; i < MAXO; i++) {
2336 if (PL_profiledata[i])
2337 PerlIO_printf(Perl_debug_log,
2338 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2345 * XML variants of most of the above routines
2349 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2353 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2355 PerlIO_printf(file, "\n ");
2356 va_start(args, pat);
2357 xmldump_vindent(level, file, pat, &args);
2363 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2366 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2367 va_start(args, pat);
2368 xmldump_vindent(level, file, pat, &args);
2373 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2375 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2377 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2378 PerlIO_vprintf(file, pat, *args);
2382 Perl_xmldump_all(pTHX)
2384 xmldump_all_perl(FALSE);
2388 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2390 PerlIO_setlinebuf(PL_xmlfp);
2392 op_xmldump(PL_main_root);
2393 /* someday we might call this, when it outputs XML: */
2394 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2395 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2396 PerlIO_close(PL_xmlfp);
2401 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2403 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2404 xmldump_packsubs_perl(stash, FALSE);
2408 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2413 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2415 if (!HvARRAY(stash))
2417 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2418 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2419 GV *gv = MUTABLE_GV(HeVAL(entry));
2421 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2424 xmldump_sub_perl(gv, justperl);
2427 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2428 && (hv = GvHV(gv)) && hv != PL_defstash)
2429 xmldump_packsubs_perl(hv, justperl); /* nested package */
2435 Perl_xmldump_sub(pTHX_ const GV *gv)
2437 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2438 xmldump_sub_perl(gv, FALSE);
2442 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2446 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2448 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2451 sv = sv_newmortal();
2452 gv_fullname3(sv, gv, NULL);
2453 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2454 if (CvXSUB(GvCV(gv)))
2455 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2456 PTR2UV(CvXSUB(GvCV(gv))),
2457 (int)CvXSUBANY(GvCV(gv)).any_i32);
2458 else if (CvROOT(GvCV(gv)))
2459 op_xmldump(CvROOT(GvCV(gv)));
2461 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2465 Perl_xmldump_form(pTHX_ const GV *gv)
2467 SV * const sv = sv_newmortal();
2469 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2471 gv_fullname3(sv, gv, NULL);
2472 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2473 if (CvROOT(GvFORM(gv)))
2474 op_xmldump(CvROOT(GvFORM(gv)));
2476 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2480 Perl_xmldump_eval(pTHX)
2482 op_xmldump(PL_eval_root);
2486 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2488 PERL_ARGS_ASSERT_SV_CATXMLSV;
2489 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2493 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2495 PERL_ARGS_ASSERT_SV_CATXMLPV;
2496 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2500 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2503 const char * const e = pv + len;
2504 const char * const start = pv;
2508 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2511 dsvcur = SvCUR(dsv); /* in case we have to restart */
2516 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2518 SvCUR(dsv) = dsvcur;
2583 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2586 sv_catpvs(dsv, "<");
2589 sv_catpvs(dsv, ">");
2592 sv_catpvs(dsv, "&");
2595 sv_catpvs(dsv, """);
2599 if (c < 32 || c > 127) {
2600 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2603 const char string = (char) c;
2604 sv_catpvn(dsv, &string, 1);
2608 if ((c >= 0xD800 && c <= 0xDB7F) ||
2609 (c >= 0xDC00 && c <= 0xDFFF) ||
2610 (c >= 0xFFF0 && c <= 0xFFFF) ||
2612 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2614 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2627 Perl_sv_xmlpeek(pTHX_ SV *sv)
2629 SV * const t = sv_newmortal();
2633 PERL_ARGS_ASSERT_SV_XMLPEEK;
2639 sv_catpv(t, "VOID=\"\"");
2642 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2643 sv_catpv(t, "WILD=\"\"");
2646 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2647 if (sv == &PL_sv_undef) {
2648 sv_catpv(t, "SV_UNDEF=\"1\"");
2649 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2650 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2654 else if (sv == &PL_sv_no) {
2655 sv_catpv(t, "SV_NO=\"1\"");
2656 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2657 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2658 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2659 SVp_POK|SVp_NOK)) &&
2664 else if (sv == &PL_sv_yes) {
2665 sv_catpv(t, "SV_YES=\"1\"");
2666 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2667 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2668 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2669 SVp_POK|SVp_NOK)) &&
2671 SvPVX(sv) && *SvPVX(sv) == '1' &&
2676 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2677 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2678 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2682 sv_catpv(t, " XXX=\"\" ");
2684 else if (SvREFCNT(sv) == 0) {
2685 sv_catpv(t, " refcnt=\"0\"");
2688 else if (DEBUG_R_TEST_) {
2691 /* is this SV on the tmps stack? */
2692 for (ix=PL_tmps_ix; ix>=0; ix--) {
2693 if (PL_tmps_stack[ix] == sv) {
2698 if (SvREFCNT(sv) > 1)
2699 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2702 sv_catpv(t, " DRT=\"<T>\"");
2706 sv_catpv(t, " ROK=\"\"");
2708 switch (SvTYPE(sv)) {
2710 sv_catpv(t, " FREED=\"1\"");
2714 sv_catpv(t, " UNDEF=\"1\"");
2717 sv_catpv(t, " IV=\"");
2720 sv_catpv(t, " NV=\"");
2723 sv_catpv(t, " PV=\"");
2726 sv_catpv(t, " PVIV=\"");
2729 sv_catpv(t, " PVNV=\"");
2732 sv_catpv(t, " PVMG=\"");
2735 sv_catpv(t, " PVLV=\"");
2738 sv_catpv(t, " AV=\"");
2741 sv_catpv(t, " HV=\"");
2745 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2747 sv_catpv(t, " CV=\"()\"");
2750 sv_catpv(t, " GV=\"");
2753 sv_catpv(t, " BIND=\"");
2756 sv_catpv(t, " REGEXP=\"");
2759 sv_catpv(t, " FM=\"");
2762 sv_catpv(t, " IO=\"");
2771 else if (SvNOKp(sv)) {
2772 STORE_NUMERIC_LOCAL_SET_STANDARD();
2773 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2774 RESTORE_NUMERIC_LOCAL();
2776 else if (SvIOKp(sv)) {
2778 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2780 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2789 return SvPV(t, n_a);
2793 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2795 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2798 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2801 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2804 REGEXP *const r = PM_GETRE(pm);
2805 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2806 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2807 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2809 SvREFCNT_dec_NN(tmpsv);
2810 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2811 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2814 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2815 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2816 SV * const tmpsv = pm_description(pm);
2817 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2818 SvREFCNT_dec_NN(tmpsv);
2822 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2823 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2824 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2825 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2826 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2827 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2830 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2834 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2836 do_pmop_xmldump(0, PL_xmlfp, pm);
2840 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2844 const OPCODE optype = o->op_type;
2846 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2850 seq = sequence_num(o);
2851 Perl_xmldump_indent(aTHX_ level, file,
2852 "<op_%s seq=\"%"UVuf" -> ",
2857 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2858 sequence_num(o->op_next));
2860 PerlIO_printf(file, "DONE\"");
2863 if (optype == OP_NULL)
2865 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2866 if (o->op_targ == OP_NEXTSTATE)
2869 PerlIO_printf(file, " line=\"%"UVuf"\"",
2870 (UV)CopLINE(cCOPo));
2871 if (CopSTASHPV(cCOPo))
2872 PerlIO_printf(file, " package=\"%s\"",
2874 if (CopLABEL(cCOPo))
2875 PerlIO_printf(file, " label=\"%s\"",
2880 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2883 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2886 DUMP_OP_FLAGS(o,1,0,file);
2887 DUMP_OP_PRIVATE(o,1,0,file);
2891 if (o->op_flags & OPf_SPECIAL) {
2897 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2899 if (cSVOPo->op_sv) {
2900 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2901 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2907 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2908 s = SvPV(tmpsv1,len);
2909 sv_catxmlpvn(tmpsv2, s, len, 1);
2910 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2914 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2919 case OP_METHOD_NAMED:
2920 #ifndef USE_ITHREADS
2921 /* with ITHREADS, consts are stored in the pad, and the right pad
2922 * may not be active here, so skip */
2923 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2929 PerlIO_printf(file, ">\n");
2931 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2936 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2937 (UV)CopLINE(cCOPo));
2938 if (CopSTASHPV(cCOPo))
2939 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2941 if (CopLABEL(cCOPo))
2942 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2946 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2947 if (cLOOPo->op_redoop)
2948 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2950 PerlIO_printf(file, "DONE\"");
2951 S_xmldump_attr(aTHX_ level, file, "next=\"");
2952 if (cLOOPo->op_nextop)
2953 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2955 PerlIO_printf(file, "DONE\"");
2956 S_xmldump_attr(aTHX_ level, file, "last=\"");
2957 if (cLOOPo->op_lastop)
2958 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2960 PerlIO_printf(file, "DONE\"");
2968 S_xmldump_attr(aTHX_ level, file, "other=\"");
2969 if (cLOGOPo->op_other)
2970 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2972 PerlIO_printf(file, "DONE\"");
2980 if (o->op_private & OPpREFCOUNTED)
2981 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2987 if (PL_madskills && o->op_madprop) {
2988 char prevkey = '\0';
2989 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2990 const MADPROP* mp = o->op_madprop;
2994 PerlIO_printf(file, ">\n");
2996 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2999 char tmp = mp->mad_key;
3000 sv_setpvs(tmpsv,"\"");
3002 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3003 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3004 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3007 sv_catpv(tmpsv, "\"");
3008 switch (mp->mad_type) {
3010 sv_catpv(tmpsv, "NULL");
3011 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3014 sv_catpv(tmpsv, " val=\"");
3015 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3016 sv_catpv(tmpsv, "\"");
3017 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3020 sv_catpv(tmpsv, " val=\"");
3021 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3022 sv_catpv(tmpsv, "\"");
3023 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3026 if ((OP*)mp->mad_val) {
3027 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3028 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3029 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3033 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3039 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3041 SvREFCNT_dec_NN(tmpsv);
3051 PerlIO_printf(file, ">\n");
3053 do_pmop_xmldump(level, file, cPMOPo);
3059 if (o->op_flags & OPf_KIDS) {
3063 PerlIO_printf(file, ">\n");
3065 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3066 do_op_xmldump(level, file, kid);
3070 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3072 PerlIO_printf(file, " />\n");
3076 Perl_op_xmldump(pTHX_ const OP *o)
3078 PERL_ARGS_ASSERT_OP_XMLDUMP;
3080 do_op_xmldump(0, PL_xmlfp, o);
3086 * c-indentation-style: bsd
3088 * indent-tabs-mode: nil
3091 * ex: set ts=8 sts=4 sw=4 et: